[MLton-devel] cvs commit: source-level profiling

Stephen Weeks sweeks@users.sourceforge.net
Thu, 19 Dec 2002 15:43:37 -0800


sweeks      02/12/19 15:43:37

  Modified:    doc      changelog
               include  ccodegen.h x86codegen.h
               mlprof   main.sml
               mlton    Makefile mlton-stubs-1997.cm mlton-stubs.cm
                        mlton.cm
               mlton/backend backend.fun c-function.fun c-function.sig
                        implement-handlers.fun limit-check.fun
                        machine-atoms.fun machine-atoms.sig machine.fun
                        machine.sig rssa.fun rssa.sig signal-check.fun
                        sources.cm ssa-to-rssa.fun ssa-to-rssa.sig
               mlton/closure-convert closure-convert.fun
               mlton/codegen/c-codegen c-codegen.fun c-codegen.sig
               mlton/codegen/x86-codegen x86-codegen.fun
                        x86-generate-transfers.fun x86-mlton.fun
                        x86-mlton.sig x86-pseudo.sig x86-translate.fun
                        x86-translate.sig
               mlton/control control.sig control.sml
               mlton/main compile.sml main.sml
               mlton/ssa analyze.fun common-block.fun common-subexp.fun
                        constant-propagation.fun contify.fun flatten.fun
                        inline.fun introduce-loops.fun known-case.fun
                        local-flatten.fun local-ref.fun loop-invariant.fun
                        poly-equal.fun redundant-tests.fun redundant.fun
                        remove-unused.fun restore.fun shrink.fun
                        simplify-types.fun source-info.fun source-info.sig
                        ssa-tree.fun ssa-tree.sig type-check.fun
                        useless.fun
               runtime  gc.c gc.h
               runtime/basis/MLton profile-alloc.c profile-time.c
  Added:       include  codegen.h
               mlton/backend profile.fun profile.sig
  Removed:     mlton/backend profile-alloc.fun profile-alloc.sig
  Log:
  Second whack at source-level profiling.  Here's how it works.
  
  Associate source positions (file and line) with functions in the
  source and propagate through to the SSA.  In the closure converter,
  when first creating each SSA function with associated source info si,
  insert an "Enter si" profile statement at the beginning of the
  function and a "Leave si" profile statement before each return, raise,
  or tail call (see Ssa.Function.profile).  Then, all of the SSA
  simplifier passes preserve the Enter/Leave statements.  The SSA type
  checker checks that the Enter/Leave statements properly nested (in the
  sense of balanced parentheses).  This required a few changes to the
  SSA simplifier (see below).
  
  The Enter/Leaves are directly translated into RSSA and preserved by
  all of the RSSA passes.  At the end of the RSSA passes, the profile
  pass (see backend/profile.fun) uses the Enter/Leave statements to
  determine the stack of source functions at each program point.  It
  does this by a simple depth-first search of the basic blocks in the
  function, keeping track of the stack of source functions, pushing for
  Enter and popping for Leave.  For time profiling, it inserts a
  ProfileLabel statement at the beginning of each basic block and at
  each point within the basic block that the source info stack changes.
  For allocation profiling, it inserts assignments to
  gcState.profileAllocIndex and calls to GC_ProfileAlloc_inc whenever
  the source stack changes.
  
  In addition to instrumenting the program, the profiling pass produces
  four pieces of information (see Machine.ProfileInfo.t)
  
  1. sources: SourceInfo.t vector
  	This is used to share source info.  Each source info appears
  	in sources once.  Other information refers to source info by
  	indexing into this vector.
  2. sourceSeqs: int vector vector
  	This contains all of the local source stacks seen by the
  	profile pass, given as vectors of indices into sources.
  	Other information refers to source stacks by indexing into
  	this vector
  3. frameSources: int vector
  	This describes the source stack that the profile pass
  	inferred at each continuation.
  4. labels: {label: ProfileLabel.t,
              sourceSeqsIndex: int} vector
  	This is only used for time profiling.  It records the source
  	stack that the the profile pass associates with each profile
  	label.
  
  All of this information is output into the C file as structs/arrays
  and is stored in gcState at program initialization.  All the codegen
  has to do is spit out the profileLabels.  This was another nice thing
  about the new approach that should make profiling easier with new
  codegens (or even with the C codegen, where it has been disabled for
  ages).
  
  At run time, time profiling first sorts the labels array in increasing
  order of label, and uses that to build an array (gcState.textSources)
  that maps program address to sourceSeqs index.  A unit of time
  profiling data then just needs to keep an array of counts with one
  entry for each source info.  When the profiling signal handler gets an
  interrupt, it looks up the sourceSeqs index in textSources, then looks
  up the sources index in sourceSeqs, and bumps the appropriate counter
  in the profiling data.
  
  Space profiling is similar.  The RSSA profiling pass has already
  inserted the assignments to gcState.profileAllocIndex and calls to
  MLton_ProfileAlloc_inc, which then has to look up the sourceSeq and
  source index and bump the counter.
  
  The data stored in an mlmon.out file is now very simple.  First off,
  the file is now a text file, not a binary file.  The file contains a
  flag indicating whether it is allocation or time data and then the
  array of counts corresponding to the sources.  There is a new runtime
  argument, show-prof, which prints out the strings in the sources
  array.  mlprof uses show-prof, zips up the sources with the counts,
  and has the profiling data.  There is no notion of depth for now.
  
  All of this is how profiling of "leaf" source-level profiling works.
  That is, the counts (be they clock ticks or bytes allocated) are
  associated with leaves in the call graph.  Coming soon, I will add the
  ability to have the (alloc or time) profiler walk the stack and bump a
  counter for all the functions on the call stack.  Then, the deeper
  sources in each sourceSeq and the frameSources will be used to map the
  SSA call stack into the source call stack.  The mlmon file will still
  be the same, the counts will just denote how often the function was on
  the call stack.  This should give a clearer picture of where time is
  being spent by the major functions program (kind of like our pass
  timings with MLton -v2).
  
  Now, for a few notes.
  
  I added a new flag, -keep machine, since the Machine code is now much
  more readable and has much more sensible type info.
  
  I got tired of making repeated changes to x86codegen.h and ccodegen.h,
  so I created a new file, codegen.h, that captures all the similar code
  from them.
  
  I had to make a few changes to the SSA simplifier and the Enter/Leave
  checker in order match Enter/Leave statements.
  1. Because removeUnused can turn a nontail call into a tail call with
  	a Dead continuation but does not know to "pop" the Enter/Leave
  	stack before the call, the Enter/Leave checker allows any
  	stack before a Dead.  This is unlike Tail calls, where it
  	requires the stack to be empty.
  2. Because of 1, the contifier is not allowed to contify a function
  	that is called with a Dead continuation -- the Enter/Leave
  	stack might not match if it does.  Similarly for
  	introduce-loops.
  3. knownCase and removeUnused must create new blocks instead of
  	sharing them since it can't guarantee that the profile stacks
  	are the same at the shared blocks.
  I could have put the changes under a test for
  	!Control.profile <> Control.ProfileNone
  but my goal is to have profiling have as small of an impact on the
  program as possible, and so I decided to see if we can live with the
  weaker optimizations in general.  The jury is still out.  None of the
  benchmarks seem to have been hurt by the optimizer changes.  However,
  there has been a significant self-compile slowdown.  I am
  investigating.
  
  The SSA simplifier changes tickled a bug in signal check insertion.
  It had missed the possibility of looping forever via recursive
  function calls instead of SSA loops.  To fix the problem, I added a
  signal check on entry to each function.
  
  The machine type checker is too slow because it does a linear lookup
  of profile labels in an array.  I will fix it to use plists.
  
  Time profiling does not yet correctly handle other labels (e.g. C
  functions, GC functions).  In order to do that, I plan to have the
  profiling initialization code do an nm on the program itself to find
  the labels and then to add special "source" infos into the sources
  array and the corresponding indices into the textSources array.

Revision  Changes    Path
1.13      +5 -0      mlton/doc/changelog

Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- changelog	10 Dec 2002 22:18:46 -0000	1.12
+++ changelog	19 Dec 2002 23:43:30 -0000	1.13
@@ -1,5 +1,10 @@
 Here are the changes from version 20020923.
 
+* 2002-12-19
+  - Fixed bug in signal check insertion that could cause some signals
+    to be missed.  The fix was to add a signal check on entry to each
+    function in addition to at each loop header.
+
 * 2002-12-10
   - Fixed bug in runtime that might cause the message
 	Unable to set cardMapForMutator.



1.45      +54 -89    mlton/include/ccodegen.h

Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- ccodegen.h	12 Dec 2002 01:14:21 -0000	1.44
+++ ccodegen.h	19 Dec 2002 23:43:30 -0000	1.45
@@ -1,68 +1,44 @@
 #ifndef _CCODEGEN_H_
 #define _CCODEGEN_H_
 
-#define Globals(c, d, i, p, u, nr)						\
-	/* gcState can't be static because stuff in mlton-lib.c refers to it */	\
-	struct GC_state gcState;						\
-	static int sizeRes;							\
-	static pointer serializeRes;						\
-	static pointer deserializeRes;						\
-	static pointer stackRes;						\
-	static pointer arrayAllocateRes;					\
-	static struct intInfRes_t *intInfRes;					\
-	static int nextFun;							\
-	static char globaluchar[c];						\
-	static double globaldouble[d];						\
-	static int globalint[i];						\
-	static pointer globalpointer[p];					\
-	static uint globaluint[u];						\
-	static pointer globalpointerNonRoot[nr];				\
-	/* The CReturn's must be globals and cannot be per chunk because 	\
-	 * they may be assigned in one chunk and read in another.  See		\
-	 * Array_allocate.							\
-	 */									\
-	static char CReturnC;							\
-	static double CReturnD;							\
-	static int CReturnI;							\
-	static char *CReturnP;							\
-	static uint CReturnU;							\
-	void saveGlobals(int fd) {						\
-		swrite(fd, globaluchar, sizeof(char) * c);			\
-		swrite(fd, globaldouble, sizeof(double) * d);			\
-		swrite(fd, globalint, sizeof(int) * i);				\
-		swrite(fd, globalpointer, sizeof(pointer) * p);			\
-		swrite(fd, globaluint, sizeof(uint) * u);			\
-	}									\
-	static void loadGlobals(FILE *file) {					\
-		sfread(globaluchar, sizeof(char), c, file);			\
-		sfread(globaldouble, sizeof(double), d, file);			\
-		sfread(globalint, sizeof(int), i, file);			\
-		sfread(globalpointer, sizeof(pointer), p, file);		\
-		sfread(globaluint, sizeof(uint), u, file);			\
-	}
-
-#define BeginIntInfs static struct GC_intInfInit intInfInits[] = {
-#define IntInf(g, n) { g, n },
-#define EndIntInfs { 0, NULL }};
-
-#define BeginStrings static struct GC_stringInit stringInits[] = {
-#define String(g, s, l) { g, s, l },
-#define EndStrings { 0, NULL, 0 }};
-
-#define BeginReals static void real_Init() {
-#define Real(c, f) globaldouble[c] = f;
-#define EndReals }
+#include "codegen.h"
+
+/* Globals */
+static pointer arrayAllocateRes;
+static int nextFun;
+static int sizeRes;
+static pointer stackRes;
+
+/* The CReturn's must be globals and cannot be per chunk because
+ * they may be assigned in one chunk and read in another.  See, e.g.
+ * Array_allocate.
+ */
+static char CReturnC;
+static double CReturnD;
+static int CReturnI;
+static char *CReturnP;
+static uint CReturnU;
+
+#ifndef DEBUG_CCODEGEN
+#define DEBUG_CCODEGEN FALSE
+#endif
 
 #define IsInt(p) (0x3 & (int)(p))
 
-#define BZ(x, l)				\
-	do {					\
-		if (x == 0) goto l;		\
+#define BZ(x, l)						\
+	do {							\
+		if (DEBUG_CCODEGEN)				\
+			fprintf (stderr, "%d  BZ(%d, %s)\n", 	\
+					__LINE__, (x), #l); 	\
+		if (0 == (x)) goto l;				\
 	} while (0)
 
-#define BNZ(x, l)				\
-	do {					\
-		if (x) goto l;		        \
+#define BNZ(x, l)						\
+	do {							\
+		if (DEBUG_CCODEGEN)				\
+			fprintf (stderr, "%d  BNZ(%d, %s)\n",	\
+					__LINE__, (x), #l);	\
+		if (x) goto l;					\
 	} while (0)
 
 /* ------------------------------------------------- */
@@ -87,11 +63,14 @@
 		char *stackTop;			\
 		pointer frontier;		\
 
-#define ChunkSwitch				\
-		CacheFrontier();		\
-		CacheStackTop();		\
-		while (1) {			\
-		top:				\
+#define ChunkSwitch(n)							\
+		if (DEBUG_CCODEGEN)					\
+			fprintf (stderr, "%d  entering chunk %d\n",	\
+					__LINE__, n);			\
+		CacheFrontier();					\
+		CacheStackTop();					\
+		while (1) {						\
+		top:							\
 		switch (l_nextFun) {
 
 #define EndChunk							\
@@ -111,28 +90,11 @@
 /*                       main                        */
 /* ------------------------------------------------- */
 
-#define Main(cs, mmc, mfs, mfi, mot, mg, mc, ml)			\
+#define Main(cs, mmc, mfs, mg, pa, mc, ml)				\
 int main (int argc, char **argv) {					\
 	struct cont cont;						\
-	int l_nextFun;							\
-	gcState.profileAllocIsOn = FALSE;				\
-	gcState.cardSizeLog2 = cs;					\
-	gcState.frameLayouts = frameLayouts;				\
-	gcState.globals = globalpointer;				\
-	gcState.intInfInits = intInfInits;				\
-	gcState.loadGlobals = &loadGlobals;				\
-	gcState.magic = mg;						\
-	gcState.maxFrameIndex = mfi;					\
-	gcState.maxFrameSize = mfs;					\
-	gcState.maxObjectTypeIndex = mot;				\
-	gcState.mutatorMarksCards = mmc;				\
 	gcState.native = FALSE;						\
-	gcState.numGlobals = cardof(globalpointer);			\
-	gcState.objectTypes = objectTypes;				\
-	gcState.profileInfo = NULL;					\
-	gcState.saveGlobals = &saveGlobals;				\
-	gcState.stringInits = stringInits;				\
-	MLton_init (argc, argv, &gcState);				\
+	Initialize(cs, mmc, mfs, mg, pa);				\
 	if (gcState.isOriginal) {					\
 		real_Init();						\
 		PrepFarJump(mc, ml);					\
@@ -231,15 +193,18 @@
 		assert(StackBottom <= stackTop);	\
 	} while (0)
 
-#define Return()						\
-	do {							\
-		l_nextFun = *(word*)(stackTop - WORD_SIZE);	\
-		goto top;					\
+#define Return()								\
+	do {									\
+		l_nextFun = *(word*)(stackTop - WORD_SIZE);			\
+		if (DEBUG_CCODEGEN)						\
+			fprintf (stderr, "%d  Return()  l_nextFun = %d\n",	\
+					__LINE__, l_nextFun);			\
+		goto top;							\
 	} while (0)
 
 #define Raise()								\
 	do {								\
-		if (FALSE)						\
+		if (DEBUG_CCODEGEN)					\
 			fprintf (stderr, "%d  Raise\n", __LINE__);	\
 		stackTop = StackBottom + ExnStack;			\
 		l_nextFun = *(int*)stackTop;				\
@@ -303,7 +268,7 @@
 	do {								\
 		*(word*)frontier = (h);					\
 		x = frontier + GC_NORMAL_HEADER_SIZE;			\
-		if (FALSE)						\
+		if (DEBUG_CCODEGEN)					\
 			fprintf (stderr, "%d  0x%x = Object(%d)\n",	\
 				 __LINE__, x, h);			\
 		assert (frontier <= gcState.limitPlusSlop);		\
@@ -455,10 +420,10 @@
 	do {									\
 		int overflow;							\
 		dst = f(n1, n2, &overflow);					\
-		if (FALSE)							\
+		if (DEBUG_CCODEGEN)						\
 			fprintf(stderr, #f "(%d, %d) = %d\n", n1, n2, dst);	\
 		if (overflow) {							\
-			if (FALSE)						\
+			if (DEBUG_CCODEGEN)					\
 				fprintf(stderr, "overflow\n");			\
 			goto l;							\
 		}								\



1.22      +29 -78    mlton/include/x86codegen.h

Index: x86codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86codegen.h,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86codegen.h	16 Dec 2002 19:28:01 -0000	1.21
+++ x86codegen.h	19 Dec 2002 23:43:31 -0000	1.22
@@ -1,50 +1,31 @@
 #ifndef _X86CODEGEN_H_
 #define _X86CODEGEN_H_
 
-#define Globals(c, d, i, p, u, nr)					\
-	word raTemp1;							\
-	double raTemp2;							\
-	word spill[16];							\
-	word indexTemp;							\
-	word checkTemp;							\
-	word divTemp;							\
-	struct GC_state gcState;					\
-	word stackTopTemp;						\
-	word c_stackP;							\
-	char cReturnTempB;						\
-	word cReturnTempL;						\
-	double cReturnTempD;						\
-	word switchTemp;						\
-	word intInfTemp;						\
-	word threadTemp;						\
-	word statusTemp;						\
-	word fileTemp;							\
-	word applyFFTemp;						\
-	double realTemp1;						\
-	double realTemp2;						\
-        double realTemp3;						\
-	word fpswTemp;							\
-	char MLton_bug_msg[] = "cps machine";				\
-	char globaluchar[c];						\
-	double globaldouble[d];						\
-	int globalint[i];						\
-	pointer globalpointer[p];					\
-        uint globaluint[u];						\
-	pointer globalpointerNonRoot[nr];				\
-	void saveGlobals(int fd) {					\
-		swrite(fd, globaluchar, sizeof(char) * c);		\
-		swrite(fd, globaldouble, sizeof(double) * d);		\
-		swrite(fd, globalint, sizeof(int) * i);			\
-		swrite(fd, globalpointer, sizeof(pointer) * p);		\
-		swrite(fd, globaluint, sizeof(uint) * u);		\
-	}								\
-	static void loadGlobals(FILE *file) {				\
-		sfread(globaluchar, sizeof(char), c, file);		\
-		sfread(globaldouble, sizeof(double), d, file);		\
-		sfread(globalint, sizeof(int), i, file);		\
-		sfread(globalpointer, sizeof(pointer), p, file);	\
-		sfread(globaluint, sizeof(uint), u, file);		\
-	}
+#include "codegen.h"
+
+/* Globals */
+word applyFFTemp;
+word checkTemp;
+char cReturnTempB;
+double cReturnTempD;
+word cReturnTempL;
+word c_stackP;
+word divTemp;
+word fileTemp;
+word fpswTemp;
+word indexTemp;
+word intInfTemp;
+char MLton_bug_msg[] = "cps machine";
+word raTemp1;
+double raTemp2;
+double realTemp1;
+double realTemp2;
+double realTemp3;
+word spill[16];
+word stackTopTemp;
+word statusTemp;
+word switchTemp;
+word threadTemp;
 
 #define Locals(c, d, i, p, u)						\
 	char localuchar[c];						\
@@ -53,42 +34,12 @@
 	pointer localpointer[p];					\
 	uint localuint[u]
 
-#define BeginIntInfs static struct GC_intInfInit intInfInits[] = {
-#define IntInf(g, n) { g, n },
-#define EndIntInfs { 0, NULL }};
-
-#define BeginStrings static struct GC_stringInit stringInits[] = {
-#define String(g, s, l) { g, s, l },
-#define EndStrings { 0, NULL, 0 }};
-
-#define BeginReals static void real_Init() {
-#define Real(c, f) globaldouble[c] = f;
-#define EndReals }
-
-#define Main(cs, mmc, mfs, mfi, mot, mg, ml, reserveEsp, a1, a2, a3, pi) \
-extern pointer ml;							\
+#define Main(cs, mmc, mfs, mg, pa, ml, reserveEsp)			\
 int main (int argc, char **argv) {					\
 	pointer jump;  							\
-	gcState.profileAllocIsOn = a1;					\
-	gcState.profileAllocLabels = a2;				\
-	gcState.profileAllocNumLabels = a3;				\
-	gcState.cardSizeLog2 = cs;					\
-	gcState.frameLayouts = frameLayouts;				\
-	gcState.profileInfo = pi;					\
-	gcState.globals = globalpointer;				\
-	gcState.intInfInits = intInfInits;				\
-	gcState.loadGlobals = &loadGlobals;				\
-	gcState.magic = mg;						\
-	gcState.maxFrameIndex = mfi;					\
-	gcState.maxFrameSize = mfs;					\
-	gcState.maxObjectTypeIndex = mot;				\
-	gcState.mutatorMarksCards = mmc;				\
-	gcState.native = TRUE;       					\
-	gcState.numGlobals = cardof(globalpointer);			\
-	gcState.objectTypes = objectTypes;				\
-	gcState.saveGlobals = &saveGlobals;				\
-	gcState.stringInits = stringInits;				\
-	MLton_init (argc, argv, &gcState);				\
+	extern pointer ml;						\
+	gcState.native = TRUE;						\
+	Initialize(cs, mmc, mfs, mg, pa);				\
 	if (gcState.isOriginal) {					\
 		real_Init();						\
 		jump = (pointer)&ml;   					\



1.1                  mlton/include/codegen.h

Index: codegen.h
===================================================================
#ifndef _CODEGEN_H_
#define _CODEGEN_H_

#define BeginIntInfs static struct GC_intInfInit intInfInits[] = {
#define IntInf(g, n) { g, n },
#define EndIntInfs { 0, NULL }};

#define BeginStrings static struct GC_stringInit stringInits[] = {
#define String(g, s, l) { g, s, l },
#define EndStrings { 0, NULL, 0 }};

#define BeginReals static void real_Init() {
#define Real(c, f) globaldouble[c] = f;
#define EndReals }

#define Globals(c, d, i, p, u, nr)					\
	/* gcState can't be static because stuff in mlton-lib.c refers to it */	\
	struct GC_state gcState;						\
	char globaluchar[c];						\
	double globaldouble[d];						\
	int globalint[i];						\
	pointer globalpointer[p];					\
        uint globaluint[u];						\
	pointer globalpointerNonRoot[nr];				\
	void saveGlobals (int fd) {					\
		swrite (fd, globaluchar, sizeof(char) * c);		\
		swrite (fd, globaldouble, sizeof(double) * d);		\
		swrite (fd, globalint, sizeof(int) * i);		\
		swrite (fd, globalpointer, sizeof(pointer) * p); 	\
		swrite (fd, globaluint, sizeof(uint) * u);		\
	}								\
	static void loadGlobals (FILE *file) {				\
		sfread (globaluchar, sizeof(char), c, file);		\
		sfread (globaldouble, sizeof(double), d, file);		\
		sfread (globalint, sizeof(int), i, file);		\
		sfread (globalpointer, sizeof(pointer), p, file);	\
		sfread (globaluint, sizeof(uint), u, file);		\
	}

#define Initialize(cs, mmc, mfs, mg, pa)				\
	gcState.cardSizeLog2 = cs;					\
	gcState.frameLayouts = frameLayouts;				\
	gcState.globals = globalpointer;				\
	gcState.intInfInits = intInfInits;				\
	gcState.loadGlobals = loadGlobals;				\
	gcState.magic = mg;						\
	gcState.maxFrameSize = mfs;					\
	gcState.mutatorMarksCards = mmc;				\
	gcState.numFrameLayouts = cardof(frameLayouts);			\
	gcState.numGlobals = cardof(globalpointer);			\
	gcState.numObjectTypes = (uint)cardof(objectTypes);		\
	gcState.objectTypes = objectTypes;				\
	gcState.profileAllocIsOn = pa;					\
	gcState.profileLabels = profileLabels;				\
	gcState.profileLabelsSize = cardof(profileLabels);		\
	gcState.profileSources = profileSources;			\
	gcState.profileSourcesSize = cardof(profileSources);		\
	gcState.profileFrameSources = profileFrameSources;		\
	gcState.profileFrameSourcesSize = cardof(profileFrameSources);	\
	gcState.profileSourceSeqs = profileSourceSeqs;			\
	gcState.profileSourceSeqsSize = cardof(profileSourceSeqs);	\
	gcState.saveGlobals = saveGlobals;				\
	gcState.stringInits = stringInits;				\
	MLton_init (argc, argv, &gcState);				\

#endif /* #ifndef _CODEGEN_H_ */



1.20      +99 -508   mlton/mlprof/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- main.sml	12 Dec 2002 18:27:39 -0000	1.19
+++ main.sml	19 Dec 2002 23:43:31 -0000	1.20
@@ -83,6 +83,8 @@
    datatype 'a t = T of {data: 'a,
 			 minor: 'a t} list
 
+   val empty = T []
+
    local
       open Layout
    in
@@ -98,528 +100,116 @@
 
 structure AFile =
    struct
-      datatype t = T of {data: {addr: word,
-				profileInfo: {name: string} ProfileInfo.t} list,
-			 etext: word,
-			 frameFunc: string vector,
-			 funcSource: string StringMap.t,
-			 start: word}
-
-      fun layout (T {data, ...}) =
-	 let 
-	    open Layout
-	 in 
-	    List.layout
-	    (fn {addr, profileInfo} =>
-	     seq [Word.layout addr,
-		  str " ",
-		  ProfileInfo.layout (fn {name} => str name) profileInfo])
-	    data
-	 end
+      datatype t = T of {magic: word,
+			 sources: string vector}
+
+      fun layout (T {magic, sources}) =
+	 Layout.record [("magic", Word.layout magic),
+			("sources", Vector.layout String.layout sources)]
 
-      structure Match = Regexp.Match
       fun new {afile: File.t}: t =
-	 let
-	    val (frameFunc, funcSource) =
-	       Process.callWithIn
-	       (afile, ["@MLton", "show-prof"],
-		fn ins =>
-		let
-		   fun loop ac =
-		      case In.inputLine ins of
-			 "\n" => Vector.fromListRev ac
-		       | s => loop (String.dropSuffix (s, 1) :: ac)
-		   val frameFunc = loop []
-		   val funcSource = StringMap.new ()
-		   fun loop () =
-		      case In.inputLine ins of
-			 "" => ()
-		       | s =>
-			    case String.tokens (s, Char.isSpace) of
-			       [func, source] =>
-				  (StringMap.lookupOrInsert
-				   (funcSource, func, fn () => source)
-				   ; loop ())
-			     | _ =>
-				  die (concat
-				       ["executable ",
-					afile,
-					" with strange profiling info"])
-		   val _ = loop ()
-		in
-		   (frameFunc, funcSource)
-		end)
-	    local
-	       open Regexp
-	    in
-	       val level = Save.new ()
-	       val name = Save.new ()
-	       val profileInfoC =
-		  compileDFA (seq [save (digits, level),
-				   char #".",
-				   save (identifier, name),
-				   string "$$"])
-	       val profileInfo = Save.new ()
-	       val profileLabelRegexp =
-		  seq [string "MLtonProfile",
-		       digits,
-		       string "$$",
-		       save (star (seq [digits,
-					char #".",
-					identifier,
-					string "$$"]),
-			     profileInfo),
-		       string "Begin"]
-	       val addr = Save.new ()
-	       val kind = Save.new ()
-	       val label = Save.new ()
-	       val start = Save.new ()
-	       val etext = Save.new ()
-	       val symbolC =
-		  compileDFA
-		  (or [seq [save (hexDigits, start),
-			    string " T _start",
-			    eol],
-		       seq [save (hexDigits, etext),
-			    string " A etext",
-			    eol],
-		       seq [save (hexDigits, addr),
-			    char #" ",
-			    save (char #"T", kind),
-			    char #" ",
-			    profileLabelRegexp,
-			    eol],
-		       seq [save (hexDigits, addr),
-			    char #" ",
-			    save (oneOf (if !static then "tT" else "T"), kind),
-			    char #" ",
-			    save (identifier, label),
-			    eol]])
-	       val _ =
-		  if true
-		     then ()
-		  else (Layout.outputl (Compiled.layout symbolC, Out.standard)
-			; Compiled.layoutDotToFile (symbolC, "symbol.dot"))
-	    end
-	    val startRef: word option ref = ref NONE
-	    val etextRef: word option ref = ref NONE
-	    fun extractLabels ()
-	       : {addr: word,
-		  profileInfo: {level: int,
-				name: string} list} list =
-	       Process.callWithIn
-	       ("nm", ["-n", afile], fn ins =>
-		In.foldLines
-		(ins, [], fn (line, ac) =>
-		 case Regexp.Compiled.matchAll (symbolC, line) of
-		    NONE => ac
-		  | SOME m =>
-		       let
-			  val {lookup, peek, ...} = Match.stringFuns m
-			  fun normal () =
-			     let
-				val addr = valOf (Word.fromString (lookup addr))
-				val profileInfo =
-				   case peek label of
-				      SOME label =>
-					 let
-					    val kind = lookup kind
-					    val level =
-					       if kind = "T" then ~1 else ~2
-					 in [{level = level,
-					      name = label}]
-					 end
-				    | NONE =>
-					 let
-					    val profileInfo = lookup profileInfo
-					    val length = String.size profileInfo
-					    fun loop pos =
-					       case (Regexp.Compiled.matchShort
-						     (profileInfoC,
-						      profileInfo, pos)) of
-						  NONE => []
-						| SOME m =>
-						     let
-							val {lookup, ...} =
-							   Match.stringFuns m
-							val level =
-							   valOf (Int.fromString
-								  (lookup level))
-							val name = lookup name
-						     in
-							{level = level,
-							 name = name}
-							:: loop (pos + Match.length m)
-						     end	
-					 in loop 0
-					 end
-			     in
-				{addr = addr, profileInfo = profileInfo} :: ac
-			     end
-		       in
-			  case peek start of
-			     SOME s =>
-				(startRef := SOME (valOf (Word.fromString s))
-				 ; ac)
-			   | NONE =>
-				case peek etext of
-				   SOME s =>
-				      (etextRef :=
-				       SOME (valOf (Word.fromString s))
-				       ; ac)
-				 | NONE => normal ()
-		       end))
-	    fun shrink {addr,
-			profileInfo: {level: int,
-				      name: string} list} =
-	       let
-		  val profileInfo =
-		     QuickSort.sortList
-		     (List.removeDuplicates (profileInfo, op =),
-		      fn ({level = l1, name = n1}, {level = l2, name = n2}) =>
-		      if l1 = l2
-			 then String.>= (n1, n2)
-		      else Int.>= (l1, l2))
-		  val profileInfo =
-		     List.fold
-		     (profileInfo, [],
-		      fn ({level, name}, profileInfo) =>
-		      if level >= 0
-			 then {level = level,
-			       name = if level > 0 orelse not (!source)
-					 then name
-				      else
-					 StringMap.lookupOrInsert
-					 (funcSource, name,
-					  fn () =>
-					  die (concat
-					       ["missing source info for ",
-						name]))}
-			       :: profileInfo
-		      else
-			 if List.exists
-			    (profileInfo, fn {name = name', ...} => name = name')
-			    then profileInfo
-			 else let
-				 val name =
-				    if level = ~1
-				       then name ^ " (C)"
-				    else concat [name, " (C @ 0x",
-						 Word.toString addr, ")"]
-			      in
-				 {level = 0,
-				  name = name} :: profileInfo
-			      end)
-		  fun combineNamesAtLevel (profileInfo, n) =
-		     let
-			val {yes, no} =
-			   List.partition
-			   (List.rev profileInfo,
-			    fn {level, name} => level = n)
-		     in
-			if List.isEmpty yes
-			   then ProfileInfo.T []
-			else let
-				val name =
-				   concat (List.separate
-					   (List.map (yes, #name),
-					    ","))
-				val minor = combineNamesAtLevel (no, n + 1)
-			     in
-				ProfileInfo.T [{data = {name = name},
-						minor = minor}]
-			     end
-		     end
-		  val profileInfo = combineNamesAtLevel (profileInfo, 0)
-	       in
-		  {addr = addr, profileInfo = profileInfo}
-	       end
-	    (* Combine profileInfo at the same address. *)
-	    val rec compress =
-	       fn [] => []
-		| [v] => [shrink v]
-		| (v1 as {addr = addr1,
-			  profileInfo = profileInfo1})
-		  :: (v2 as {addr = addr2,
-			     profileInfo = profileInfo2})
-		  :: l
-		  => if addr1 = addr2
-			then (compress
-			      ({addr = addr1,
-				profileInfo = profileInfo1 @ profileInfo2}
-			       :: l))
-		     else shrink v1 :: compress (v2::l)
-	    val l = List.rev (compress (extractLabels ()))
-	    val start =
-	       case !startRef of
-		  NONE => die "couldn't find _start label"
-		| SOME w => w
-	    val etext =
-	       case !etextRef of
-		  NONE => die "couldn't find _etext label"
-		| SOME w => w
-	 in
-	    T {data = l,
-	       etext = etext,
-	       frameFunc = frameFunc,
-	       funcSource = funcSource,
-	       start = start}
-	 end
-			      
+	 Process.callWithIn
+	 (afile, ["@MLton", "show-prof"],
+	  fn ins =>
+	  let
+	     val magic =
+		valOf (Word.fromString (In.inputLine ins))
+	     fun loop ac =
+		case In.inputLine ins of
+		   "" => Vector.fromListRev ac
+		 | s => loop (String.dropSuffix (s, 1) :: ac)
+	     val sources = loop []
+	  in
+	     T {magic = magic,
+		sources = sources}
+	  end)
+	 
       val new = Trace.trace ("AFile.new", File.layout o #afile, layout) new
    end
 
 structure Kind =
    struct
       datatype t = Alloc | Time
+
+      val toString =
+	 fn Alloc => "Alloc"
+	  | Time => "Time"
+
+      val layout = Layout.str o toString
    end
 
 structure ProfFile =
-struct
-   (* Profile information is a list of buckets, sorted in increasing order of
-    * address, with count always greater than 0.
-    *)
-  datatype t = T of {buckets: {addr: word,
-			       count: IntInf.t} list,
-		     etext: word,
-		     kind: Kind.t,
-		     magic: word,
-		     start: word}
-
-  local
-     fun make f (T r) = f r
-  in
-     val kind = make #kind
-  end
-
-  fun layout (T {buckets, ...}) =
-     let 
-	open Layout
-     in 
-	List.layout
-	(fn {addr, count} =>
-	 seq [Word.layout addr, str " ", IntInf.layout count])
-	buckets
-     end
-
-  fun new {mlmonfile: File.t}: t 
-    = File.withIn
-      (mlmonfile, 
-       fn ins
-        => let
-	     fun read (size: int): string 
-	       = let 
-		   val res = In.inputN (ins, size)
-		 in 
-		   if size <> String.size res
-		     then die "Unexpected EOF"
-		     else res
-		 end
-	     fun getString size = read size
-	     fun getChar ():char 
-	       = let val s = read 1
-		 in String.sub (s, 0)
-		 end 
-	     fun getWord (): word
-	       = let val s = read 4
-		     fun c i = Word.fromInt (Char.toInt (String.sub (s, i)))
-		 in Word.orb (Word.orb (Word.<< (c 3, 0w24),
-					Word.<< (c 2, 0w16)),
-			      Word.orb (Word.<< (c 1, 0w8), 
-					Word.<< (c 0, 0w0)))
-		 end
-	     fun getHWord (): word
-	       = let val s = read 2
-		     fun c i = Word.fromInt (Char.toInt (String.sub (s, i)))
-		 in Word.orb (Word.<< (c 1, 0w8), 
-			     Word.<< (c 0, 0w0))
-		 end
-	     fun getQWord (): word
-	       = let val s = read 1
-		     fun c i = Word.fromInt (Char.toInt (String.sub (s, i)))
-		 in Word.<< (c 0, 0w0)
-		 end
+   struct
+      datatype t = T of {counts: IntInf.t vector,
+			 kind: Kind.t,
+			 magic: word}
+
+      local
+	 fun make f (T r) = f r
+      in
+	 val kind = make #kind
+      end
+
+      fun layout (T {counts, kind, magic}) =
+	 Layout.record [("kind", Kind.layout kind),
+			("magic", Word.layout magic),
+			("counts", Vector.layout IntInf.layout counts)]
+
+      fun new {mlmonfile: File.t}: t =
+	 File.withIn
+	 (mlmonfile, fn ins =>
+	  let
 	     val _ =
-		if "MLton prof\n\000" <> getString 12
-		   then
-		      die (concat [mlmonfile,
-				   " does not appear to be a mlmon.out file"])
-		else ()
-	     val getAddr = getWord
-	     val magic = getWord ()
-	     val start = getAddr ()
-	     val etext = getAddr ()
-	     val countSize = getWord ()
+		if "MLton prof\n" = In.inputLine ins
+		   then ()
+		else die (concat [mlmonfile,
+				  " does not appear to be an mlmon file"])
 	     val kind =
-		case getWord () of
-		   0w0 => Kind.Alloc
-		 | 0w1 => Kind.Time
-		 | _ => die "invalid mlmon.out kind"
-	     fun getCount4 () = Word.toIntInf (getWord ())
-	     fun getCount8 () =
-		let
-		   val low = getCount4 ()
-		   val high = getCount4 ()
-		   open IntInf
-		in
-		   low + high * pow (fromInt 2, Word.wordSize)
-		end
-	     fun getCount (): IntInf.t =
-		case countSize of
-		   0w4 => getCount4 ()
-		 | 0w8 => getCount8 ()
-		 | _ => die "invalid count size"
+		case In.inputLine ins of
+		   "alloc\n" => Kind.Alloc
+		 | "time\n" => Kind.Time
+		 | _ => die "invalid profile kind"
+	     fun line () = String.dropSuffix (In.inputLine ins, 1)
+	     val magic = valOf (Word.fromString (line ()))
 	     fun loop ac =
-		if In.endOf ins
-		   then rev ac
-		else let
-			val addr = getAddr ()
-			val _ =
-			   if addr > 0w0
-			      andalso (addr < start orelse addr >= etext)
-			      then die "bad addr"
-			   else ()
-			val count = getCount ()
-			val _ =
-			   if count = IntInf.fromInt 0
-			      then die "zero count"
-			   else ()
-		     in
-			loop ({addr = addr, count = count} :: ac)
-		     end
-	     val buckets = loop []
-	     val buckets =
-		QuickSort.sortList
-		(buckets, fn ({addr = a, ...}, {addr = a', ...}) => a <= a')
-	   in 
-	     T {buckets = buckets,
-		etext = etext,
+		case In.inputLine ins of
+		   "" => Vector.fromListRev ac
+		 | s => loop (valOf (IntInf.fromString s) :: ac)
+	     val counts = loop []
+	  in
+	     T {counts = counts,
 		kind = kind,
-		magic = magic,
-		start = start}
-	   end)
-
-  val new = Trace.trace ("ProfFile.new", File.layout o #mlmonfile, layout) new
-
-  fun merge (T {buckets = b, etext = e, kind = k, magic = m, start = s},
-	     T {buckets = b', etext = e', kind = k', magic = m', start = s'}) =
-     if m <> m' orelse e <> e' orelse k <> k' orelse s <> s'
-	then die "incompatible mlmon files"
-     else
-	let
-	   fun loop (buckets, buckets', ac) =
-	      case (buckets, buckets') of
-		 ([], buckets') => List.appendRev (ac, buckets')
-	       | (buckets, []) => List.appendRev (ac, buckets)
-	       | (buckets as {addr, count}::bs,
-		  buckets' as {addr = addr', count = count'}::bs') =>
-		 (case Word.compare (addr, addr')
-		     of LESS => loop (bs, buckets', 
-				      {addr = addr, count = count}::ac)
-		   | EQUAL => loop (bs, bs', 
-				    {addr = addr,
-				     count = IntInf.+ (count, count')}
-				    :: ac)
-		   | GREATER => loop (buckets, bs', 
-				      {addr = addr', count = count'}::ac))
-	in
-	   T {buckets = loop (b, b', []),
-	      etext = e,
-	      kind = k,
-	      magic = m,
-	      start = s}
-	end
-	     
-  fun addNew (pi, mlmonfile: File.t): t =
-     merge (pi, new {mlmonfile = mlmonfile})
+		magic = magic}
+	  end)
 
-  val addNew = Trace.trace ("ProfFile.addNew", File.layout o #2, layout) addNew
-end
+      val new =
+	 Trace.trace ("ProfFile.new", File.layout o #mlmonfile, layout) new
 
-fun attribute (AFile.T {data, etext = e, funcSource, start = s, ...}, 
-	       ProfFile.T {buckets, etext = e', kind, start = s', ...}) : 
-    {profileInfo: {name: string} ProfileInfo.t,
-     ticks: IntInf.t} list option
-  = if e <> e' orelse s <> s'
-       then NONE
-    else
-    let
-      fun loop (profileInfoCurrent,
-		ticks: IntInf.t, l, buckets) =
-	 let
-	    fun done (ticks, rest)
-	       = if IntInf.equals (IntInf.fromInt 0, ticks)
-		    then rest
-		 else {profileInfo = profileInfoCurrent,
-		       ticks = ticks} :: rest
-	 in
-	    case (l, buckets) of
-	       (_, []) => done (ticks, [])
-	     | ([], _) => done (List.fold (buckets, ticks, 
-					   fn ({count, ...}, ticks) =>
-					   IntInf.+ (count, ticks)),
-				[])
-	     | ({addr = profileAddr, profileInfo} :: l',
-		{addr = bucketAddr, count} :: buckets') =>
-		  if profileAddr <= bucketAddr
-		     then done (ticks,
-				loop (profileInfo, IntInf.fromInt 0,
-				      l', buckets))
-		  else loop (profileInfoCurrent,
-			     IntInf.+ (ticks, count), l, buckets')
-	 end
-    in
-       SOME
-       (loop (ProfileInfo.T ([{data = {name =
-				       (case kind of
-					   Kind.Alloc => "<runtime>"
-					 | Kind.Time => "<shared libraries>")},
-			       minor = ProfileInfo.T []}]),
-	      IntInf.fromInt 0, data, buckets))
-    end
-
-fun coalesce (counts: {profileInfo: {name: string} ProfileInfo.t,
-		       ticks: IntInf.t} list)
-   : {name: string, ticks: IntInf.t} ProfileInfo.t =
-   let
-      datatype t = T of {ticks': IntInf.t ref, map': t StringMap.t ref}
-      val map = StringMap.new ()
-      val _ 
-	= List.foreach
-	  (counts,
-	   fn {profileInfo, ticks}
-	    => let
-		 fun doit (ProfileInfo.T profileInfo, map)
-		   = List.foreach
-		     (profileInfo,
-		      fn {data = {name}, minor}
-		       => let
-			    val T {ticks', map'} 
-			      = StringMap.lookupOrInsert
-			        (map, 
-				 name, 
-				 fn () => T {ticks' = ref (IntInf.fromInt 0),
-					     map' = ref (StringMap.new ())})
-			  in
-			    ticks' := IntInf.+ (!ticks', ticks);
-			    doit (minor, !map')
-			  end)
-	       in
-		 doit (profileInfo, map)
-	       end)
-
-      fun doit map
-	= ProfileInfo.T
-	  (StringMap.foldi
-	   (map,
-	    [],
-	    (fn (name, T {map', ticks'}, profileInfo)
-	      => {data = {name = name, ticks = !ticks'},
-		  minor = doit (!map')}::profileInfo)))
-    in
-      doit map
-    end
+      fun merge (T {counts = c, kind = k, magic = m},
+		 T {counts = c', magic = m', ...}): t =
+	 if m <> m'
+	    then die "incompatible mlmon files"
+	 else
+	    T {counts = Vector.map2 (c, c', IntInf.+),
+	       kind = k,
+	       magic = m}
+   end
 
+fun attribute (AFile.T {magic = m, sources},
+	       ProfFile.T {counts, kind, magic = m'})
+    : {name: string,
+       ticks: IntInf.t} ProfileInfo.t option =
+   if m <> m'
+      then NONE
+   else
+      SOME
+      (ProfileInfo.T
+       (Vector.fold2 (counts, sources, [], fn (c, s, ac) =>
+		      if c = IntInf.zero
+			 then ac
+		      else {data = {name = s, ticks = c},
+			    minor = ProfileInfo.empty} :: ac)))
+      
 val replaceLine =
    Promise.lazy
    (fn () =>
@@ -833,13 +423,13 @@
 	 boolRef busy),
 	(Normal, "color", " {false|true}", "color .dot files",
 	 boolRef color),
-	(Normal, "depth", " {0|1|2}", "depth of detail",
+	(Expert, "depth", " {0|1|2}", "depth of detail",
 	 Int (fn i => if i < 0 orelse i > 2
 			 then usage "invalid depth"
 		      else depth := i)),
 	(Normal, "raw", " {false|true}", "show raw counts",
 	 boolRef raw),
-	(Normal, "source", " {true|false}", "report info at source level",
+	(Expert, "source", " {true|false}", "report info at source level",
 	 boolRef source),
 	(Normal, "static", " {false|true}", "show static C functions",
 	 boolRef static),
@@ -879,7 +469,8 @@
 		   List.fold
 		   (mlmonfiles, ProfFile.new {mlmonfile = mlmonfile},
 		    fn (mlmonfile, profFile) =>
-		    ProfFile.addNew (profFile, mlmonfile))
+		    ProfFile.merge (profFile,
+				    ProfFile.new {mlmonfile = mlmonfile}))
 		val _ =
 		   if true
 		      then ()
@@ -894,7 +485,7 @@
 		   case attribute (aInfo, profFile) of
 		      NONE => die (concat [afile, " is incompatible with ",
 					   mlmonfile])
-		    | SOME z => coalesce z
+		    | SOME z => z
 		val _ = display (ProfFile.kind profFile, info, afile, !depth)
 	     in
 		()



1.64      +1 -1      mlton/mlton/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/Makefile,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- Makefile	7 Dec 2002 02:21:51 -0000	1.63
+++ Makefile	19 Dec 2002 23:43:31 -0000	1.64
@@ -4,7 +4,7 @@
 LIB = $(BUILD)/lib
 MLTON = mlton
 HOST = self
-FLAGS = @MLton $(RUNTIME_ARGS) gc-summary -- -host $(HOST) -v -o $(AOUT)
+FLAGS = @MLton $(RUNTIME_ARGS) gc-summary -- -profile time -host $(HOST) -v2 -o $(AOUT)
 NAME = mlton
 AOUT = mlton-compile
 PATH = $(BIN):$(shell echo $$PATH)



1.6       +2 -2      mlton/mlton/mlton-stubs-1997.cm

Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- mlton-stubs-1997.cm	12 Dec 2002 19:35:25 -0000	1.5
+++ mlton-stubs-1997.cm	19 Dec 2002 23:43:31 -0000	1.6
@@ -347,8 +347,8 @@
 backend/signal-check.sig
 backend/signal-check.fun
 backend/rssa.fun
-backend/profile-alloc.sig
-backend/profile-alloc.fun
+backend/profile.sig
+backend/profile.fun
 backend/parallel-move.sig
 backend/parallel-move.fun
 backend/limit-check.sig



1.11      +2 -2      mlton/mlton/mlton-stubs.cm

Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- mlton-stubs.cm	12 Dec 2002 19:35:25 -0000	1.10
+++ mlton-stubs.cm	19 Dec 2002 23:43:31 -0000	1.11
@@ -346,8 +346,8 @@
 backend/signal-check.sig
 backend/signal-check.fun
 backend/rssa.fun
-backend/profile-alloc.sig
-backend/profile-alloc.fun
+backend/profile.sig
+backend/profile.fun
 backend/parallel-move.sig
 backend/parallel-move.fun
 backend/limit-check.sig



1.59      +2 -2      mlton/mlton/mlton.cm

Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- mlton.cm	12 Dec 2002 19:35:25 -0000	1.58
+++ mlton.cm	19 Dec 2002 23:43:31 -0000	1.59
@@ -317,8 +317,8 @@
 backend/signal-check.sig
 backend/signal-check.fun
 backend/rssa.fun
-backend/profile-alloc.sig
-backend/profile-alloc.fun
+backend/profile.sig
+backend/profile.fun
 backend/parallel-move.sig
 backend/parallel-move.fun
 backend/limit-check.sig



1.41      +152 -124  mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- backend.fun	12 Dec 2002 01:14:21 -0000	1.40
+++ backend.fun	19 Dec 2002 23:43:31 -0000	1.41
@@ -20,6 +20,7 @@
    structure MemChunk = MemChunk
    structure ObjectType = ObjectType
    structure PointerTycon = PointerTycon
+   structure ProfileInfo = ProfileInfo
    structure Register = Register
    structure Runtime = Runtime
    structure SourceInfo = SourceInfo
@@ -33,7 +34,8 @@
 end
 val wordSize = Runtime.wordSize
 
-structure Rssa = Rssa (open Ssa Machine)
+structure Rssa = Rssa (open Ssa Machine
+		       structure ProfileStatement = ProfileExp)
 structure R = Rssa
 local
    open Rssa
@@ -46,7 +48,8 @@
    structure Var = Var
 end 
 
-structure ProfileAlloc = ProfileAlloc (structure Rssa = Rssa)
+structure Profile = Profile (structure Machine = Machine
+			     structure Rssa = Rssa)
 structure AllocateRegisters = AllocateRegisters (structure Machine = Machine
 						 structure Rssa = Rssa)
 structure Chunkify = Chunkify (Rssa)
@@ -114,8 +117,7 @@
 
 fun eliminateDeadCode (f: R.Function.t): R.Function.t =
    let
-      val {args, blocks, name, returns, raises, sourceInfo, start} =
-	 R.Function.dest f
+      val {args, blocks, name, returns, raises, start} = R.Function.dest f
       val {get, set, ...} =
 	 Property.getSetOnce (Label.plist, Property.initConst false)
       val get = Trace.trace ("Backend.labelIsReachable",
@@ -133,7 +135,6 @@
 		      name = name,
 		      returns = returns,
 		      raises = raises,
-		      sourceInfo = sourceInfo,
 		      start = start}
    end
 
@@ -149,10 +150,29 @@
       val program = pass ("ssaToRssa", SsaToRssa.convert, program)
       val program = pass ("insertLimitChecks", LimitCheck.insert, program)
       val program = pass ("insertSignalChecks", SignalCheck.insert, program)
-      val program =
-	 if !Control.profile = Control.ProfileAlloc
-	    then pass ("profileAlloc", ProfileAlloc.doit, program)
-	 else program
+      val {frameProfileIndices, labels = profileLabels, program, sources,
+	   sourceSeqs} =
+	 Control.passTypeCheck
+	 {display = Control.Layouts (fn ({program, ...}, output) =>
+				     Rssa.Program.layouts (program, output)),
+	  name = "profile",
+	  style = Control.No,
+	  suffix = "rssa",
+	  thunk = fn () => Profile.profile program,
+	  typeCheck = R.Program.typeCheck o #program}
+      val frameProfileIndex =
+	 if !Control.profile = Control.ProfileNone
+	    then fn _ => 0
+	 else
+	    let
+	       val {get, set, ...} =
+		  Property.getSetOnce
+		  (Label.plist,
+		   Property.initRaise ("frameProfileIndex", Label.layout))
+	       val _ = Vector.foreach (frameProfileIndices, set)
+	    in
+	       get
+	    end
       val _ =
 	 let
 	    open Control
@@ -164,8 +184,7 @@
 				Layouts Rssa.Program.layouts)
 	    else ()
 	 end
-      val program as R.Program.T {functions, main, objectTypes,
-				  profileAllocLabels} = program
+      val program as R.Program.T {functions, main, objectTypes} = program
       val handlesSignals = Rssa.Program.handlesSignals program
       (* Chunk information *)
       val {get = labelChunk, set = setLabelChunk, ...} =
@@ -184,11 +203,6 @@
 	    c
 	 end
       val handlers = ref []
-      val frames: {chunkLabel: M.ChunkLabel.t,
-		   func: string,
-		   offsets: int list,
-		   return: Label.t,
-		   size: int} list ref = ref []
       (* Set funcChunk and labelChunk. *)
       val _ =
 	 Vector.foreach
@@ -200,6 +214,81 @@
 	  in
 	     ()
 	  end)
+      (* FrameInfo. *)
+      local
+	 val frameSources = ref []
+	 val frameLayouts = ref []
+	 val frameLayoutsCounter = Counter.new 0
+	 val _ = IntSet.reset ()
+	 val table = HashSet.new {hash = Word.fromInt o #frameOffsetsIndex}
+	 val frameOffsets = ref []
+	 val frameOffsetsCounter = Counter.new 0
+	 val {get = frameOffsetsIndex: IntSet.t -> int, ...} =
+	    Property.get
+	    (IntSet.plist,
+	     Property.initFun
+	     (fn offsets =>
+	      let
+		 val _ = List.push (frameOffsets, IntSet.toList offsets)
+	      in
+		 Counter.next frameOffsetsCounter
+	      end))
+      in
+	 fun allFrameInfo () =
+	    let
+	       (* Reverse both lists because the index is from back of list. *)
+	       val frameOffsets =
+		  Vector.rev
+		  (Vector.fromListMap (!frameOffsets, Vector.fromList))
+	       val frameLayouts = Vector.fromListRev (!frameLayouts)
+	       val frameSources = Vector.fromListRev (!frameSources)
+	    in
+	       (frameLayouts, frameOffsets, frameSources)
+	    end
+	 fun getFrameLayoutsIndex {label: Label.t,
+				   offsets: int list,
+				   size: int}: int =
+	    let
+	       val profileIndex = frameProfileIndex label
+	       val foi = frameOffsetsIndex (IntSet.fromList offsets)
+	       fun new () =
+		  let
+		     val _ =
+			List.push (frameLayouts,
+				   {frameOffsetsIndex = foi,
+				    size = size})
+		     val _ = List.push (frameSources, profileIndex)
+		  in
+		     Counter.next frameLayoutsCounter
+		  end
+	    in
+	       if not (!Control.Native.native)
+		  then
+		     (* Assign the entries of each chunk consecutive integers
+		      * so that gcc will use a jump table.
+		      *)
+		     new ()
+	       else
+	       #frameLayoutsIndex
+	       (HashSet.lookupOrInsert
+		(table, Word.fromInt foi,
+		 fn {frameOffsetsIndex = foi',
+		     profileIndex = pi', size = s', ...} =>
+		 foi = foi' andalso profileIndex = pi' andalso size = s',
+		 fn () => {frameLayoutsIndex = new (),
+			   frameOffsetsIndex = foi,
+			   profileIndex = profileIndex,
+			   size = size}))
+	    end
+      end
+      val {get = frameInfo: Label.t -> M.FrameInfo.t,
+	   set = setFrameInfo, ...} = 
+	 Property.getSetOnce (Label.plist,
+			      Property.initRaise ("frameInfo", Label.layout))
+      val setFrameInfo =
+	 Trace.trace2 ("Backend.setFrameInfo",
+		       Label.layout, M.FrameInfo.layout, Unit.layout)
+	 setFrameInfo
       (* The global raise operands. *)
       local
 	 val table: (Type.t vector * M.Operand.t vector) list ref = ref []
@@ -390,6 +479,8 @@
 			     dst = Option.map (dst, varOperand o #1),
 			     prim = prim})
 		  end
+	     | Profile p => Error.bug "backend saw strange profile statement"
+	     | ProfileLabel s => Vector.new1 (M.Statement.ProfileLabel s)
 	     | SetExnStackLocal =>
 		  Vector.new1
 		  (M.Statement.SetExnStackLocal {offset = handlerOffset ()})
@@ -445,6 +536,7 @@
 	    val {args, blocks, name, raises, returns, start, ...} =
 	       Function.dest f
 	    val func = Func.toString name
+	    val profileInfoFunc = Func.toString name
 	    val raises = Option.map (raises, fn ts => raiseOperands ts)
 	    val returns =
 	       Option.map (returns, fn ts =>
@@ -539,7 +631,33 @@
 		   function = f,
 		   varInfo = varInfo}
 	    end
-	    val profileInfoFunc = Func.toString name
+	    (* Set the frameInfo for Conts and CReturns in this function. *)
+	    val _ =
+	       Vector.foreach
+	       (blocks, fn R.Block.T {kind, label, ...} =>
+		if not (R.Kind.isFrame kind)
+		   then ()
+		else
+		   let
+		      val {liveNoFormals, size, ...} = labelRegInfo label
+		      val offsets =
+			 Vector.fold
+			 (liveNoFormals, [], fn (oper, ac) =>
+			  case oper of
+			     M.Operand.StackOffset {offset, ty} =>
+				if Type.isPointer ty
+				   then offset :: ac
+				else ac
+			   | _ => ac)
+		      val frameLayoutsIndex =
+			 getFrameLayoutsIndex {label = label,
+					       offsets = offsets,
+					       size = size}
+		   in
+		      setFrameInfo (label,
+				    M.FrameInfo.T
+				    {frameLayoutsIndex = frameLayoutsIndex})
+		   end)
 	    (* ------------------------------------------------- *)
 	    (*                    genTransfer                    *)
 	    (* ------------------------------------------------- *)
@@ -563,7 +681,8 @@
 			simple (M.Transfer.CCall
 				{args = translateOperands args,
 				 frameInfo = if CFunction.mayGC func
-						then SOME M.FrameInfo.bogus
+						then SOME (frameInfo
+							   (valOf return))
 					     else NONE,
 				 func = func,
 				 return = return})
@@ -722,33 +841,14 @@
 				  genStatement (s, handlerLinkOffset)))
 		  val (preTransfer, transfer) =
 		     genTransfer (transfer, chunk, label)
-		  fun frame () =
-		     let
-			val offsets =
-			   Vector.fold
-			   (liveNoFormals, [], fn (oper, ac) =>
-			    case oper of
-			       M.Operand.StackOffset {offset, ty} =>
-				  if Type.isPointer ty
-				     then offset :: ac
-				  else ac
-			     | _ => ac)
-		     in
-			List.push (frames, {chunkLabel = Chunk.label chunk,
-					    func = func,
-					    offsets = offsets,
-					    return = label,
-					    size = size})
-		     end
 		  val (kind, live, pre) =
 		     case kind of
 			R.Kind.Cont _ =>
 			   let
-			      val _ = frame ()
 			      val srcs = callReturnOperands (args, #2, size)
 			   in
 			      (M.Kind.Cont {args = srcs,
-					    frameInfo = M.FrameInfo.bogus},
+					    frameInfo = frameInfo label},
 			       liveNoFormals,
 			       parallelMove
 			       {chunk = chunk,
@@ -765,12 +865,7 @@
 				  | _ => Error.bug "strange CReturn"
 			      val frameInfo =
 				 if mayGC
-				    then
-				       let
-					  val _ = frame ()
-				       in
-					  SOME M.FrameInfo.bogus
-				       end
+				    then SOME (frameInfo label)
 				 else NONE
 			   in
 			      (M.Kind.CReturn {dst = dst,
@@ -831,86 +926,10 @@
        *)
       val _ = genFunc (main, true)
       val _ = List.foreach (functions, fn f => genFunc (f, false))
-      val funcSources =
-	 Vector.fromListMap
-	 (main :: functions, fn f =>
-	  let
-	     val {name, sourceInfo, ...} = R.Function.dest f
-	  in
-	     {func = Func.toString name,
-	      sourceInfo = sourceInfo}
-	  end)
       val chunks = !chunks
-      val _ = IntSet.reset ()
-      val c = Counter.new 0
-      val frameOffsets = ref []
-      val {get: IntSet.t -> int, ...} =
-	 Property.get
-	 (IntSet.plist,
-	  Property.initFun
-	  (fn offsets =>
-	   let val index = Counter.next c
-	   in
-	      List.push (frameOffsets, IntSet.toList offsets)
-	      ; index
-	   end))
-      val {get = frameInfo: Label.t -> M.FrameInfo.t, set = setFrameInfo, ...} = 
-	 Property.getSetOnce (Label.plist,
-			      Property.initRaise ("frameInfo", Label.layout))
-      val setFrameInfo =
-	 Trace.trace2 ("Backend.setFrameInfo",
-		       Label.layout, M.FrameInfo.layout, Unit.layout)
-	 setFrameInfo
-      val _ =
-	 List.foreach
-	 (!frames, fn {func, offsets, return, size, ...} =>
-	  setFrameInfo
-	  (return,
-	   M.FrameInfo.T {frameOffsetsIndex = get (IntSet.fromList offsets),
-			  func = func,
-			  size = size}))
-      (* Reverse the list of frameOffsets because offsetIndex 
-       * is from back of list.
-       *)
-      val frameOffsets =
-	 Vector.rev (Vector.fromListMap (!frameOffsets, Vector.fromList))
-      fun blockToMachine (M.Block.T {kind, label, live, profileInfo,
-				     raises, returns, statements, transfer}) =
-	 let
-	    datatype z = datatype M.Kind.t
-	    val kind =
-	       case kind of
-		  Cont {args, ...} => Cont {args = args,
-					    frameInfo = frameInfo label}
-		| CReturn {dst, frameInfo = f, func} =>
-		     CReturn {dst = dst,
-			      frameInfo = Option.map (f, fn _ =>
-						      frameInfo label),
-			      func = func}
-		| _ => kind
-	    val transfer =
-	       case transfer of
-		  M.Transfer.CCall {args, frameInfo = f, func, return} =>
-		     M.Transfer.CCall
-		     {args = args,
-		      frameInfo = Option.map (f, fn _ =>
-					      frameInfo (valOf return)),
-		      func = func,
-		      return = return}
-		| _ => transfer
-	 in
-	    M.Block.T {kind = kind,
-		       label = label,
-		       live = live,
-		       profileInfo = profileInfo,
-		       raises = raises,
-		       returns = returns,
-		       statements = statements,
-		       transfer = transfer}
-	 end
       fun chunkToMachine (Chunk.T {chunkLabel, blocks}) =
 	 let
-	    val blocks = Vector.fromListMap (!blocks, blockToMachine)
+	    val blocks = Vector.fromList (!blocks)
 	    val regMax = Runtime.Type.memo (fn _ => ref ~1)
 	    val regsNeedingIndex =
 	       Vector.fold
@@ -957,6 +976,7 @@
        *)
       val _ = List.foreach (chunks, fn M.Chunk.T {blocks, ...} =>
 			    Vector.foreach (blocks, Label.clear o M.Block.label))
+      val (frameLayouts, frameOffsets, frameSources) = allFrameInfo ()
       val maxFrameSize =
 	 List.fold
 	 (chunks, 0, fn (M.Chunk.T {blocks, ...}, max) =>
@@ -980,7 +1000,10 @@
 	      val max =
 		 case M.Kind.frameInfoOpt kind of
 		    NONE => max
-		  | SOME (M.FrameInfo.T {size, ...}) => Int.max (max, size)
+		  | SOME (M.FrameInfo.T {frameLayoutsIndex, ...}) =>
+		       Int.max
+		       (max,
+			#size (Vector.sub (frameLayouts, frameLayoutsIndex)))
 	      val max =
 		 Vector.fold
 		 (statements, max, fn (s, max) =>
@@ -991,17 +1014,22 @@
 	      max
 	   end))
       val maxFrameSize = Runtime.wordAlignInt maxFrameSize
+      val profileInfo =
+	 ProfileInfo.T {frameSources = frameSources,
+			labels = profileLabels,
+			sources = sources,
+			sourceSeqs = sourceSeqs}
    in
       Machine.Program.T 
       {chunks = chunks,
+       frameLayouts = frameLayouts,
        frameOffsets = frameOffsets,
-       funcSources = funcSources,
        handlesSignals = handlesSignals,
        intInfs = allIntInfs (), 
        main = main,
        maxFrameSize = maxFrameSize,
        objectTypes = objectTypes,
-       profileAllocLabels = profileAllocLabels,
+       profileInfo = profileInfo,
        reals = allReals (),
        strings = allStrings ()}
    end



1.5       +18 -23    mlton/mlton/backend/c-function.fun

Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-function.fun	24 Nov 2002 01:19:43 -0000	1.4
+++ c-function.fun	19 Dec 2002 23:43:32 -0000	1.5
@@ -47,6 +47,8 @@
    val returnTy = make #returnTy
 end
 
+fun equals (f, f') = name f = name f'
+
 fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
 	     modifiesStackTop, returnTy, ...}): bool =
    (if maySwitchThreads
@@ -60,33 +62,11 @@
     else true)
    andalso 
    (if mayGC
-       then modifiesFrontier andalso modifiesStackTop
+       then (modifiesFrontier andalso modifiesStackTop)
     else true)
 
 val isOk = Trace.trace ("CFunction.isOk", layout, Bool.layout) isOk
 
-fun equals (T {bytesNeeded = b,
-	       ensuresBytesFree = e,
-	       mayGC = g,
-	       maySwitchThreads = s,
-	       modifiesFrontier = f,
-	       modifiesStackTop = t,
-	       name = n,
-	       needsProfileAllocIndex = np,
-	       returnTy = r},
-	    T {bytesNeeded = b',
-	       ensuresBytesFree = e',
-	       mayGC = g',
-	       maySwitchThreads = s',
-	       modifiesFrontier = f',
-	       modifiesStackTop = t',
-	       name = n',
-	       needsProfileAllocIndex = np',
-	       returnTy = r'}) =
-   b = b' andalso e = e' andalso g = g' andalso s = s' andalso f = f'
-   andalso t = t' andalso n = n' andalso np = np'
-   andalso Option.equals (r, r', Type.equals)
-
 val equals =
    Trace.trace2 ("CFunction.equals", layout, layout, Bool.layout) equals
 	 
@@ -123,4 +103,19 @@
 
 val size = vanilla {name = "MLton_size",
 		    returnTy = SOME Type.int}
+
+val profileAllocInc =
+   T {bytesNeeded = NONE,
+      ensuresBytesFree = false,
+      modifiesFrontier = false,
+      (* Acutally, it just reads the stackTop, but we have no way to read and
+       * not modify.
+       *)
+      modifiesStackTop = true,
+      mayGC = false,
+      maySwitchThreads = false,
+      name = "MLton_ProfileAlloc_inc",
+      needsProfileAllocIndex = true,
+      returnTy = NONE}
+
 end



1.4       +1 -0      mlton/mlton/backend/c-function.sig

Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- c-function.sig	24 Nov 2002 01:19:43 -0000	1.3
+++ c-function.sig	19 Dec 2002 23:43:32 -0000	1.4
@@ -47,6 +47,7 @@
       val modifiesStackTop: t -> bool
       val name: t -> string
       val needsProfileAllocIndex: t -> bool
+      val profileAllocInc: t
       val returnTy: t -> Type.t option
       val size: t
       val vanilla: {name: string, returnTy: Type.t option} -> t



1.6       +1 -2      mlton/mlton/backend/implement-handlers.fun

Index: implement-handlers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/implement-handlers.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- implement-handlers.fun	12 Dec 2002 01:14:21 -0000	1.5
+++ implement-handlers.fun	19 Dec 2002 23:43:32 -0000	1.6
@@ -31,7 +31,7 @@
    let
       fun implementFunction (f: Function.t): Function.t =
 	 let
-	    val {args, blocks, name, raises, returns, sourceInfo, start} =
+	    val {args, blocks, name, raises, returns, start} =
 	       Function.dest f
 	    val {get = labelInfo: Label.t -> LabelInfo.t,
 		 set = setLabelInfo, ...} =
@@ -155,7 +155,6 @@
 			  name = name,
 			  raises = raises,
 			  returns = returns,
-			  sourceInfo = sourceInfo,
 			  start = start}
 	 end
    in



1.31      +5 -10     mlton/mlton/backend/limit-check.fun

Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- limit-check.fun	12 Dec 2002 18:25:05 -0000	1.30
+++ limit-check.fun	19 Dec 2002 23:43:32 -0000	1.31
@@ -113,8 +113,7 @@
 		    blockCheckAmount: {blockIndex: int} -> word,
 		    ensureBytesFree: Label.t -> word) =
    let
-      val {args, blocks, name, raises, returns, sourceInfo, start} =
-	 Function.dest f
+      val {args, blocks, name, raises, returns, start} = Function.dest f
       val newBlocks = ref []
       local
 	 val r: Label.t option ref = ref NONE
@@ -429,7 +428,6 @@
 		    name = name,
 		    raises = raises,
 		    returns = returns,
-		    sourceInfo = sourceInfo,
 		    start = start}
    end
 
@@ -451,8 +449,7 @@
 
 fun insertCoalesce (f: Function.t, handlesSignals) =
    let
-      val {args, blocks, name, raises, returns, sourceInfo, start} =
-	 Function.dest f
+      val {args, blocks, name, raises, returns, start} = Function.dest f
       val n = Vector.length blocks
       val {get = labelIndex, set = setLabelIndex, rem = remLabelIndex, ...} =
 	 Property.getSetOnce
@@ -712,7 +709,7 @@
       f
    end
 
-fun insert (p as Program.T {functions, main, objectTypes, profileAllocLabels}) =
+fun insert (p as Program.T {functions, main, objectTypes}) =
    let
       val _ = Control.diagnostic (fn () => Layout.str "Limit Check maxPaths")
       datatype z = datatype Control.limitCheck
@@ -722,7 +719,7 @@
 	    PerBlock => insertPerBlock (f, handlesSignals)
 	  | _ => insertCoalesce (f, handlesSignals)
       val functions = List.revMap (functions, insert)
-      val {args, blocks, name, raises, returns, sourceInfo, start} =
+      val {args, blocks, name, raises, returns, start} =
 	 Function.dest (insert main)
       val newStart = Label.newNoname ()
       val block =
@@ -744,13 +741,11 @@
 			       name = name,
 			       raises = raises,
 			       returns = returns,
-			       sourceInfo = sourceInfo,
 			       start = newStart}
    in
       Program.T {functions = functions,
 		 main = main,
-		 objectTypes = objectTypes,
-		 profileAllocLabels = profileAllocLabels}
+		 objectTypes = objectTypes}
    end
 
 end



1.3       +17 -0     mlton/mlton/backend/machine-atoms.fun

Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- machine-atoms.fun	10 Dec 2002 21:45:48 -0000	1.2
+++ machine-atoms.fun	19 Dec 2002 23:43:32 -0000	1.3
@@ -406,6 +406,23 @@
 	  (PointerTycon.wordVector, wordVector)]
    end
 
+structure ProfileLabel =
+   struct
+      datatype t = T of int
+
+      local
+	 val c = Counter.new 0
+      in
+	 fun new () = T (Counter.next c)
+      end
+
+      fun toString (T n) = concat ["MLtonProfile", Int.toString n]
+
+      val layout = Layout.str o toString
+
+      fun equals (T n, T n') = n = n'
+   end
+
 fun castIsOk {from: Type.t,
 	      fromInt: int option,
 	      to: Type.t,



1.3       +10 -0     mlton/mlton/backend/machine-atoms.sig

Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- machine-atoms.sig	12 Dec 2002 01:14:21 -0000	1.2
+++ machine-atoms.sig	19 Dec 2002 23:43:32 -0000	1.3
@@ -112,6 +112,16 @@
 	    val wordVector: t
 	 end
 
+      structure ProfileLabel:
+	 sig
+	    type t
+
+	    val equals: t * t -> bool
+	    val layout: t -> Layout.t
+	    val new: unit -> t
+	    val toString: t -> string
+	 end
+
       val castIsOk: {from: Type.t,
 		     fromInt: int option,
 		     to: Type.t,



1.33      +97 -36    mlton/mlton/backend/machine.fun

Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- machine.fun	12 Dec 2002 01:14:21 -0000	1.32
+++ machine.fun	19 Dec 2002 23:43:32 -0000	1.33
@@ -27,7 +27,7 @@
 open Atoms
 
 structure ChunkLabel = IntUniqueId ()
-   
+
 structure SmallIntInf =
    struct
       type t = word
@@ -321,6 +321,7 @@
        | PrimApp of {args: Operand.t vector,
 		     dst: Operand.t option,
 		     prim: Prim.t}
+       | ProfileLabel of ProfileLabel.t
        | SetExnStackLocal of {offset: int}
        | SetExnStackSlot of {offset: int}
        | SetSlotExnStack of {offset: int}
@@ -356,6 +357,8 @@
 			   mayAlign [Operand.layout z,
 				     seq [str " = ", rest]]
 		  end
+	     | ProfileLabel l =>
+		  seq [str "ProfileLabel ", ProfileLabel.layout l]
 	     | SetExnStackLocal {offset} =>
 		  seq [str "SetExnStackLocal ", Int.layout offset]
 	     | SetExnStackSlot {offset} =>
@@ -404,24 +407,16 @@
 
 structure FrameInfo =
    struct
-      datatype t = T of {frameOffsetsIndex: int,
-			 func: string,
-			 size: int}
+      datatype t = T of {frameLayoutsIndex: int}
 
       local
 	 fun make f (T r) = f r
       in
-	 val frameOffsetsIndex = make #frameOffsetsIndex
-	 val size = make #size
+	 val frameLayoutsIndex = make #frameLayoutsIndex
       end
    
-      fun layout (T {frameOffsetsIndex, size, ...}) =
-	 Layout.record [("frameOffsetsIndex", Int.layout frameOffsetsIndex),
-			("size", Int.layout size)]
-
-      val bogus = T {frameOffsetsIndex = ~1,
-		     func = "<unknown>",
- 		     size = ~1}
+      fun layout (T {frameLayoutsIndex, ...}) =
+	 Layout.record [("frameLayoutsIndex", Int.layout frameLayoutsIndex)]
    end
 
 structure Transfer =
@@ -622,26 +617,39 @@
 	 Vector.foreach (blocks, fn block => Block.layouts (block, output))
    end
 
+structure ProfileInfo =
+   struct
+      datatype t =
+	 T of {frameSources: int vector,
+	       labels: {label: ProfileLabel.t,
+			sourceSeqsIndex: int} vector,
+	       sourceSeqs: int vector vector,
+	       sources: SourceInfo.t vector}
+   end
+
 structure Program =
    struct
       datatype t = T of {chunks: Chunk.t list,
+			 frameLayouts: {frameOffsetsIndex: int,
+					size: int} vector,
 			 frameOffsets: int vector vector,
-			 funcSources: {func: string,
-				       sourceInfo: SourceInfo.t} vector,
 			 handlesSignals: bool,
 			 intInfs: (Global.t * string) list,
 			 main: {chunkLabel: ChunkLabel.t,
 				label: Label.t},
 			 maxFrameSize: int,
 			 objectTypes: ObjectType.t vector,
-			 profileAllocLabels: string vector,
+			 profileInfo: ProfileInfo.t,
 			 reals: (Global.t * string) list,
 			 strings: (Global.t * string) list}
 
+      fun frameSize (T {frameLayouts, ...},
+		     FrameInfo.T {frameLayoutsIndex, ...}) =
+	 #size (Vector.sub (frameLayouts, frameLayoutsIndex))
+
       fun layouts (p as T {chunks, frameOffsets, handlesSignals,
 			   main = {label, ...},
-			   maxFrameSize, objectTypes,
-			   profileAllocLabels, ...},
+			   maxFrameSize, objectTypes, ...},
 		   output': Layout.t -> unit) =
 	 let
 	    open Layout
@@ -651,14 +659,13 @@
 		    [("handlesSignals", Bool.layout handlesSignals),
 		     ("main", Label.layout label),
 		     ("maxFrameSize", Int.layout maxFrameSize),
-		     ("profileAllocLabels",
-		      Vector.layout String.layout profileAllocLabels),
 		     ("frameOffsets",
 		      Vector.layout (Vector.layout Int.layout) frameOffsets)])
 	    ; output (str "\nObjectTypes:")
 	    ; Vector.foreachi (objectTypes, fn (i, ty) =>
 			       output (seq [str "pt_", Int.layout i,
 					    str " = ", ObjectType.layout ty]))
+	    ; output (str "\n")
             ; List.foreach (chunks, fn chunk => Chunk.layouts (chunk, output))
 	 end
 
@@ -692,12 +699,63 @@
 	       doesDefine
 	 end
       
-      fun typeCheck (T {chunks, frameOffsets, intInfs, main,
-			maxFrameSize, objectTypes, reals, strings, ...}) =
+      fun typeCheck (T {chunks, frameLayouts, frameOffsets, intInfs, main,
+			maxFrameSize, objectTypes,
+			profileInfo = ProfileInfo.T {frameSources,
+						     labels = profileLabels,
+						     sources,
+						     sourceSeqs},
+			reals, strings, ...}) =
 	 let
+	    val maxProfileLabel = Vector.length sourceSeqs
+	    val _ =
+	       Vector.foreach
+	       (profileLabels, fn {sourceSeqsIndex = i, ...} =>
+		Err.check
+		("profileLabes",
+		 fn () => 0 <= i andalso i < maxProfileLabel,
+		 fn () => Int.layout i))
+	    val _ =
+	       let
+		  val maxFrameSourceSeq = Vector.length sourceSeqs
+		  val _ =
+		     Vector.foreach
+		     (frameSources, fn i =>
+		      Err.check
+		      ("frameSources", 
+		       fn () => 0 <= i andalso i <= maxFrameSourceSeq,
+		       fn () => Int.layout i))
+		  val maxSource = Vector.length sources
+		  val _ =
+		     Vector.foreach
+		     (sourceSeqs, fn v =>
+		      Vector.foreach
+		      (v, fn i =>
+		       Err.check
+		       ("sourceSeq",
+			fn () => 0 <= i andalso i < maxSource,
+			fn () => Int.layout i)))
+	       in
+		  ()
+	       end
+	    fun getFrameInfo (FrameInfo.T {frameLayoutsIndex, ...}) =
+	       Vector.sub (frameLayouts, frameLayoutsIndex)
 	    fun boolToUnitOpt b = if b then SOME () else NONE
 	    val _ =
 	       Vector.foreach
+	       (frameLayouts, fn {frameOffsetsIndex, size} =>
+		Err.check
+		("frameLayouts",
+		 fn () => (0 <= frameOffsetsIndex
+			   andalso frameOffsetsIndex < Vector.length frameOffsets
+			   andalso size <= maxFrameSize
+			   andalso size <= Runtime.maxFrameSize
+			   andalso 0 = Int.rem (size, 4)),
+		 fn () => Layout.record [("frameOffsetsIndex",
+					  Int.layout frameOffsetsIndex),
+					 ("size", Int.layout size)]))
+	    val _ =
+	       Vector.foreach
 	       (objectTypes, fn ty =>
 		Err.check ("objectType",
 			   fn () => ObjectType.isOk ty,
@@ -828,17 +886,11 @@
 	       Vector.foreach (v, fn z => checkOperand (z, a))
 	    fun check' (x, name, isOk, layout) =
 	       Err.check (name, fn () => isOk x, fn () => layout x)
-	    fun frameInfoOk (FrameInfo.T {frameOffsetsIndex, size, ...}) =
-	       0 <= frameOffsetsIndex
-	       andalso frameOffsetsIndex <= Vector.length frameOffsets
-	       andalso 0 <= size
-	       andalso size <= maxFrameSize
-	       andalso size <= Runtime.maxFrameSize
-	       andalso 0 = Int.rem (size, 4)
+	    fun frameInfoOk (FrameInfo.T {frameLayoutsIndex, ...}) =
+	       0 <= frameLayoutsIndex
+	       andalso frameLayoutsIndex < Vector.length frameLayouts
 	    fun checkFrameInfo i =
-	       check' (i, "frame info",
-		       frameInfoOk,
-		       FrameInfo.layout)
+	       check' (i, "frame info", frameInfoOk, FrameInfo.layout)
 	    val labelKind = Block.kind o labelBlock
 	    fun labelIsJump (l: Label.t): bool =
 	       case labelKind l of
@@ -852,7 +904,7 @@
 		     Cont {args, frameInfo} =>
 			let
 			   val _ = checkFrameInfo frameInfo
-			   val FrameInfo.T {size, ...} = frameInfo
+			   val {size, ...} = getFrameInfo frameInfo
 			in
 			   if (Alloc.forall
 			       (alloc, fn z =>
@@ -931,6 +983,15 @@
 				    SOME alloc
 				 end
 			end
+		   | ProfileLabel l =>
+			if !Control.profile = Control.ProfileTime
+			   then
+			      if Vector.exists
+				 (profileLabels, fn {label, ...} =>
+				  ProfileLabel.equals (l, label))
+				 then SOME alloc
+			      else NONE
+			else SOME alloc
 		   | SetExnStackLocal {offset} =>
 			(checkOperand
 			 (Operand.StackOffset {offset = offset,
@@ -985,7 +1046,7 @@
 		     then
 			(case kind of
 			    Kind.Cont {args, frameInfo, ...} =>
-			       (if size = FrameInfo.size frameInfo
+			       (if size = #size (getFrameInfo frameInfo)
 				   then
 				      SOME
 				      (live,
@@ -1158,8 +1219,8 @@
 		Layout.tuple [Transfer.layout t, Alloc.layout a],
 		Bool.layout)
 	       transferOk
-	    fun blockOk (Block.T {kind, label, live, profileInfo, raises,
-				  returns, statements, transfer}): bool =
+	    fun blockOk (Block.T {kind, label, live, raises, returns, statements,
+				  transfer, ...}): bool =
 	       let
 		  val live = Vector.toList live
 		  val _ =



1.26      +23 -12    mlton/mlton/backend/machine.sig

Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- machine.sig	12 Dec 2002 01:14:21 -0000	1.25
+++ machine.sig	19 Dec 2002 23:43:32 -0000	1.26
@@ -110,6 +110,7 @@
 	     | PrimApp of {args: Operand.t vector,
 			   dst: Operand.t option,
 			   prim: Prim.t}
+	     | ProfileLabel of ProfileLabel.t
 	     | SetExnStackLocal of {offset: int}
 	     | SetExnStackSlot of {offset: int}
 	     | SetSlotExnStack of {offset: int}
@@ -124,16 +125,9 @@
 
       structure FrameInfo:
 	 sig
-	    datatype t =
-	       T of {(* Index into frameOffsets *)
-		     frameOffsetsIndex: int,
-		     func: string,
-		     (* Size of frame in bytes, including return address. *)
-		     size: int}
+	    datatype t = T of {frameLayoutsIndex: int}
 
-	    val bogus: t
 	    val layout: t -> Layout.t
-	    val size: t -> int
 	 end
 
       structure Transfer:
@@ -216,27 +210,44 @@
 		     regMax: Runtime.Type.t -> int}
 	 end
 
+      structure ProfileInfo:
+	 sig
+	    datatype t =
+	       T of {(* For each frame, gives the index into sourceSeqs of the
+		      * source functions corresponding to the frame.
+		      *)
+	             frameSources: int vector,
+		     labels: {label: ProfileLabel.t,
+			      sourceSeqsIndex: int} vector,
+		     (* Each sourceSeq describes a sequence of source functions,
+		      * each given as an index into the source vector.
+		      *)
+		     sourceSeqs: int vector vector,
+		     sources: SourceInfo.t vector}
+	 end
+
       structure Program:
 	 sig
 	    datatype t =
 	       T of {chunks: Chunk.t list,
+		     frameLayouts: {frameOffsetsIndex: int,
+				    size: int} vector,
 		     (* Each vector in frame Offsets specifies the offsets
 		      * of live pointers in a stack frame.  A vector is referred
-		      * to by index as the frameOffsetsIndex in a block kind.
+		      * to by index as the offsetsIndex in frameLayouts.
 		      *)
 		     frameOffsets: int vector vector,
-		     funcSources: {func: string,
-				   sourceInfo: SourceInfo.t} vector,
 		     handlesSignals: bool,
 		     intInfs: (Global.t * string) list,
 		     main: {chunkLabel: ChunkLabel.t,
 			    label: Label.t},
 		     maxFrameSize: int,
 		     objectTypes: ObjectType.t vector,
-		     profileAllocLabels: string vector,
+		     profileInfo: ProfileInfo.t,
 		     reals: (Global.t * string) list,
 		     strings: (Global.t * string) list}
 
+	    val frameSize: t * FrameInfo.t -> int
 	    val layouts: t * (Layout.t -> unit) -> unit
 	    val typeCheck: t -> unit
 	 end



1.24      +15 -4     mlton/mlton/backend/rssa.fun

Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- rssa.fun	12 Dec 2002 18:25:05 -0000	1.23
+++ rssa.fun	19 Dec 2002 23:43:32 -0000	1.24
@@ -168,6 +168,8 @@
        | PrimApp of {args: Operand.t vector,
 		     dst: (Var.t * Type.t) option,
 		     prim: Prim.t}
+       | Profile of ProfileStatement.t
+       | ProfileLabel of ProfileLabel.t
        | SetExnStackLocal
        | SetExnStackSlot
        | SetHandler of Label.t
@@ -195,6 +197,8 @@
 			       Option.fold (dst, a, fn ((x, t), a) =>
 					    def (x, t, a)),
 			       useOperand)
+	     | Profile _ => a
+	     | ProfileLabel _ => a
 	     | SetExnStackLocal => a
 	     | SetExnStackSlot => a
 	     | SetHandler _ => a
@@ -255,6 +259,8 @@
 			   mayAlign [seq [Var.layout x, constrain t],
 				     seq [str " = ", rest]]
 		  end
+	     | Profile p => ProfileStatement.layout p
+	     | ProfileLabel l => seq [str "ProfileLabel ", ProfileLabel.layout l]
 	     | SetExnStackLocal => str "SetExnStackLocal"
 	     | SetExnStackSlot => str "SetExnStackSlot "
 	     | SetHandler l => seq [str "SetHandler ", Label.layout l]
@@ -439,6 +445,12 @@
 	     | Handler => str "Handler"
 	     | Jump => str "Jump"
 	 end
+
+      fun isFrame (k: t): bool =
+	 case k of
+	    Cont _ => true
+	  | CReturn {func = CFunction.T {mayGC, ...}, ...} => mayGC
+	  | _ => false
    end
 
 local
@@ -509,7 +521,6 @@
 			 name: Func.t,
 			 raises: Type.t vector option,
 			 returns: Type.t vector option,
-			 sourceInfo: SourceInfo.t,
 			 start: Label.t}
 
       local
@@ -520,7 +531,6 @@
 	 val name = make #name
 	 val raises = make #raises
 	 val returns = make #returns
-	 val sourceInfo = make #sourceInfo
 	 val start = make #start
       end
 
@@ -643,8 +653,7 @@
       datatype t =
 	 T of {functions: Function.t list,
 	       main: Function.t,
-	       objectTypes: ObjectType.t vector,
-	       profileAllocLabels: string vector}
+	       objectTypes: ObjectType.t vector}
 
       fun clear (T {functions, main, ...}) =
 	 (List.foreach (functions, Function.clear)
@@ -917,6 +926,8 @@
 		   | PrimApp {args, ...} =>
 			(Vector.foreach (args, checkOperand)
 			 ; true)
+		   | Profile _ => true
+		   | ProfileLabel _ => true
 		   | SetExnStackLocal => true
 		   | SetExnStackSlot => true
 		   | SetHandler l =>



1.20      +14 -5     mlton/mlton/backend/rssa.sig

Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- rssa.sig	12 Dec 2002 18:25:05 -0000	1.19
+++ rssa.sig	19 Dec 2002 23:43:32 -0000	1.20
@@ -25,6 +25,14 @@
 	    val layout: t -> Layout.t
 	    val map: t * (Label.t -> Label.t) -> t
 	 end
+      structure ProfileStatement:
+	 sig
+	    datatype t =
+	       Enter of SourceInfo.t
+	     | Leave of SourceInfo.t
+
+	    val layout: t -> Layout.t
+	 end
       structure Return:
 	 sig
 	    datatype t =
@@ -91,7 +99,7 @@
 	    val word: word -> t
 	 end
       sharing Operand = Switch.Use
-      
+    
       structure Statement:
 	 sig
 	    datatype t =
@@ -110,6 +118,8 @@
 	     | PrimApp of {args: Operand.t vector,
 			   dst: (Var.t * Type.t) option,
 			   prim: Prim.t}
+	     | Profile of ProfileStatement.t
+	     | ProfileLabel of ProfileLabel.t
 	     | SetExnStackLocal
 	     | SetExnStackSlot
 	     | SetHandler of Label.t (* label must be of Handler kind. *)
@@ -182,6 +192,8 @@
 	     | CReturn of {func: CFunction.t}
 	     | Handler
 	     | Jump
+
+	    val isFrame: t -> bool
 	 end
 
       structure Block:
@@ -214,7 +226,6 @@
 			    name: Func.t,
 			    raises: Type.t vector option,
 			    returns: Type.t vector option,
-			    sourceInfo: SourceInfo.t,
 			    start: Label.t}
 	    (* dfs (f, v) visits the blocks in depth-first order, applying v b
 	     * for block b to yield v', then visiting b's descendents,
@@ -227,7 +238,6 @@
 		      name: Func.t,
 		      raises: Type.t vector option,
 		      returns: Type.t vector option,
-		      sourceInfo: SourceInfo.t,
 		      start: Label.t} -> t
 	    val start: t -> Label.t
 	 end
@@ -237,8 +247,7 @@
 	    datatype t =
 	       T of {functions: Function.t list,
 		     main: Function.t,
-		     objectTypes: ObjectType.t vector,
-		     profileAllocLabels: string vector}
+		     objectTypes: ObjectType.t vector}
 
 	    val clear: t -> unit
 	    val handlesSignals: t -> bool



1.13      +166 -158  mlton/mlton/backend/signal-check.fun

Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- signal-check.fun	12 Dec 2002 01:14:21 -0000	1.12
+++ signal-check.fun	19 Dec 2002 23:43:32 -0000	1.13
@@ -12,172 +12,180 @@
 open Rssa
 
 structure Graph = DirectedGraph
-structure Node = Graph.Node
-structure Edge = Graph.Edge
-structure Forest = Graph.LoopForest
+local
+   open Graph
+in
+   structure Node = Node
+   structure Edge = Edge
+   structure Forest = LoopForest
+end
+
+fun insertInFunction (f: Function.t): Function.t =
+   let
+      val {args, blocks, name, raises, returns, start} =
+	 Function.dest f
+      val {get = labelIndex: Label.t -> int, set = setLabelIndex,
+	   rem = remLabelIndex, ...} =
+	 Property.getSetOnce
+	 (Label.plist, Property.initRaise ("index", Label.layout))
+      val _ =
+	 Vector.foreachi (blocks, fn (i, Block.T {label, ...}) =>
+			  setLabelIndex (label, i))
+      val g = Graph.new ()
+      val n = Vector.length blocks
+      val {get = nodeIndex: Node.t -> int, set = setNodeIndex, ...} =
+	 Property.getSetOnce
+	 (Node.plist, Property.initRaise ("index", Node.layout))
+      val nodes =
+	 Vector.tabulate (n, fn i =>
+			  let
+			     val n = Graph.newNode g
+			     val _ = setNodeIndex (n, i)
+			  in
+			     n
+			  end)
+      val isHeader = Array.new (n, false)
+      fun indexNode i = Vector.sub (nodes, i)
+      val labelNode = indexNode o labelIndex
+      val _ =
+	 Vector.foreachi
+	 (blocks, fn (i, Block.T {label, transfer, ...}) =>
+	  let
+	     val from = indexNode i
+	  in
+	     if (case transfer of
+		    Transfer.CCall {func, ...} =>
+		       CFunction.maySwitchThreads func
+		  | _ => false)
+		then ()
+	     else
+		Transfer.foreachLabel
+		(transfer, fn to =>
+		 (Graph.addEdge (g, {from = from,
+				     to = labelNode to})
+		  ; ()))
+	  end)
+      val extra: Block.t list ref = ref []
+      fun addSignalCheck (i: int): unit =
+	 let
+	    val _ = Array.update (isHeader, i, true)
+	    val Block.T {args, kind, label, profileInfo,
+			 statements, transfer} =
+	       Vector.sub (blocks, i)
+	    val failure = Label.newNoname ()
+	    val success = Label.newNoname ()
+	    val collect = Label.newNoname ()
+	    val collectReturn = Label.newNoname ()
+	    val dontCollect = Label.newNoname ()
+	    val res = Var.newNoname ()
+	    val compare =
+	       Vector.new1
+	       (Statement.PrimApp
+		{args = Vector.new2 (Operand.Cast
+				     (Operand.Runtime
+				      Runtime.GCField.Limit,
+				      Type.Word),
+				     Operand.word 0w0),
+		 dst = SOME (res, Type.bool),
+		 prim = Prim.eq})
+	    val compareTransfer =
+	       Transfer.ifBool
+	       (Operand.Var {var = res, ty = Type.bool},
+		{falsee = dontCollect,
+		 truee = collect})
+	    val func = CFunction.gc {maySwitchThreads = true}
+	    val _ =
+	       extra :=
+	       Block.T {args = args,
+			kind = kind,
+			label = label,
+			profileInfo = profileInfo,
+			statements = compare,
+			transfer = compareTransfer}
+	       :: (Block.T
+		   {args = Vector.new0 (),
+		    kind = Kind.Jump,
+		    label = collect,
+		    profileInfo = profileInfo,
+		    statements = Vector.new0 (),
+		    transfer =
+		    Transfer.CCall
+		    {args = Vector.new5 (Operand.GCState,
+					 Operand.word 0w0,
+					 Operand.bool false,
+					 Operand.File,
+					 Operand.Line),
+		     func = func,
+		     return = SOME collectReturn}})
+	       :: (Block.T
+		   {args = Vector.new0 (),
+		    kind = Kind.CReturn {func = func},
+		    label = collectReturn,
+		    profileInfo = profileInfo,
+		    statements = Vector.new0 (),
+		    transfer =
+		    Transfer.Goto {dst = dontCollect,
+				   args = Vector.new0 ()}})
+	       :: Block.T {args = Vector.new0 (),
+			   kind = Kind.Jump,
+			   label = dontCollect,
+			   profileInfo = profileInfo,
+			   statements = statements,
+			   transfer = transfer}
+	       :: !extra
+	 in
+	    ()
+	 end
+      (* Create extra blocks with signal checks for all blocks that are
+       * loop headers.
+       *)
+      fun loop (Forest.T {loops, ...}) =
+	 Vector.foreach
+	 (loops, fn {headers, child} =>
+	  let
+	     val _ = Vector.foreach (headers, fn n =>
+				     addSignalCheck (nodeIndex n))
+	     val _ = loop child
+	  in
+	     ()
+	  end)
+      (* Add a signal check at the function entry. *)
+      val _ =
+	 case Vector.peeki (blocks, fn (_, Block.T {label, ...}) =>
+			    Label.equals (label, start)) of
+	    NONE => Error.bug "missing start block"
+	  | SOME (i, _) => addSignalCheck i
+      val forest =
+	 loop
+	 (Graph.loopForestSteensgaard (g, {root = labelNode start}))
+      val blocks =
+	 Vector.keepAllMap
+	 (blocks, fn b as Block.T {label, ...} =>
+	  if Array.sub (isHeader, labelIndex label)
+	     then NONE
+	  else SOME b)
+      val blocks = Vector.concat [blocks, Vector.fromList (!extra)]
+      val f = Function.new {args = args,
+			    blocks = blocks,
+			    name = name,
+			    raises = raises,
+			    returns = returns,
+			    start = start}
+      val _ = Function.clear f
+   in
+      f
+   end
 
 fun insert p =
    if not (Program.handlesSignals p)
       then p
    else
       let
-	 val Program.T {functions, main, objectTypes, profileAllocLabels} = p
-	 fun insert (f: Function.t): Function.t =
-	    let
-	       val {args, blocks, name, raises, returns, sourceInfo, start} =
-		  Function.dest f
-	       val {get = labelIndex: Label.t -> int, set = setLabelIndex,
-		    rem = remLabelIndex, ...} =
-		  Property.getSetOnce
-		  (Label.plist, Property.initRaise ("index", Label.layout))
-	       val _ =
-		  Vector.foreachi (blocks, fn (i, Block.T {label, ...}) =>
-				   setLabelIndex (label, i))
-	       val g = Graph.new ()
-	       val n = Vector.length blocks
-	       val {get = nodeIndex: Node.t -> int, set = setNodeIndex, ...} =
-		  Property.getSetOnce
-		  (Node.plist, Property.initRaise ("index", Node.layout))
-	       val nodes =
-		  Vector.tabulate (n, fn i =>
-				   let
-				      val n = Graph.newNode g
-				      val _ = setNodeIndex (n, i)
-				   in
-				      n
-				   end)
-	       val isHeader = Array.new (n, false)
-	       fun indexNode i = Vector.sub (nodes, i)
-	       val labelNode = indexNode o labelIndex
-	       val _ =
-		  Vector.foreachi
-		  (blocks, fn (i, Block.T {label, transfer, ...}) =>
-		   let
-		      val from = indexNode i
-		   in
-		      if (case transfer of
-			     Transfer.CCall {func, ...} =>
-				CFunction.maySwitchThreads func
-			   | _ => false)
-			 then ()
-		      else
-			 Transfer.foreachLabel
-			 (transfer, fn to =>
-			  (Graph.addEdge (g, {from = from,
-					      to = labelNode to})
-			   ; ()))
-		   end)
-	       val extra: Block.t list ref = ref []
-	       (* Create extra blocks with signal checks for all blocks that are
-		* loop headers.
-		*)
-	       fun loop (Forest.T {loops, ...}) =
-		  Vector.foreach
-		  (loops, fn {headers, child} =>
-		   let
-		      val _ =
-			 Vector.foreach
-			 (headers, fn n =>
-			  let
-			     val i = nodeIndex n
-			     val _ = Array.update (isHeader, i, true)
-			     val Block.T {args, kind, label, profileInfo,
-					  statements, transfer} =
-				Vector.sub (blocks, i)
-			     val failure = Label.newNoname ()
-			     val success = Label.newNoname ()
-			     val collect = Label.newNoname ()
-			     val collectReturn = Label.newNoname ()
-			     val dontCollect = Label.newNoname ()
-			     val res = Var.newNoname ()
-			     val compare =
-				Vector.new1
-				(Statement.PrimApp
-				 {args = Vector.new2 (Operand.Cast
-						      (Operand.Runtime
-						       Runtime.GCField.Limit,
-						       Type.Word),
-						      Operand.word 0w0),
-				  dst = SOME (res, Type.bool),
-				  prim = Prim.eq})
-			     val compareTransfer =
-				Transfer.ifBool
-				(Operand.Var {var = res, ty = Type.bool},
-				 {falsee = dontCollect,
-				  truee = collect})
-			     val func = CFunction.gc {maySwitchThreads = true}
-			     val _ =
-				extra :=
- 				Block.T {args = args,
- 					 kind = kind,
-					 label = label,
- 					 profileInfo = profileInfo,
- 					 statements = compare,
- 					 transfer = compareTransfer}
-				:: (Block.T
-				    {args = Vector.new0 (),
-				     kind = Kind.Jump,
-				     label = collect,
-				     profileInfo = profileInfo,
-				     statements = Vector.new0 (),
-				     transfer =
-				     Transfer.CCall
-				     {args = Vector.new5 (Operand.GCState,
-							  Operand.word 0w0,
-							  Operand.bool false,
-							  Operand.File,
-							  Operand.Line),
-				      func = func,
-				      return = SOME collectReturn}})
-				:: (Block.T
-				    {args = Vector.new0 (),
-				     kind = Kind.CReturn {func = func},
-				     label = collectReturn,
-				     profileInfo = profileInfo,
-				     statements = Vector.new0 (),
-				     transfer =
-				     Transfer.Goto {dst = dontCollect,
-						    args = Vector.new0 ()}})
-				:: Block.T {args = Vector.new0 (),
-					    kind = Kind.Jump,
-					    label = dontCollect,
-					    profileInfo = profileInfo,
-					    statements = statements,
-					    transfer = transfer}
-				:: !extra
-			  in
-			     ()
-			  end)
-		      val _ = loop child
-		   in
-		      ()
-		   end)
-	       val forest =
-		  loop
-		  (Graph.loopForestSteensgaard (g, {root = labelNode start}))
-	       val blocks =
-		  Vector.keepAllMap
-		  (blocks, fn b as Block.T {label, ...} =>
-		   if Array.sub (isHeader, labelIndex label)
-		      then NONE
-		   else SOME b)
-	       val blocks = Vector.concat [blocks, Vector.fromList (!extra)]
-	       val f = Function.new {args = args,
-				     blocks = blocks,
-				     name = name,
-				     raises = raises,
-				     returns = returns,
-				     sourceInfo = sourceInfo,
-				     start = start}
-	       val _ = Function.clear f
-	    in
-	       f
-	    end
+	 val Program.T {functions, main, objectTypes} = p
       in
-	 Program.T {functions = List.revMap (functions, insert),
+	 Program.T {functions = List.revMap (functions, insertInFunction),
 		    main = main,
-		    objectTypes = objectTypes,
-		    profileAllocLabels = profileAllocLabels}
+		    objectTypes = objectTypes}
       end
 
 end



1.13      +2 -2      mlton/mlton/backend/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- sources.cm	7 Dec 2002 02:21:52 -0000	1.12
+++ sources.cm	19 Dec 2002 23:43:32 -0000	1.13
@@ -45,8 +45,8 @@
 mtype.sig
 parallel-move.fun
 parallel-move.sig
-profile-alloc.fun
-profile-alloc.sig
+profile.fun
+profile.sig
 representation.fun
 representation.sig
 rssa.fun



1.30      +28 -27    mlton/mlton/backend/ssa-to-rssa.fun

Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- ssa-to-rssa.fun	12 Dec 2002 18:25:05 -0000	1.29
+++ ssa-to-rssa.fun	19 Dec 2002 23:43:32 -0000	1.30
@@ -1211,6 +1211,7 @@
 					   func = CFunction.worldSave}
 			       | _ => normal ()
 			   end
+		      | S.Exp.Profile pe => add (Statement.Profile pe)
 		      | S.Exp.Select {tuple, offset} =>
 			   let
 			      val TupleRep.T {offsets, ...} =
@@ -1261,7 +1262,7 @@
 	 let
 	    val _ =
 	       S.Function.foreachVar (f, fn (x, t) => setVarInfo (x, {ty = t}))
-	    val {args, blocks, name, raises, returns, sourceInfo, start, ...} =
+	    val {args, blocks, name, raises, returns, start, ...} =
 	       S.Function.dest f
 	    val _ =
 	       Vector.foreach
@@ -1292,7 +1293,6 @@
 			  name = name,
 			  raises = transTypes raises,
 			  returns = transTypes returns,
-			  sourceInfo = sourceInfo,
 			  start = start}
 	 end
       val main =
@@ -1301,35 +1301,36 @@
 	     val bug = Label.newNoname ()
 	  in
 	     translateFunction
-	     (S.Function.new
-	      {args = Vector.new0 (),
-	       blocks = (Vector.new2
-			 (S.Block.T
-			  {label = start,
-			   args = Vector.new0 (),
-			   statements = globals,
-			   transfer = (S.Transfer.Call
-				       {func = main,
-					args = Vector.new0 (),
-					return = (Return.NonTail
-						  {cont = bug,
-						   handler = S.Handler.None})})},
-			  S.Block.T
-			  {label = bug,
-			   args = Vector.new0 (),
-			   statements = Vector.new0 (),
-			   transfer = S.Transfer.Bug})),
-	       name = Func.newNoname (),
-	       raises = NONE,
-	       returns = NONE,
-	       sourceInfo = S.SourceInfo.main,
-	       start = start})
+	     (S.Function.profile
+	      (S.Function.new
+	       {args = Vector.new0 (),
+		blocks = (Vector.new2
+			  (S.Block.T
+			   {label = start,
+			    args = Vector.new0 (),
+			    statements = globals,
+			    transfer = (S.Transfer.Call
+					{func = main,
+					 args = Vector.new0 (),
+					 return =
+					 Return.NonTail
+					 {cont = bug,
+					  handler = S.Handler.None}})},
+			   S.Block.T
+			   {label = bug,
+			    args = Vector.new0 (),
+			    statements = Vector.new0 (),
+			    transfer = S.Transfer.Bug})),
+		name = Func.newNoname (),
+		raises = NONE,
+		returns = NONE,
+		start = start},
+	       S.SourceInfo.main))
 	  end
       val functions = List.revMap (functions, translateFunction)
       val p = Program.T {functions = functions,
 			 main = main,
-			 objectTypes = objectTypes,
-			 profileAllocLabels = Vector.new0 ()}
+			 objectTypes = objectTypes}
       val _ = Program.clear p
    in
       p



1.6       +1 -0      mlton/mlton/backend/ssa-to-rssa.sig

Index: ssa-to-rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ssa-to-rssa.sig	12 Dec 2002 01:14:22 -0000	1.5
+++ ssa-to-rssa.sig	19 Dec 2002 23:43:32 -0000	1.6
@@ -17,6 +17,7 @@
       sharing Rssa.Handler = Ssa.Handler
       sharing Rssa.Label = Ssa.Label
       sharing Rssa.Prim = Ssa.Prim
+      sharing Rssa.ProfileStatement = Ssa.ProfileExp
       sharing Rssa.Return = Ssa.Return
       sharing Rssa.SourceInfo = Ssa.SourceInfo
       sharing Rssa.Var = Ssa.Var



1.1                  mlton/mlton/backend/profile.fun

Index: profile.fun
===================================================================
functor Profile (S: PROFILE_STRUCTS): PROFILE = 
struct

open S
open Rssa
   
type sourceSeq = int list

structure Push =
   struct
      datatype t =
	 Enter of int
       | Skip of int

      fun layout z =
	 let
	    open Layout
	 in
	    case z of
	       Enter i => seq [str "Enter ", Int.layout i]
	     | Skip i => seq [str "Skip ", Int.layout i]
	 end

      fun toSources (ps: t list): int list =
	 List.fold (rev ps, [], fn (p, ac) =>
		    case p of
		       Enter i => i :: ac
		     | Skip _ => ac)
   end

fun profile program =
   if !Control.profile = Control.ProfileNone
      then {frameProfileIndices = Vector.new0 (),
	    labels = Vector.new0 (),
	    program = program,
	    sources = Vector.new0 (),
	    sourceSeqs = Vector.new0 ()}
   else
   let
      val debug = false
      val profile = !Control.profile
      val profileAlloc: bool = profile = Control.ProfileAlloc
      val profileTime: bool = profile = Control.ProfileTime
      val frameProfileIndices = ref []
      local
	 val table: {index: int,
		     info: SourceInfo.t} HashSet.t =
	    HashSet.new {hash = SourceInfo.hash o #info}
	 val c = Counter.new 0
	 val sourceInfos = ref []
      in
	 fun sourceInfoIndex (si: SourceInfo.t): int =
	    #index
	    (HashSet.lookupOrInsert
	     (table, SourceInfo.hash si,
	      fn {info = si', ...} => SourceInfo.equals (si, si'),
	      fn () => let
			  val _ = List.push (sourceInfos, si)
			  val index = Counter.next c
			  val _ =
			     if not debug
				then ()
			     else
			     let
				open Layout
			     in
				outputl (seq [Int.layout index,
					      str " ",
					      SourceInfo.layout si],
					 Out.error)
			     end
		       in
			 {index = index,
			  info = si}
		       end))
	 fun makeSources () = Vector.fromListRev (!sourceInfos)
      end
      val mainIndex = sourceInfoIndex SourceInfo.main
      val unknownIndex = sourceInfoIndex SourceInfo.unknown
      local
	 val table: {hash: word,
		     index: int,
		     sourceSeq: int vector} HashSet.t =
	    HashSet.new {hash = #hash}
	 val c = Counter.new 0
	 val sourceSeqs: int vector list ref = ref []
      in
	 fun sourceSeqIndex (s: sourceSeq): int =
	    let
	       val s = Vector.fromList s
	       val hash =
		  Vector.fold (s, 0w0, fn (i, w) =>
			       w * 0w31 + Word.fromInt i)
	    in
	       #index
	       (HashSet.lookupOrInsert
		(table, hash,
		 fn {sourceSeq = s', ...} => s = s',
		 fn () => let
			     val _ = List.push (sourceSeqs, s)
			  in
			     {hash = hash,
			      index = Counter.next c,
			      sourceSeq = s}
			  end))
	    end
	 fun makeSourceSeqs () = Vector.fromListRev (!sourceSeqs)
      end
      (* Ensure that SourceInfo unknown is index 0. *)
      val unknownSourceSeq = sourceSeqIndex [sourceInfoIndex SourceInfo.unknown]
      (* Treat the empty source sequence as unknown. *)
      val sourceSeqIndex =
	 fn [] => unknownSourceSeq
	  | s => sourceSeqIndex s
      val {get = labelInfo: Label.t -> {block: Block.t,
					visited: bool ref},
	   set = setLabelInfo, ...} =
	 Property.getSetOnce
	 (Label.plist, Property.initRaise ("info", Label.layout))
      val labels = ref []
      fun profileLabel (sourceSeq: int list): Statement.t =
	 let
	    val index = sourceSeqIndex sourceSeq
	    val l = ProfileLabel.new ()
	    val _ = List.push (labels, {label = l,
					sourceSeqsIndex = index})
	 in
	    Statement.ProfileLabel l
	 end
      fun shouldPush (si: SourceInfo.t, ps: Push.t list): bool =
	 case List.peekMap (ps, fn Push.Enter i => SOME i | _ => NONE) of
	    NONE => true
	  | SOME i =>
	       not (SourceInfo.isBasis si)
	       orelse i = mainIndex
	       orelse i = unknownIndex
      fun doFunction (f: Function.t): Function.t =
	 let
	    val {args, blocks, name, raises, returns, start} = Function.dest f
	    val _ =
	       Vector.foreach
	       (blocks, fn block as Block.T {label, ...} =>
		setLabelInfo (label, {block = block,
				      visited = ref false}))
	    val blocks = ref []
	    datatype z = datatype Statement.t
	    datatype z = datatype ProfileStatement.t
	    fun backward {args,
			  kind,
			  label,
			  needsProfileAllocIndex,
			  profileInfo,
			  sourceSeq,
			  statements: Statement.t list,
			  transfer: Transfer.t}: unit =
	       let
		  val (_, npl, sourceSeq, statements) =
		     List.fold
		     (statements,
		      (needsProfileAllocIndex, true, sourceSeq, []),
		      fn (s, (npai, npl, sourceSeq, ss)) =>
		      case s of
			 Object _ => (true, true, sourceSeq, s :: ss)
		       | Profile ps =>
			    let
			       val ss =
				  if profileTime andalso npl
				     then profileLabel sourceSeq :: ss
				  else ss
			       val sourceSeq' = 
				  case ps of
				     Enter si =>
					(case sourceSeq of
					    [] => Error.bug "unmatched Enter"
					  | si' :: sis =>
					       if si' = sourceInfoIndex si
						  then sis
					       else Error.bug "mismatched Enter")
				   | Leave si => sourceInfoIndex si :: sourceSeq
			       val ss =
				  if profileAlloc andalso needsProfileAllocIndex
				     then
					Statement.Move
					{dst = (Operand.Runtime
						Runtime.GCField.ProfileAllocIndex),
					 src = (Operand.word
						(Word.fromInt
						 (sourceSeqIndex sourceSeq)))}
					:: ss
				  else ss
			    in
			       (false, false, sourceSeq', ss)
			    end
		       | _ => (npai, true, sourceSeq, s :: ss))
		  val statements =
		     if profileTime andalso npl
			then profileLabel sourceSeq :: statements
		     else statements
	       in		       
		  List.push (blocks,
			     Block.T {args = args,
				      kind = kind,
				      label = label,
				      profileInfo = profileInfo,
				      statements = Vector.fromList statements,
				      transfer = transfer})
	       end
	    val backward =
	       Trace.trace
	       ("Profile.backward",
		fn {statements, sourceSeq, ...} =>
		Layout.tuple [List.layout Int.layout sourceSeq,
			      List.layout Statement.layout statements],
		Unit.layout)
	       backward
	    fun goto (l: Label.t, sourceSeq: Push.t list): unit =
	       let
		  val _ =
		     if not debug
			then ()
		     else
		     let
			open Layout
		     in
			outputl (seq [str "goto (",
				      Label.layout l,
				      str ", ",
				      List.layout Push.layout sourceSeq,
				      str ")"],
				 Out.error)
		     end
		  val {block, visited, ...} = labelInfo l
	       in
		  if !visited
		     then ()
		  else
		     let
			val _ = visited := true
			val Block.T {args, kind, label, profileInfo, statements,
				     transfer, ...} = block
			val _ =
			   if Kind.isFrame kind
			      then List.push (frameProfileIndices,
					      (label,
					       sourceSeqIndex
					       (Push.toSources sourceSeq)))
			   else ()
			fun maybeSplit {args, bytesAllocated, kind, label,
					sourceSeq: Push.t list,
					statements} =
			   if profileAlloc andalso bytesAllocated > 0
			      then
				 let
				    val newLabel = Label.newNoname ()
				    val func = CFunction.profileAllocInc
				    val transfer =
				       Transfer.CCall
				       {args = (Vector.new1
						(Operand.word
						 (Word.fromInt bytesAllocated))),
					func = func,
					return = SOME newLabel}
				    val sourceSeq = Push.toSources sourceSeq
				    val _ =
				       backward {args = args,
						 kind = kind,
						 label = label,
						 needsProfileAllocIndex = true,
						 profileInfo = profileInfo,
						 sourceSeq = sourceSeq,
						 statements = statements,
						 transfer = transfer}
				 in
				    {args = Vector.new0 (),
				     bytesAllocated = 0,
				     kind = Kind.CReturn {func = func},
				     label = newLabel,
				     statements = []}
				 end
			   else {args = args,
				 bytesAllocated = 0,
				 kind = kind,
				 label = label,
				 statements = statements}
			val {args, bytesAllocated, kind, label, sourceSeq,
			     statements} =
			   Vector.fold
			   (statements,
			    {args = args,
			     bytesAllocated = 0,
			     kind = kind,
			     label = label,
			     sourceSeq = sourceSeq,
			     statements = []},
			    fn (s, {args, bytesAllocated, kind, label,
				    sourceSeq: Push.t list,
				    statements}) =>
			    (if not debug
				then ()
			     else
				let
				   open Layout
				in
				   outputl
				   (seq [List.layout Push.layout sourceSeq,
					 str " ",
					 Statement.layout s],
				    Out.error)
				end
			     ;
			    case s of
			       Object {size, ...} =>
				  {args = args,
				   bytesAllocated = bytesAllocated + size,
				   kind = kind,
				   label = label,
				   sourceSeq = sourceSeq,
				   statements = s :: statements}
			     | Profile ps =>
				  let
				     datatype z = datatype ProfileStatement.t
				     val {args, bytesAllocated, kind, label,
					  statements} =
					maybeSplit
					{args = args,
					 bytesAllocated = bytesAllocated,
					 kind = kind,
					 label = label,
					 sourceSeq = sourceSeq,
					 statements = statements}
				     val (keep, sourceSeq) =
					case ps of
					   Enter si =>
					      let
						 val i = sourceInfoIndex si
					      in
						 if shouldPush (si, sourceSeq)
						    then (true,
							  Push.Enter i
							  :: sourceSeq)
						 else (false,
						       Push.Skip i :: sourceSeq)
					      end
					 | Leave si =>
					      (case sourceSeq of
						  [] =>
						     Error.bug "unmatched Leave"
						| p :: sourceSeq' =>
						     let
							val (keep, i) =
							   case p of
							      Push.Enter i =>
								 (true, i)
							    | Push.Skip i =>
								 (false, i)
						     in
							if i = sourceInfoIndex si
							   then (keep, sourceSeq')
							else Error.bug "mismatched Leave"
						     end)
				     val statements =
					if keep
					   then s :: statements
					else statements
				  in
				     {args = args,
				      bytesAllocated = bytesAllocated,
				      kind = kind,
				      label = label,
				      sourceSeq = sourceSeq,
				      statements = statements}
				  end
			     | _ =>
				  {args = args,
				   bytesAllocated = bytesAllocated,
				   kind = kind,
				   label = label,
				   sourceSeq = sourceSeq,
				   statements = s :: statements})
			    )
			val _ =
			   Transfer.foreachLabel
			   (transfer, fn l => goto (l, sourceSeq))
			val npai =
			   case transfer of
			      Transfer.CCall {func, ...} =>
				 CFunction.needsProfileAllocIndex func
			    | _ => false
			val {args, kind, label, statements, ...} =
			   maybeSplit {args = args,
				       bytesAllocated = bytesAllocated,
				       kind = kind,
				       label = label,
				       sourceSeq = sourceSeq,
				       statements = statements}
		     in
			backward {args = args,
				  kind = kind,
				  label = label,
				  needsProfileAllocIndex = npai,
				  profileInfo = profileInfo,
				  sourceSeq = Push.toSources sourceSeq,
				  statements = statements,
				  transfer = transfer}
		     end
	       end
	    val _ = goto (start, [])
	    val blocks = Vector.fromList (!blocks)
	 in
	    Function.new {args = args,
			  blocks = blocks,
			  name = name,
			  raises = raises,
			  returns = returns,
			  start = start}
	 end
      val Program.T {functions, main, objectTypes} = program
      val program = Program.T {functions = List.revMap (functions, doFunction),
			       main = doFunction main,
			       objectTypes = objectTypes}
   in
      {frameProfileIndices = Vector.fromList (!frameProfileIndices),
       labels = Vector.fromList (!labels),
       program = program,
       sources = makeSources (),
       sourceSeqs = makeSourceSeqs ()}
   end

end



1.1                  mlton/mlton/backend/profile.sig

Index: profile.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature PROFILE_STRUCTS = 
   sig
      structure Rssa: RSSA
   end

signature PROFILE = 
   sig
      include PROFILE_STRUCTS
      
      val profile:
	 Rssa.Program.t -> {frameProfileIndices: (Rssa.Label.t * int) vector,
			    labels: {label: Rssa.ProfileLabel.t,
				     sourceSeqsIndex: int} vector,
			    program: Rssa.Program.t,
			    sources: Rssa.SourceInfo.t vector,
			    sourceSeqs: int vector vector}
   end



1.21      +11 -10    mlton/mlton/closure-convert/closure-convert.fun

Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- closure-convert.fun	12 Dec 2002 01:14:22 -0000	1.20
+++ closure-convert.fun	19 Dec 2002 23:43:33 -0000	1.21
@@ -111,7 +111,6 @@
 				name = Func.newNoname (),
 				raises = NONE,
 				returns = NONE, (* bogus *)
-				sourceInfo = SourceInfo.bogus,
 				start = start}))
 	  in
 	     if 1 <> Vector.length blocks
@@ -686,16 +685,18 @@
 	 let
 	    val (start, blocks) =
 	       Dexp.linearize (body, Ssa.Handler.CallerHandler)
+	    val f =
+	       Function.profile 
+	       (shrinkFunction
+		(Function.new {args = args,
+			       blocks = Vector.fromList blocks,
+			       name = name,
+			       raises = raises,
+			       returns = SOME returns,
+			       start = start}),
+		sourceInfo)
 	 in
-	    Accum.addFunc (ac,
-			   shrinkFunction
-			   (Function.new {args = args,
-					  blocks = Vector.fromList blocks,
-					  name = name,
-					  raises = raises,
-					  returns = SOME returns,
-					  sourceInfo = sourceInfo,
-					  start = start}))
+	    Accum.addFunc (ac, f)
 	 end
       (* Closure convert an expression, returning:
        *   - the target ssa expression



1.39      +138 -92   mlton/mlton/codegen/c-codegen/c-codegen.fun

Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- c-codegen.fun	12 Dec 2002 01:14:22 -0000	1.38
+++ c-codegen.fun	19 Dec 2002 23:43:33 -0000	1.39
@@ -23,8 +23,12 @@
    structure ObjectType = ObjectType
    structure Operand = Operand
    structure Prim = Prim
+   structure ProfileInfo = ProfileInfo
+   structure ProfileLabel = ProfileLabel
+   structure Program = Program
    structure Register = Register
    structure Runtime = Runtime
+   structure SourceInfo = SourceInfo
    structure Statement = Statement
    structure Switch = Switch
    structure Transfer = Transfer
@@ -132,11 +136,12 @@
 fun outputDeclarations
    {additionalMainArgs: string list,
     includes: string list,
-    maxFrameIndex: int,
     name: string,
     print: string -> unit,
-    program = (Machine.Program.T
-	       {chunks, frameOffsets, intInfs, maxFrameSize, objectTypes,
+    program = (Program.T
+	       {chunks, frameLayouts, frameOffsets, intInfs, maxFrameSize,
+		objectTypes,
+		profileInfo,
 		reals, strings, ...}),
     rest: unit -> unit
     }: unit =
@@ -190,26 +195,40 @@
 	   ; print (C.int (Vector.length v))
 	   ; Vector.foreach (v, fn i => (print ","; print (C.int i)))
 	   ; print "};\n"))
-      fun declareObjectTypes () =
-	 (print (concat ["static GC_ObjectType objectTypes[] = {\n"])
-	  ; (Vector.foreach
-	     (objectTypes, fn ty =>
-	      let
-		 datatype z = datatype Runtime.ObjectType.t
-		 val (tag, nonPointers, pointers) =
-		    case ObjectType.toRuntime ty of
-		       Array {numBytesNonPointers, numPointers} =>
-			  (0, numBytesNonPointers, numPointers)
-		     | Normal {numPointers, numWordsNonPointers} =>
-			  (1, numWordsNonPointers, numPointers)
-		     | Stack =>
-			  (2, 0, 0)
-	      in
-		 print (concat ["\t{ ", Int.toString tag, ", ",
-				Int.toString nonPointers, ", ",
-				Int.toString pointers, " },\n"])
-	      end))
+      fun declareArray (ty: string,
+			name: string,
+			v: 'a vector,
+			toString: int * 'a -> string) =
+	 (print (concat ["static ", ty, " ", name, "[] = {\n"])
+	  ; Vector.foreachi (v, fn (i, x) =>
+			     print (concat ["\t", toString (i, x), ",\n"]))
 	  ; print "};\n")
+      fun declareFrameLayouts () =
+	 declareArray ("GC_frameLayout", "frameLayouts", frameLayouts,
+		       fn (_, {frameOffsetsIndex, size}) =>
+		       concat ["{",
+			       C.int size,
+			       ", frameOffsets", C.int frameOffsetsIndex,
+			       "}"])
+      fun declareObjectTypes () =
+	 declareArray
+	 ("GC_ObjectType", "objectTypes", objectTypes,
+	  fn (_, ty) =>
+	  let
+	     datatype z = datatype Runtime.ObjectType.t
+	     val (tag, nonPointers, pointers) =
+		case ObjectType.toRuntime ty of
+		   Array {numBytesNonPointers, numPointers} =>
+		      (0, numBytesNonPointers, numPointers)
+		 | Normal {numPointers, numWordsNonPointers} =>
+		      (1, numWordsNonPointers, numPointers)
+		 | Stack =>
+		      (2, 0, 0)
+	  in
+	     concat ["{ ", Int.toString tag, ", ",
+		     Int.toString nonPointers, ", ",
+		     Int.toString pointers, " }"]
+	  end)
       fun declareMain () =
 	 let
 	    val magic = C.word (Random.useed ())
@@ -218,12 +237,42 @@
 			  [C.int (!Control.cardSizeLog2),
 			   C.bool (!Control.markCards),
 			   C.int maxFrameSize,
-			   C.int maxFrameIndex,
-			   C.int (Vector.length objectTypes),
-			   magic] @ additionalMainArgs,
+			   magic,
+			   C.bool (!Control.profile = Control.ProfileAlloc)]
+			  @ additionalMainArgs,
 			  print)
 	    ; print "\n"
 	 end
+      fun declareProfileInfo () =
+	 let
+	    val ProfileInfo.T {frameSources, labels, sourceSeqs,
+			       sources} =
+	       profileInfo
+	 in
+	    Vector.foreach (labels, fn {label, ...} =>
+			    print (concat ["void ",
+					   ProfileLabel.toString label,
+					   "();\n"]))
+	    ; declareArray ("struct GC_profileLabel", "profileLabels", labels,
+			    fn (_, {label, sourceSeqsIndex}) =>
+			    concat ["{(pointer)", ProfileLabel.toString label,
+				    ", ", C.int sourceSeqsIndex, "}"])
+	    ; declareArray ("string", "profileSources", sources,
+			    C.string o SourceInfo.toString o #2)
+	    ; Vector.foreachi (sourceSeqs, fn (i, v) =>
+			       (print (concat ["static int sourceSeq",
+					       Int.toString i,
+					       "[] = {"])
+				; print (C.int (Vector.length v))
+				; Vector.foreach (v, fn i =>
+						  (print (concat [",", C.int i])))
+				; print "};\n"))
+				      
+	    ; declareArray ("int", "*profileSourceSeqs", sourceSeqs, fn (i, _) =>
+			    concat ["sourceSeq", Int.toString i])
+	    ; declareArray ("int", "profileFrameSources", frameSources,
+			    C.int o #2)
+	 end
    in
       print (concat ["#define ", name, "CODEGEN\n\n"])
       ; outputIncludes ()
@@ -232,12 +281,15 @@
       ; declareStrings ()
       ; declareReals ()
       ; declareFrameOffsets ()
+      ; declareFrameLayouts ()
       ; declareObjectTypes ()
+      ; declareProfileInfo ()
       ; rest ()
       ; declareMain ()
    end
 
 fun output {program as Machine.Program.T {chunks,
+					  frameLayouts,
 					  main = {chunkLabel, label}, ...},
             includes,
 	    outputC: unit -> {file: File.t,
@@ -253,28 +305,38 @@
 	   set = setLabelInfo, ...} =
 	 Property.getSetOnce
 	 (Label.plist, Property.initRaise ("CCodeGen.info", Label.layout))
-      val entryLabels = ref []
-      (* Assign the entries of each chunk consecutive integers so that
-       * gcc will use a jump table.
-       *)
-      val indexCounter = Counter.new 0
+      val entryLabels: (Label.t * int) list ref = ref []
+      val indexCounter = Counter.new (Vector.length frameLayouts)
       val _ =
 	 List.foreach
 	 (chunks, fn Chunk.T {blocks, chunkLabel, ...} =>
 	  Vector.foreach
 	  (blocks, fn b as Block.T {kind, label, ...} =>
-	   (setLabelInfo
-	    (label,
-	     {block = b,
-	      chunkLabel = chunkLabel,
-	      frameIndex = if Kind.isEntry kind
-			      then (List.push (entryLabels, label)
-				    ; SOME (Counter.next indexCounter))
-			   else NONE,
-              layedOut = ref false,
-	      status = ref None}))))
-      val entryLabels = Vector.fromListRev (!entryLabels)
-      val maxFrameIndex = Counter.value indexCounter
+	   let
+	      fun entry (index: int) =
+		 List.push (entryLabels, (label, index))
+	      val frameIndex = 
+		 case Kind.frameInfoOpt kind of
+		    NONE => (if Kind.isEntry kind
+				then entry (Counter.next indexCounter)
+			     else ()
+		             ; NONE)
+		  | SOME (FrameInfo.T {frameLayoutsIndex, ...}) =>
+		       (entry frameLayoutsIndex
+			; SOME frameLayoutsIndex)
+	   in
+	      setLabelInfo (label, {block = b,
+				    chunkLabel = chunkLabel,
+				    frameIndex = frameIndex,
+				    layedOut = ref false,
+				    status = ref None})
+	   end))
+      val entryLabels =
+	 Vector.map
+	 (Vector.fromArray
+	  (QuickSort.sortArray
+	   (Array.fromList (!entryLabels), fn ((_, i), (_, i')) => i <= i')),
+	  #1)
       val labelChunk = #chunkLabel o labelInfo
       fun labelFrameInfo (l: Label.t): FrameInfo.t option =
 	 let
@@ -287,52 +349,32 @@
 	 List.foreach (chunks, fn Chunk.T {chunkLabel, ...} =>
 		       C.call ("DeclareChunk",
 			       [ChunkLabel.toString chunkLabel],
-			       print));
-      fun make (name, pr) =
-	 (print (concat ["static ", name, " = {"])
-	  ; Vector.foreachi (entryLabels, fn (i, x) =>
-			     (if i > 0 then print ",\n\t" else ()
-				 ; pr x))
-	  ; print "};\n")
-      fun declareFrameLayouts () =
-	 make ("GC_frameLayout frameLayouts []", fn l =>
-	       let
-		  val (size, offsetIndex) =
-		     case labelFrameInfo l of
-			NONE => ("0", "NULL")
-		      | SOME (FrameInfo.T {size, frameOffsetsIndex, ...}) =>
-			   (C.int size, "frameOffsets" ^ C.int frameOffsetsIndex)
-	       in 
-		  print (concat ["{", size, ",", offsetIndex, "}"])
-	       end)
+			       print))
       fun declareNextChunks () =
-	 make ("struct cont ( *nextChunks []) ()", fn l =>
-	       let
-		  val {chunkLabel, frameIndex, ...} = labelInfo l
-	       in
-		  case frameIndex of
-		     NONE => print "NULL"
-		   | SOME _ =>
-			C.callNoSemi ("Chunkp",
-				      [ChunkLabel.toString chunkLabel],
-				      print)
-	       end)
+	 (print "static struct cont ( *nextChunks []) () = {"
+	  ; Vector.foreach (entryLabels, fn l =>
+			    let
+			       val {chunkLabel, ...} = labelInfo l
+			    in
+			       print "\t"
+			       ; C.callNoSemi ("Chunkp",
+					       [ChunkLabel.toString chunkLabel],
+					       print)
+			       ; print ",\n"
+			    end)
+	  ; print "};\n")
       fun declareIndices () =
-	 Vector.foreach
-	 (entryLabels, fn l =>
-	  Option.app
-	  (#frameIndex (labelInfo l), fn i =>
-	   (print "#define "
-	    ; print (Label.toStringIndex l)
-	    ; print " "
-	    ; print (C.int i)
-	    ; print "\n")))
+	 Vector.foreachi
+	 (entryLabels, fn (i, l) =>
+	  (print (concat ["#define ", Label.toStringIndex l, " ",
+			  C.int i, "\n"])))
       local
 	 datatype z = datatype Operand.t
-      	 val rec toString =
-	    fn ArrayOffset {base, index, ty} =>
-	    concat ["X", Type.name ty,
-		    C.args [toString base, toString index]]
+      	 fun toString (z: Operand.t): string =
+	    case z of
+	       ArrayOffset {base, index, ty} =>
+		  concat ["X", Type.name ty,
+			  C.args [toString base, toString index]]
 	     | Cast (z, ty) =>
 		  concat ["(", Runtime.Type.toString (Type.toRuntime ty), ")",
 			  toString z]
@@ -351,7 +393,8 @@
 	     | Label l => Label.toStringIndex l
 	     | Line => "__LINE__"
 	     | Offset {base, offset, ty} =>
-		  concat ["O", Type.name ty, C.args [toString base, C.int offset]]
+		  concat ["O", Type.name ty,
+			  C.args [toString base, C.int offset]]
 	     | Real s => C.real s
 	     | Register r =>
 		  concat ["R", Type.name (Register.ty r),
@@ -433,6 +476,8 @@
 			    in 
 			       ()
 			    end
+		       | ProfileLabel _ =>
+			    Error.bug "C codegen can't do profiling"
 		       | SetExnStackLocal {offset} =>
 			    C.call ("SetExnStackLocal", [C.int offset], print)
 		       | SetExnStackSlot {offset} =>
@@ -444,7 +489,7 @@
       fun outputChunk (chunk as Chunk.T {chunkLabel, blocks, regMax, ...}) =
 	 let
 	    fun labelFrameSize (l: Label.t): int =
-	       FrameInfo.size (valOf (labelFrameInfo l))
+	       Program.frameSize (program, valOf (labelFrameInfo l))
 	    (* Count how many times each label is jumped to. *)
 	    fun jump l =
 	       let
@@ -557,7 +602,8 @@
 			      ; print ":\n"
 			   end 
 		      | _ => ()
-		  fun pop (FrameInfo.T {size, ...}) = C.push (~ size, print)
+		  fun pop (fi: FrameInfo.t) =
+		     C.push (~ (Program.frameSize (program, fi)), print)
 		  val _ =
 		     case kind of
 			Kind.Cont {frameInfo, ...} => pop frameInfo
@@ -671,8 +717,9 @@
 			      if mayGC
 				 then
 				    let
-				       val FrameInfo.T {size, ...} =
-					  valOf frameInfo
+				       val size =
+					  Program.frameSize (program,
+							     valOf frameInfo)
 				       val res = copyArgs args
 				       val _ = push (valOf return, size)
 				    in
@@ -819,7 +866,8 @@
 	    C.callNoSemi ("Chunk", [ChunkLabel.toString chunkLabel], print)
 	    ; print "\n"
 	    ; declareRegisters ()
-	    ; print "ChunkSwitch\n"
+	    ; C.callNoSemi ("ChunkSwitch", [ChunkLabel.toString chunkLabel],
+			    print)
 	    ; Vector.foreach (blocks, fn Block.T {kind, label, ...} =>
 			      if Kind.isEntry kind
 				 then (print "case "
@@ -835,13 +883,11 @@
       fun rest () =
 	 (declareChunks ()
 	  ; declareNextChunks ()
-	  ; declareFrameLayouts ()
 	  ; declareIndices ()
 	  ; List.foreach (chunks, outputChunk))
    in
       outputDeclarations {additionalMainArgs = additionalMainArgs,
 			  includes = includes,
-			  maxFrameIndex = maxFrameIndex,
 			  name = "C",
 			  program = program,
 			  print = print,



1.5       +0 -1      mlton/mlton/codegen/c-codegen/c-codegen.sig

Index: c-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-codegen.sig	6 Jul 2002 17:22:06 -0000	1.4
+++ c-codegen.sig	19 Dec 2002 23:43:33 -0000	1.5
@@ -25,7 +25,6 @@
 		   } -> unit
       val outputDeclarations: {additionalMainArgs: string list,
 			       includes: string list,
-			       maxFrameIndex: int,
 			       name: string,
 			       print: string -> unit,
 			       program: Machine.Program.t,



1.34      +11 -173   mlton/mlton/codegen/x86-codegen/x86-codegen.fun

Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- x86-codegen.fun	12 Dec 2002 01:14:22 -0000	1.33
+++ x86-codegen.fun	19 Dec 2002 23:43:34 -0000	1.34
@@ -79,13 +79,13 @@
   open x86
   structure Type = Machine.Type
   fun output {program as Machine.Program.T {chunks,
+					    frameLayouts,
 					    frameOffsets,
-					    funcSources,
 					    handlesSignals,
 					    intInfs,
 					    main,
 					    maxFrameSize,
-					    profileAllocLabels,
+					    profileInfo,
 					    strings,
 					    ...},
               includes: string list,
@@ -103,127 +103,9 @@
 	     | Control.FreeBSD => false
 	     | Control.Linux => false
 
-	 val numProfileAllocLabels =
-	    (* Add 1 for PROFILE_ALLOC_MISC *)
-	    1 + Vector.length profileAllocLabels
-	 val declareProfileAllocLabels =
-	    if !Control.profile <> Control.ProfileAlloc
-	       then fn _ => ()
-	    else
-		let  
-		   val profileLabels =
-		      Array.tabulate (numProfileAllocLabels, fn _ => NONE)
-		   val labelSet: {done: bool ref,
-				  hash: word,
-				  index: int,
-				  name: string} HashSet.t =
-		      HashSet.new {hash = #hash}
-		   val _ = 
-		      Vector.foreachi (profileAllocLabels, fn (i, name) =>
-				       let
-					  val hash = String.hash name
-				       in
-					  HashSet.lookupOrInsert
-					  (labelSet, hash, fn _ => false,
-					   fn () => {done = ref false,
-						     hash = hash,
-						     index = i + 1,
-						     name = name})
-					  ; ()
-				       end)
-		   fun addProfileLabel (name: string, label: Label.t) =
-		      case HashSet.peek (labelSet, String.hash name,
-					 fn {name = n, ...} => n = name) of
-			 NONE => ()
-		       | SOME {done, index, ...} =>
-			    if !done
-			       then ()
-			    else (done := true
-				  ; Array.update (profileLabels, index,
-						  SOME label))
-		   val _ = x86.setAddProfileLabel addProfileLabel
-		   fun declareLabels print =
-		      let
-			 val _ = print ".data\n\
-	                               \.p2align 4\n\
-				       \.global profileAllocLabels\n\
-				       \profileAllocLabels:\n"
-			 val _ =
-			    Array.foreach
-			    (profileLabels, fn l =>
-			     (print
-			      (concat
-			       [".long ",
- 				case l of
-	 			   NONE => "0"
-		 		 | SOME l => Label.toString l,
-			       "\n"])))
-		      in
-			 ()
-		      end
-		in
-		   declareLabels
-		end
-
 	val makeC = outputC
 	val makeS = outputS
 
-	val {get = getFrameLayoutIndex 
-	         : Label.t -> {size: int, 
-			       frameLayoutsIndex: int} option,
-	     set = setFrameLayoutIndex, ...}
-	  = Property.getSetOnce(Label.plist,
-				Property.initConst NONE)
-
-	local
-	  val hash' = fn {size, offsetIndex} => Word.fromInt (offsetIndex)
-	  val hash = fn {size, offsetIndex, frameLayoutsIndex}
-	              => hash' {size = size, offsetIndex = offsetIndex}
-
-	  val table = HashSet.new {hash = hash}
-	  val frameLayoutsData = ref []
-	  val maxFrameLayoutIndex' = ref 0
-	  val _ =
-	     List.foreach
-	     (chunks, fn Machine.Chunk.T {blocks, ...} =>
-	      Vector.foreach
-	      (blocks, fn Machine.Block.T {kind, label, ...} =>
-	       Option.app
-	       (Machine.Kind.frameInfoOpt kind,
-		fn (Machine.FrameInfo.T {frameOffsetsIndex = offsetIndex,
-					 func, size}) =>
-		let
-		   val info = {size = size, offsetIndex = offsetIndex}
-		   val {frameLayoutsIndex, ...} =
-		      HashSet.lookupOrInsert
-		      (table, hash' info,
-		       fn {size = size', offsetIndex = offsetIndex', ...} => 
-		       size = size' andalso offsetIndex = offsetIndex',
-		       fn () => 
-		       let
-			  val _ =
-			     List.push
-			     (frameLayoutsData,
-			      {func = func,
-			       offsetIndex = offsetIndex,
-			       size = size})
-			  val frameLayoutsIndex = !maxFrameLayoutIndex'
-			  val _ = Int.inc maxFrameLayoutIndex'
-		       in
-			  {size = size,
-			   offsetIndex = offsetIndex,
-			   frameLayoutsIndex = frameLayoutsIndex}
-		       end)
-		in
-		   setFrameLayoutIndex
-		   (label,
-		    SOME {size = size,
-			  frameLayoutsIndex = frameLayoutsIndex})
-		end)))
-	in
-	   val frameLayoutsData = List.rev (!frameLayoutsData)
-	   val maxFrameLayoutIndex = !maxFrameLayoutIndex'
-	end
 	(* C specific *)
 	fun outputC ()
 	  = let
@@ -238,39 +120,6 @@
 			NONE => ()
 		      | SOME s => print (concat [",\n\t", s, "\n"]))
 		  ; print "};\n")
-	      val (pi, declareProfileInfo) =
-		 if !Control.profile = Control.ProfileNone
-		    then ("NULL", fn () => ())
-		 else
-		    ("profileInfo",
-		     fn () =>
-		     let
-			val rest = ["\";\n"]
-			val rest =
-			   "\\n"
-			   :: (Vector.fold
-			       (funcSources, rest, fn ({func, sourceInfo}, ac) =>
-				func :: " "
-				:: Machine.SourceInfo.toString sourceInfo
-				:: "\\n" :: ac))
-		     in
-			print
-			(concat
-			 ("string profileInfo = \""
-			  :: (List.fold
-			      (rev frameLayoutsData, rest,
-			       fn ({func, ...}, ac) =>
-			       func :: "\\n" :: ac))))
-		     end)
-	      fun declareFrameLayouts () =
-                 make ("GC_frameLayout frameLayouts[]",
-		       frameLayoutsData,
-		       fn {size, offsetIndex, ...} =>
-		       print (concat ["{", 
-				      C.int size, ",", 
-				      "frameOffsets" ^ (C.int offsetIndex), 
-				      "}"]),
-		       NONE)
 	      val additionalMainArgs =
 		 let
 		    val mainLabel = Label.toString (#label main)
@@ -281,16 +130,8 @@
 			  Control.Cygwin => String.dropPrefix (mainLabel, 1)
 			| Control.FreeBSD => mainLabel
 			| Control.Linux => mainLabel
-		    val (a1, a2, a3) =
-		       if !Control.profile = Control.ProfileAlloc
-			  then (C.bool true,
-				"&profileAllocLabels",
-				C.int numProfileAllocLabels)
-		       else (C.bool false, C.int 0, C.int 0)
 		 in
-		    [mainLabel,
-		     if reserveEsp then C.truee else C.falsee,
-		     a1, a2, a3, pi]
+		    [mainLabel, if reserveEsp then C.truee else C.falsee]
 		 end
 	      fun declareLocals () =
 		 let
@@ -310,17 +151,11 @@
 			     ";\n"])
 		 end
 	      fun rest () =
-		 (declareLocals ()
-		  ; declareFrameLayouts ()
-		  ; declareProfileInfo ()
-		  ; if !Control.profile = Control.ProfileAlloc
-		       then print "extern uint profileAllocLabels;\n"
-		    else ())
+		 declareLocals ()
 	    in
 	      CCodegen.outputDeclarations
 	      {additionalMainArgs = additionalMainArgs,
 	       includes = includes,
-	       maxFrameIndex = maxFrameLayoutIndex,
 	       name = "X86",
 	       print = print,
 	       program = program,
@@ -344,6 +179,11 @@
 	val liveInfo = x86Liveness.LiveInfo.newLiveInfo ()
 	val jumpInfo = x86JumpInfo.newJumpInfo ()
 
+	fun frameInfoToX86 (Machine.FrameInfo.T {frameLayoutsIndex, ...}) =
+	   x86.FrameInfo.T
+	   {frameLayoutsIndex = frameLayoutsIndex,
+	    size = #size (Vector.sub (frameLayouts, frameLayoutsIndex))}
+	   
 	fun outputChunk (chunk as Machine.Chunk.T {blocks, chunkLabel, ...},
 			 print)
 	  = let
@@ -353,7 +193,7 @@
 	      val {chunk}
 		= x86Translate.translateChunk 
 		  {chunk = chunk,
-		   frameLayouts = getFrameLayoutIndex,
+		   frameInfoToX86 = frameInfoToX86,
 		   liveInfo = liveInfo}
 		  handle exn
 		   => Error.bug ("x86Translate.translateChunk::" ^ 
@@ -444,9 +284,7 @@
 					print "\n"))
 		    fun loop' (chunks, size) 
 		      = case chunks
-			  of [] =>
-			     (declareProfileAllocLabels print
-			      ; done ())
+			  of [] => done ()
 			   | chunk::chunks
 			   => if (case split
 				    of NONE => false



1.34      +2 -1      mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun

Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- x86-generate-transfers.fun	16 Dec 2002 19:28:03 -0000	1.33
+++ x86-generate-transfers.fun	19 Dec 2002 23:43:34 -0000	1.34
@@ -608,7 +608,8 @@
 				    frameInfo as FrameInfo.T {size,
 							      frameLayoutsIndex},
 				    ...}
-			    => AppendList.append
+			    =>
+			       AppendList.append
 			       (AppendList.fromList
 				[Assembly.pseudoop_p2align
 				 (Immediate.const_int 4, NONE, NONE),



1.39      +4 -5      mlton/mlton/codegen/x86-codegen/x86-mlton.fun

Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- x86-mlton.fun	7 Dec 2002 02:21:53 -0000	1.38
+++ x86-mlton.fun	19 Dec 2002 23:43:34 -0000	1.39
@@ -20,16 +20,15 @@
   end
 
   type transInfo = {addData : x86.Assembly.t list -> unit,
-		    frameLayouts: x86.Label.t ->
-		                  {size: int,
-				   frameLayoutsIndex: int} option,
+		    frameInfoToX86: (x86MLtonBasic.Machine.FrameInfo.t
+				     -> x86.FrameInfo.t),
 		    live: x86.Label.t -> x86.Operand.t list,
 		    liveInfo: x86Liveness.LiveInfo.t}
 
   fun prim {prim : Prim.t,
 	    args : (Operand.t * Size.t) vector,
 	    dst : (Operand.t * Size.t) option,
-	    transInfo as {addData, frameLayouts, live, liveInfo} : transInfo}
+	    transInfo as {live, liveInfo, ...} : transInfo}
     = let
 	val primName = Prim.toString prim
 	datatype z = datatype Prim.Name.t
@@ -1430,7 +1429,7 @@
 	     dst : (Operand.t * Size.t),
 	     overflow : Label.t,
 	     success : Label.t,
-	     transInfo as {addData, frameLayouts, live, liveInfo, ...} : transInfo}
+	     transInfo as {live, liveInfo, ...} : transInfo}
     = let
 	val primName = Prim.toString prim
 	datatype z = datatype Prim.Name.t



1.14      +3 -3      mlton/mlton/codegen/x86-codegen/x86-mlton.sig

Index: x86-mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- x86-mlton.sig	6 Jul 2002 17:22:06 -0000	1.13
+++ x86-mlton.sig	19 Dec 2002 23:43:34 -0000	1.14
@@ -22,11 +22,11 @@
     sharing x86 = x86MLtonBasic.x86
     sharing x86 = x86Liveness.x86
     sharing x86.Label = Machine.Label
+    sharing Machine = x86MLtonBasic.Machine
 
     type transInfo = {addData : x86.Assembly.t list -> unit,
-		      frameLayouts: x86.Label.t ->
-		                    {size: int,
-				     frameLayoutsIndex: int} option,
+		      frameInfoToX86: (x86MLtonBasic.Machine.FrameInfo.t
+				       -> x86.FrameInfo.t),
 		      live: x86.Label.t -> x86.Operand.t list,
 		      liveInfo: x86Liveness.LiveInfo.t}
 



1.13      +1 -0      mlton/mlton/codegen/x86-codegen/x86-pseudo.sig

Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- x86-pseudo.sig	11 Jul 2002 02:16:50 -0000	1.12
+++ x86-pseudo.sig	19 Dec 2002 23:43:34 -0000	1.13
@@ -275,6 +275,7 @@
 	val pseudoop_text : unit -> t
 	val pseudoop_p2align : Immediate.t * Immediate.t option * Immediate.t option -> t
 	val pseudoop_byte : Immediate.t list -> t
+	val pseudoop_global: Label.t -> t
 	val pseudoop_word : Immediate.t list -> t
 	val pseudoop_long : Immediate.t list -> t
 	val label : Label.t -> t



1.34      +27 -63    mlton/mlton/codegen/x86-codegen/x86-translate.fun

Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- x86-translate.fun	10 Dec 2002 21:45:49 -0000	1.33
+++ x86-translate.fun	19 Dec 2002 23:43:34 -0000	1.34
@@ -205,16 +205,13 @@
 
   type transInfo = x86MLton.transInfo
 
-  fun toX86FrameInfo {label,
-		      transInfo as {frameLayouts, ...} : transInfo} =
-     Option.map (frameLayouts label, x86.FrameInfo.frameInfo)
-
   structure Entry =
     struct
       structure Kind = Machine.Kind
 	 
       fun toX86Blocks {label, kind, 
-		       transInfo as {frameLayouts, live, liveInfo, ...} : transInfo}
+		       transInfo as {frameInfoToX86, live, liveInfo,
+				     ...}: transInfo}
 	= (
 	   x86Liveness.LiveInfo.setLiveOperands
 	   (liveInfo, label, live label);
@@ -248,11 +245,9 @@
 		     statements = [],
 		     transfer = NONE})
 		 end
-	      | Kind.Cont {args, ...}
+	      | Kind.Cont {args, frameInfo, ...}
 	      => let
-	           val frameInfo =
-		      valOf (toX86FrameInfo {label = label,
-					     transInfo = transInfo})
+		    val frameInfo = frameInfoToX86 frameInfo
 		   val args
 		     = Vector.fold
 		       (args,
@@ -290,8 +285,7 @@
 		 in
 		   x86MLton.creturn
 		   {dst = dst,
-		    frameInfo = toX86FrameInfo {label = label,
-						transInfo = transInfo},
+		    frameInfo = Option.map (frameInfo, frameInfoToX86),
 		    func = func,
 		    label = label,
 		    transInfo = transInfo}
@@ -382,6 +376,19 @@
 				    transInfo = transInfo}),
 		    comment_end]
 		 end
+	      | ProfileLabel l =>
+		   let
+		      val label =
+			 Label.fromString (Machine.ProfileLabel.toString l)
+		   in
+		      AppendList.single
+		      (x86.Block.T'
+		       {entry = NONE,
+			profileInfo = x86.ProfileInfo.none,
+			statements = [x86.Assembly.pseudoop_global label,
+				      x86.Assembly.label label],
+			transfer = NONE})
+		   end
  	      | SetSlotExnStack {offset}
 	      => let
 		   val (comment_begin, comment_end) = comments statement
@@ -740,7 +747,8 @@
 	    else AppendList.empty
 
 	 
-      fun toX86Blocks {returns, transfer, transInfo as {...} : transInfo}
+      fun toX86Blocks {returns, transfer,
+		       transInfo as {frameInfoToX86, ...}: transInfo}
 	= (case transfer
 	     of Arith {prim, args, dst, overflow, success, ty}
 	      => let
@@ -763,12 +771,8 @@
 		   AppendList.append
 		   (comments transfer,	
 		    x86MLton.ccall {args = args,
-				    frameInfo = (case return of
-						    NONE => NONE
-						  | SOME l =>
-						       toX86FrameInfo
-						       {label = l,
-							transInfo = transInfo}),
+				    frameInfo = (Option.map
+						 (frameInfo, frameInfoToX86)),
 				    func = func,
 				    return = return,
 				    transInfo = transInfo})
@@ -1002,7 +1006,7 @@
       open Machine.Chunk
 
       fun toX86Chunk {chunk as T {blocks, ...}, 
-		      frameLayouts, 
+		      frameInfoToX86,
 		      liveInfo}
 	= let
 	    val data = ref []
@@ -1018,7 +1022,7 @@
 		     setLive (label,
 			      Vector.toListMap (live, Operand.toX86Operand)))
 	    val transInfo = {addData = addData,
-			     frameLayouts = frameLayouts,
+			     frameInfoToX86 = frameInfoToX86,
 			     live = live,
 			     liveInfo = liveInfo}
 	    val x86Blocks 
@@ -1039,33 +1043,12 @@
 	   => Error.reraise (exn, "x86Translate.Chunk.toX86Chunk")
     end
 
-  structure Program =
-    struct
-      open Machine.Program
-
-      fun toX86Chunks {program as T {chunks,...},
-		       frameLayouts,
-		       liveInfo} 
-	= let
-	    val chunks
-	      = List.map(chunks,
-			 fn chunk
-			  => Chunk.toX86Chunk {chunk = chunk,
-					       frameLayouts = frameLayouts,
-					       liveInfo = liveInfo})
-	  in 
-	    chunks
-	  end
-    end
-
   fun translateChunk {chunk: x86MLton.Machine.Chunk.t,
-		      frameLayouts: x86MLton.Machine.Label.t ->
-		                    {size: int, frameLayoutsIndex: int} option,
-		      liveInfo: x86Liveness.LiveInfo.t} :
+		      frameInfoToX86,
+		      liveInfo: x86Liveness.LiveInfo.t}:
                      {chunk: x86.Chunk.t}
-		      
     = {chunk = Chunk.toX86Chunk {chunk = chunk,
-				 frameLayouts = frameLayouts,
+				 frameInfoToX86 = frameInfoToX86,
 				 liveInfo = liveInfo}}
 
   val (translateChunk, translateChunk_msg)
@@ -1078,23 +1061,4 @@
        Control.indent ();
        Control.unindent ())
 
-
-  fun translateProgram {program: x86MLton.Machine.Program.t,
-			frameLayouts: x86MLton.Machine.Label.t ->
-			              {size: int, frameLayoutsIndex: int} option,
-			liveInfo: x86Liveness.LiveInfo.t} :
-                       {chunks: x86.Chunk.t list}
-    = {chunks = Program.toX86Chunks {program = program,
-				     frameLayouts = frameLayouts,
-				     liveInfo = liveInfo}}
-
-  val (translateProgram, translateProgram_msg)
-    = tracerTop
-      "translateProgram"
-      translateProgram
-
-  fun translateProgram_totals ()
-    = (translateProgram_msg ();
-       Control.indent ();
-       Control.unindent ())
 end



1.5       +4 -11     mlton/mlton/codegen/x86-codegen/x86-translate.sig

Index: x86-translate.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- x86-translate.sig	10 Apr 2002 07:02:20 -0000	1.4
+++ x86-translate.sig	19 Dec 2002 23:43:34 -0000	1.5
@@ -23,17 +23,10 @@
     include X86_TRANSLATE_STRUCTS
 
     val translateChunk : {chunk: x86MLton.Machine.Chunk.t,
-			  frameLayouts: x86MLton.Machine.Label.t ->
-			                {size: int, frameLayoutsIndex: int} option,
-			  liveInfo: x86Liveness.LiveInfo.t} ->
-                         {chunk: x86.Chunk.t}
-
-    val translateProgram : {program: x86MLton.Machine.Program.t,
-			    frameLayouts: x86MLton.Machine.Label.t ->
-			                  {size: int, frameLayoutsIndex: int} option,
-			    liveInfo: x86Liveness.LiveInfo.t} ->
-                           {chunks: x86.Chunk.t list}
+			  frameInfoToX86: (x86MLton.Machine.FrameInfo.t
+					   -> x86.FrameInfo.t),
+			  liveInfo: x86Liveness.LiveInfo.t}
+                         -> {chunk: x86.Chunk.t}
 
     val translateChunk_totals : unit -> unit
-    val translateProgram_totals : unit -> unit
   end



1.58      +3 -0      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- control.sig	7 Dec 2002 02:21:53 -0000	1.57
+++ control.sig	19 Dec 2002 23:43:34 -0000	1.58
@@ -88,6 +88,9 @@
       (* call count instrumentation *)
       val instrument: bool ref
 
+      (* Save the Machine to a file. *)
+      val keepMachine: bool ref
+	 
       (* Save the RSSA to a file. *)
       val keepRSSA: bool ref
 	 



1.74      +4 -0      mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -r1.73 -r1.74
--- control.sml	7 Dec 2002 02:21:53 -0000	1.73
+++ control.sml	19 Dec 2002 23:43:35 -0000	1.74
@@ -182,6 +182,10 @@
 			      default = false,
 			      toString = Bool.toString}
 
+val keepMachine = control {name = "keep Machine",
+			   default = false,
+			   toString = Bool.toString}
+   
 val keepRSSA = control {name = "keep RSSA",
 			default = false,
 			toString = Bool.toString}



1.43      +9 -0      mlton/mlton/main/compile.sml

Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- compile.sml	12 Dec 2002 01:14:22 -0000	1.42
+++ compile.sml	19 Dec 2002 23:43:35 -0000	1.43
@@ -455,6 +455,15 @@
 	  style = Control.No,
 	  thunk = fn () => Backend.toMachine ssa,
 	  display = Control.Layouts Machine.Program.layouts}
+      val _ =
+	 let
+	    open Control
+	 in
+	    if !keepMachine
+	       then saveToFile ({suffix = "machine"}, No, machine,
+				 Layouts Machine.Program.layouts)
+	    else ()
+	 end
       val _ = Machine.Program.typeCheck machine
    in
       machine



1.103     +6 -5      mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.102
retrieving revision 1.103
diff -u -r1.102 -r1.103
--- main.sml	13 Dec 2002 18:46:52 -0000	1.102
+++ main.sml	19 Dec 2002 23:43:35 -0000	1.103
@@ -168,6 +168,7 @@
 		     case s of
 			"dot" => keepDot := true
 		      | "g" => keepGenerated := true
+		      | "machine" => keepMachine := true
 		      | "o" => keepO := true
 		      | "sml" => keepSML := true
 		      | "rssa" => keepRSSA := true
@@ -247,11 +248,11 @@
 	"produce executable suitable for profiling",
 	SpaceString
 	(fn s =>
-	 case s of
-	    "no" => profile := ProfileNone
-	  | "alloc" => (profile := ProfileAlloc; keepSSA := true)
-	  | "time" => (profile := ProfileTime; keepSSA := true)
-	  | _ => usage (concat ["invalid -profile arg: ", s]))),
+	 profile := (case s of
+			"no" => ProfileNone
+		      | "alloc" => ProfileAlloc
+		      | "time" => ProfileTime
+		      | _ => usage (concat ["invalid -profile arg: ", s])))),
        (Expert, "print-at-fun-entry", " {false|true}",
 	"print debugging message at every call",
 	boolRef printAtFunEntry),



1.17      +1 -0      mlton/mlton/ssa/analyze.fun

Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- analyze.fun	7 Dec 2002 02:21:53 -0000	1.16
+++ analyze.fun	19 Dec 2002 23:43:35 -0000	1.17
@@ -220,6 +220,7 @@
 			      args = values args,
 			      resultType = ty,
 			      resultVar = var}
+		| Profile _ => unit
 		| Select {tuple, offset} =>
 		     select {tuple = value tuple,
 			     offset = offset,



1.10      +2 -5      mlton/mlton/ssa/common-block.fun

Index: common-block.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/common-block.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- common-block.fun	12 Dec 2002 01:14:22 -0000	1.9
+++ common-block.fun	19 Dec 2002 23:43:35 -0000	1.10
@@ -50,9 +50,7 @@
 
       fun eliminateFunction f
 	= let
-	    val {args, blocks, name, returns, raises, sourceInfo, start} =
-	       Function.dest f
-
+	    val {args, blocks, name, returns, raises, start} = Function.dest f
 	    val newBlocks = ref []
 
 	    local
@@ -155,9 +153,8 @@
 	    shrink (Function.new {args = args,
 				  blocks = blocks,
 				  name = name,
-				  returns = returns,
 				  raises = raises,
-				  sourceInfo = sourceInfo,
+				  returns = returns,
 				  start = start})
 	  end
 



1.22      +2 -4      mlton/mlton/ssa/common-subexp.fun

Index: common-subexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/common-subexp.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- common-subexp.fun	12 Dec 2002 01:14:22 -0000	1.21
+++ common-subexp.fun	19 Dec 2002 23:43:35 -0000	1.22
@@ -335,8 +335,7 @@
 	 List.revMap
 	 (functions, fn f => 
 	  let
-	     val {name, args, start, blocks, raises, returns, sourceInfo} =
-		Function.dest f
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
 	     val _ =
 		Vector.foreach
 		(blocks, fn Block.T {label, args, ...} =>
@@ -353,9 +352,8 @@
 	     shrink (Function.new {args = args,
 				   blocks = blocks,
 				   name = name,
-				   returns = returns,
 				   raises = raises,
-				   sourceInfo = sourceInfo,
+				   returns = returns,
 				   start = start})
 	  end)
       val program = 



1.14      +2 -4      mlton/mlton/ssa/constant-propagation.fun

Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- constant-propagation.fun	12 Dec 2002 01:14:22 -0000	1.13
+++ constant-propagation.fun	19 Dec 2002 23:43:35 -0000	1.14
@@ -892,15 +892,13 @@
 		  transfer = doitTransfer transfer}
       fun doitFunction f =
 	 let
-	    val {args, blocks, name, returns, raises, sourceInfo, start} =
-	       Function.dest f
+	    val {args, blocks, name, raises, returns, start} = Function.dest f
 	 in
 	    Function.new {args = args,
 			  blocks = Vector.map (blocks, doitBlock),
 			  name = name,
-			  returns = returns,
 			  raises = raises,
-			  sourceInfo = sourceInfo,
+			  returns = returns,
 			  start = start}
 	 end
       val functions = List.revMap (functions, doitFunction)



1.12      +13 -5     mlton/mlton/ssa/contify.fun

Index: contify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/contify.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- contify.fun	12 Dec 2002 01:14:22 -0000	1.11
+++ contify.fun	19 Dec 2002 23:43:35 -0000	1.12
@@ -395,7 +395,17 @@
 					  val g_node = getFuncNode g
 					in
 					  case return of
-					     Return.NonTail c =>
+					     Return.Dead =>
+						(* When compiling with profiling,
+						 * Dead returns are allowed to
+						 * have nonempty source stacks
+						 * (see type-check.fun).  So, we
+						 * can't contify functions that
+						 * are called with a Dead cont.
+						 *)
+						addEdge {from = Root,
+							 to = g_node}
+					   | Return.NonTail c =>
 						let
 						   val c_node = getContNode c
 						   val rootEdge 
@@ -711,9 +721,8 @@
 		  val {args = f_args, 
 		       blocks = f_blocks,
 		       name = f, 
-		       returns = f_returns,
 		       raises = f_raises,
-		       sourceInfo = f_sourceInfo,
+		       returns = f_returns,
 		       start = f_start} = Function.dest func
 	       in
 		  case FuncData.A (getFuncData f)
@@ -733,9 +742,8 @@
 			      shrink (Function.new {args = f_args,
 						    blocks = f_blocks,
 						    name = f,
-						    returns = f_returns,
 						    raises = f_raises,
-						    sourceInfo = f_sourceInfo,
+						    returns = f_returns,
 						    start = f_start})
 			      :: ac
 			   end



1.10      +1 -3      mlton/mlton/ssa/flatten.fun

Index: flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flatten.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- flatten.fun	12 Dec 2002 01:14:22 -0000	1.9
+++ flatten.fun	19 Dec 2002 23:43:35 -0000	1.10
@@ -250,8 +250,7 @@
 
       fun doitFunction f =
 	 let
-	    val {args, blocks, name, raises, returns, sourceInfo, start} =
-	       Function.dest f
+	    val {args, blocks, name, raises, returns, start} = Function.dest f
 	    val {args = argsReps, returns = returnsReps, raises = raisesReps} = 
 	      funcInfo name
 
@@ -446,7 +445,6 @@
 			  name = name,
 			  raises = raises,
 			  returns = returns,
-			  sourceInfo = sourceInfo,
 			  start = start}
 	 end
 



1.11      +8 -5      mlton/mlton/ssa/inline.fun

Index: inline.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/inline.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- inline.fun	12 Dec 2002 01:14:22 -0000	1.10
+++ inline.fun	19 Dec 2002 23:43:35 -0000	1.11
@@ -23,12 +23,17 @@
       val defaultExpSize : Exp.t -> int = 
 	 fn ConApp {args, ...} => 1 + Vector.length args
 	  | Const _ => 0
+	  | HandlerPop _ => 0
+	  | HandlerPush _ => 0
 	  | PrimApp {args, ...} => 1 + Vector.length args
+	  | Profile _ => 0
 	  | Select _ => 1 + 1
+	  | SetExnStackLocal => 0
+	  | SetExnStackSlot => 0
+	  | SetHandler _ => 0
+	  | SetSlotExnStack => 0
 	  | Tuple xs => 1 + Vector.length xs
 	  | Var _ => 0
-	  (* Handler* / Set* *)
-	  | _ => 0
       fun expSize (size, max) (doExp, doTransfer) exp =
 	 let
 	    val size' = doExp exp
@@ -503,8 +508,7 @@
 	 List.fold
 	 (functions, [], fn (f, ac) =>
 	  let
-	     val {args, blocks, name, raises, returns, sourceInfo, start} =
-		Function.dest f
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
 	  in
 	     if Func.equals (name, main)
 	        orelse not (shouldInline name)
@@ -516,7 +520,6 @@
 					      name = name,
 					      raises = raises,
 					      returns = returns,
-					      sourceInfo = sourceInfo,
 					      start = start})
 			:: ac
 		     end



1.7       +75 -61    mlton/mlton/ssa/introduce-loops.fun

Index: introduce-loops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/introduce-loops.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- introduce-loops.fun	12 Dec 2002 01:14:22 -0000	1.6
+++ introduce-loops.fun	19 Dec 2002 23:43:36 -0000	1.7
@@ -12,7 +12,23 @@
 struct
 
 open S
-open Exp Transfer
+datatype z = datatype Exp.t
+datatype z = datatype Transfer.t
+
+structure Return =
+   struct
+      open Return
+
+      (* Can't use the usual definition of isTail because it includes Dead,
+       * which we can't turn into loops because the profile stack might be off.
+       *)
+      fun isTail (z: t): bool =
+	 case z of
+	    Dead => false
+	  | HandleOnly => true
+	  | NonTail _ => false
+	  | Tail => true
+   end
 
 fun introduceLoops (Program.T {datatypes, globals, functions, main}) =
    let
@@ -20,81 +36,79 @@
 	 List.map
 	 (functions, fn f =>
 	  let
-	     val {args, blocks, name, raises, returns, sourceInfo, start} =
-		Function.dest f
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
 	     val tailCallsItself = ref false
-	     val noChange = (args, start, blocks)
+	     val _ =
+		Vector.foreach
+		(blocks, fn Block.T {transfer, ...} =>
+		 case transfer of
+		    Call {func, return, ...} =>
+		       if Func.equals (name, func)
+			  andalso Return.isTail return
+			  then tailCallsItself := true
+		       else ()
+		  | _ => ())
 	     val (args, start, blocks) =
-	        (Vector.foreach
-		 (blocks, fn Block.T {transfer, ...} =>
-		  case transfer of
-		     Call {func, return, ...} =>
-		        if Func.equals (name, func)
-			   andalso not (Return.isNonTail return)
-			   then tailCallsItself := true
-			else ()
-		   | _ => ()) ;
-		 if !tailCallsItself
-		    then
-		       let
-			  val _ = Control.diagnostics
-			          (fn display =>
-				   let open Layout
-				   in
-				      display (Func.layout name)
-				   end)
-
-			  val newArgs =
-			     Vector.map (args, fn (x, t) => (Var.new x, t))
-			  val loopName = Label.newString "loop"
-			  val loopSName = Label.newString "loopS"
-			  val blocks = 
-			     Vector.toListMap
-			     (blocks, fn Block.T {label, args, statements, transfer} =>
-			      let
-				 val transfer =
-				    case transfer of
-				       Call {func, args, return} =>
-					  if Func.equals (name, func)
-					     andalso not (Return.isNonTail return)
-					     then Goto {dst = loopName, 
-						        args = args}
-					  else transfer
-				     | _ => transfer
-			      in
+		if !tailCallsItself
+		   then
+		      let
+			 val _ = Control.diagnostics
+			    (fn display =>
+			     let open Layout
+			     in
+				display (Func.layout name)
+			     end)
+			 val newArgs =
+			    Vector.map (args, fn (x, t) => (Var.new x, t))
+			 val loopName = Label.newString "loop"
+			 val loopSName = Label.newString "loopS"
+			 val blocks = 
+			    Vector.toListMap
+			    (blocks,
+			     fn Block.T {label, args, statements, transfer} =>
+			     let
+				val transfer =
+				   case transfer of
+				      Call {func, args, return} =>
+					 if Func.equals (name, func)
+					    andalso Return.isTail return
+					    then Goto {dst = loopName, 
+						       args = args}
+					 else transfer
+				    | _ => transfer
+			     in
 				Block.T {label = label,
 					 args = args,
 					 statements = statements,
 					 transfer = transfer}
-			      end)
-			  val blocks = 
-			     Vector.fromList
-			     (Block.T 
-			      {label = loopSName,
-			       args = Vector.new0 (),
-			       statements = Vector.new0 (),
-			       transfer = Goto {dst = loopName,
-						args = Vector.map (newArgs, #1)}} ::
-			      Block.T 
-			      {label = loopName,
-			       args = args,
-			       statements = Vector.new0 (),
-			       transfer = Goto {dst = start,
-						args = Vector.new0 ()}} ::
-			      blocks)
-		       in
+			     end)
+			 val blocks = 
+			    Vector.fromList
+			    (Block.T 
+			     {label = loopSName,
+			      args = Vector.new0 (),
+			      statements = Vector.new0 (),
+			      transfer = Goto {dst = loopName,
+					       args = Vector.map (newArgs, #1)}} ::
+			     Block.T 
+			     {label = loopName,
+			      args = args,
+			      statements = Vector.new0 (),
+			      transfer = Goto {dst = start,
+					       args = Vector.new0 ()}} ::
+			     blocks)
+		      in
 			 (newArgs,
 			  loopSName,
 			  blocks)
-		       end
-		 else noChange)
+		      end
+		else (args, start, blocks)
 	  in
 	     Function.new {args = args,
 			   blocks = blocks,
 			   name = name,
 			   raises = raises,
 			   returns = returns,
-			   sourceInfo = sourceInfo,
 			   start = start}
 	  end)
    in



1.12      +24 -18    mlton/mlton/ssa/known-case.fun

Index: known-case.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/known-case.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- known-case.fun	19 Dec 2002 14:15:31 -0000	1.11
+++ known-case.fun	19 Dec 2002 23:43:36 -0000	1.12
@@ -411,8 +411,7 @@
 	= List.revMap
 	  (functions, fn f =>
 	   let
-	     val {args, blocks, name, raises, returns, sourceInfo, start} =
-		Function.dest f
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
 	     val _ = Vector.foreach
 	             (blocks, fn block as Block.T {label, ...} =>
 		      setLabelInfo (label, LabelInfo.new block))
@@ -448,7 +447,26 @@
 			   label: Label.t} HashSet.t
 		 = HashSet.new {hash = #hash}
 	     in
-	       fun newBlock transfer
+		fun newBlock transfer =
+		   let
+		      val label = Label.newNoname ()
+		      val block = Block.T {label = label,
+					   args = Vector.new0 (),
+					   statements = Vector.new0 (),
+					   transfer = transfer}
+		      val _ = addNewBlock block
+		   in
+		      label
+		   end
+		(* newBlock' isn't used, because it shares blocks that causes
+		 * violation of the requirements for profiling information --
+		 * namely that each block correspond to a unique sequence of
+		 * source infos at it' start.
+		 *
+		 * I left the code in case we want to enable it when compiling
+		 * without profiling.
+		 *)
+		fun newBlock' transfer
 		 = let
 		     val hash = Transfer.hash transfer
 		     val {label, ...}
@@ -456,20 +474,9 @@
 		         (table, hash,
 			  fn {transfer = transfer', ...} =>
 			  Transfer.equals (transfer, transfer'),
-			  fn () => 
-			  let
-			    val label = Label.newNoname ()
-			    val block = Block.T
-			                {label = label,
-					 args = Vector.new0 (),
-					 statements = Vector.new0 (),
-					 transfer = transfer}
-			    val _ = addNewBlock block
-			  in
-			    {hash = hash,
-			     label = label,
-			     transfer = transfer}
-			  end)
+			  fn () => {hash = hash,
+				    label = newBlock transfer,
+				    transfer = transfer})
 		   in
 		     label
 		   end
@@ -1009,7 +1016,6 @@
 				   name = name,
 				   raises = raises,
 				   returns = returns,
-				   sourceInfo = sourceInfo,
 				   start = start}
 	     val _ = Control.diagnostics
 	             (fn display =>



1.15      +1 -4      mlton/mlton/ssa/local-flatten.fun

Index: local-flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/local-flatten.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- local-flatten.fun	12 Dec 2002 01:14:22 -0000	1.14
+++ local-flatten.fun	19 Dec 2002 23:43:36 -0000	1.15
@@ -85,9 +85,7 @@
 	 List.revMap
 	 (functions, fn f =>
 	  let
-	     val {args, blocks, name, raises, returns, sourceInfo, start} =
-		Function.dest f
-
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
 	     val _ =
 	        Vector.foreach
 		(blocks, fn Block.T {label, args, ...} =>
@@ -287,7 +285,6 @@
 				   raises = raises,
 				   returns = returns,
 				   name = name,
-				   sourceInfo = sourceInfo,
 				   start = start})
 	  end)
       val program = Program.T {datatypes = datatypes,



1.18      +3 -6      mlton/mlton/ssa/local-ref.fun

Index: local-ref.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/local-ref.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- local-ref.fun	12 Dec 2002 01:14:22 -0000	1.17
+++ local-ref.fun	19 Dec 2002 23:43:36 -0000	1.18
@@ -234,8 +234,8 @@
 	   if funcIsMultiUsed (Function.name f)
 	     then (f::functions,globals)
 	     else let
-		    val {args, blocks, name, raises, returns, sourceInfo, start}
-		      = Function.dest f
+		    val {args, blocks, name, raises, returns, start} =
+		       Function.dest f
 
 		    val (globals, locals)
 		      = List.fold
@@ -276,7 +276,6 @@
 						   name = name,
 						   raises = raises,
 						   returns = returns,
-						   sourceInfo = sourceInfo,
 						   start = localsLabel}
 				   end
 		  in
@@ -306,8 +305,7 @@
 	= List.revMap
 	  (functions, fn f =>
 	   let
-	     val {args, blocks, name, raises, returns, sourceInfo, start} =
-		Function.dest f
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
 
 	     (* Find all localizable refs. *)
 	     val refs = ref []
@@ -526,7 +524,6 @@
 				   name = name,
 				   raises = raises,
 				   returns = returns,
-				   sourceInfo = sourceInfo,
 				   start = start}
 	     val f = restore f
 	     val f = shrink f



1.13      +1 -3      mlton/mlton/ssa/loop-invariant.fun

Index: loop-invariant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/loop-invariant.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- loop-invariant.fun	12 Dec 2002 01:14:22 -0000	1.12
+++ loop-invariant.fun	19 Dec 2002 23:43:36 -0000	1.13
@@ -29,8 +29,7 @@
 
       fun simplifyFunction f =
 	 let
-	    val {args, blocks, name, raises, returns, sourceInfo, start} =
-	       Function.dest f
+	    val {args, blocks, name, raises, returns, start} = Function.dest f
 	    val {get = labelInfo: Label.t -> {callsSelf: bool ref,
 					      visited: bool ref,
 					      invariant: (Var.t * bool ref) vector,
@@ -158,7 +157,6 @@
 				  name = name,
 				  raises = raises,
 				  returns = returns,
-				  sourceInfo = sourceInfo,
 				  start = start})
 	 end
       val program = 



1.13      +81 -90    mlton/mlton/ssa/poly-equal.fun

Index: poly-equal.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/poly-equal.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- poly-equal.fun	12 Dec 2002 01:14:22 -0000	1.12
+++ poly-equal.fun	19 Dec 2002 23:43:36 -0000	1.13
@@ -102,6 +102,10 @@
 	   destroy = destroyType} =
 	 Property.destGetSet (Type.plist, Property.initConst NONE)
       val returns = SOME (Vector.new1 Type.bool)
+      fun newFunction z =
+	 List.push (newFunctions,
+		    Function.profile (shrink (Function.new z),
+				      SourceInfo.polyEqual))
       fun equalFunc (tycon: Tycon.t): Func.t =
 	 case getEqualFunc tycon of
 	    SOME f => f
@@ -109,74 +113,68 @@
 	       let
 		  val name = Func.newString ("equal_" ^ Tycon.originalName tycon)
 		  val _ = setEqualFunc (tycon, SOME name)
-		  local
-		     val ty = Type.con (tycon, Vector.new0 ())
-		     val arg1 = (Var.newNoname (), ty)
-		     val arg2 = (Var.newNoname (), ty)
-		     val args = Vector.new2 (arg1, arg2)
-		     val darg1 = Dexp.var arg1
-		     val darg2 = Dexp.var arg2
-		     val cons = tyconCons tycon
-		     val body =
-			Dexp.disjoin
-			(Dexp.eq (Dexp.var arg1, Dexp.var arg2, ty),
-			 Dexp.casee
-			 {test = darg1,
-			  ty = Type.bool,
-			  default = (if Vector.exists (cons, fn {args, ...} =>
-						       0 = Vector.length args)
-					then SOME Dexp.falsee
-				     else NONE),
-			  cases =
-			  Dexp.Con
-			  (Vector.keepAllMap
-			   (cons, fn {con, args} =>
-			    if 0 = Vector.length args
-			       then NONE
-			    else
-			       let
-				  fun makeArgs () =
-				     Vector.map (args, fn ty =>
-						 (Var.newNoname (), ty))
-				  val xs = makeArgs ()
-				  val ys = makeArgs ()
-			       in
-				  SOME
-				  {con = con,
-				   args = xs,
-				   body = 
-				   Dexp.casee
-				   {test = darg2,
-				    ty = Type.bool,
-				    default = if 1 = Vector.length cons
-						 then NONE
-					      else SOME Dexp.falsee,
-				    cases =
-				    Dexp.Con
-				    (Vector.new1
-				     {con = con,
-				      args = ys,
-				      body =
-				      Vector.fold2
-				      (xs, ys, Dexp.truee,
-				       fn ((x, ty), (y, _), de) =>
-				       Dexp.conjoin (de, equal (x, y, ty)))})}}
-			       end))})
-		     val (start, blocks) =
-			Dexp.linearize (body, Handler.CallerHandler)
-		     val blocks = Vector.fromList blocks
-		  in
-		     val _ = List.push
-		             (newFunctions,
-			      shrink (Function.new
-				      {args = args,
-				       blocks = blocks,
-				       name = name,
-				       raises = NONE,
-				       returns = returns,
-				       sourceInfo = SourceInfo.polyEqual,
-				       start = start}))
-		  end
+		  val ty = Type.con (tycon, Vector.new0 ())
+		  val arg1 = (Var.newNoname (), ty)
+		  val arg2 = (Var.newNoname (), ty)
+		  val args = Vector.new2 (arg1, arg2)
+		  val darg1 = Dexp.var arg1
+		  val darg2 = Dexp.var arg2
+		  val cons = tyconCons tycon
+		  val body =
+		     Dexp.disjoin
+		     (Dexp.eq (Dexp.var arg1, Dexp.var arg2, ty),
+		      Dexp.casee
+		      {test = darg1,
+		       ty = Type.bool,
+		       default = (if Vector.exists (cons, fn {args, ...} =>
+						    0 = Vector.length args)
+				     then SOME Dexp.falsee
+				  else NONE),
+		       cases =
+		       Dexp.Con
+		       (Vector.keepAllMap
+			(cons, fn {con, args} =>
+			 if 0 = Vector.length args
+			    then NONE
+			 else
+			    let
+			       fun makeArgs () =
+				  Vector.map (args, fn ty =>
+					      (Var.newNoname (), ty))
+			       val xs = makeArgs ()
+			       val ys = makeArgs ()
+			    in
+			       SOME
+			       {con = con,
+				args = xs,
+				body = 
+				Dexp.casee
+				{test = darg2,
+				 ty = Type.bool,
+				 default = if 1 = Vector.length cons
+					      then NONE
+					   else SOME Dexp.falsee,
+					      cases =
+					      Dexp.Con
+					      (Vector.new1
+					       {con = con,
+						args = ys,
+						body =
+						Vector.fold2
+						(xs, ys, Dexp.truee,
+						 fn ((x, ty), (y, _), de) =>
+						 Dexp.conjoin (de, equal (x, y, ty)))})}}
+			    end))})
+		  val (start, blocks) =
+		     Dexp.linearize (body, Handler.CallerHandler)
+		  val blocks = Vector.fromList blocks
+		  val _ =
+		     newFunction {args = args,
+				  blocks = blocks,
+				  name = name,
+				  raises = NONE,
+				  returns = returns,
+				  start = start}
 	       in
 		  name
 	       end
@@ -220,16 +218,13 @@
 			Dexp.linearize (body, Handler.CallerHandler)
 		     val blocks = Vector.fromList blocks
 		  in
-		     val _ = List.push
-		             (newFunctions,
-			      shrink (Function.new
-				      {args = args,
-				       blocks = blocks,
-				       name = name,
-				       raises = NONE,
-				       returns = returns,
-				       sourceInfo = SourceInfo.polyEqual,
-				       start = start}))
+		     val _ =
+			newFunction {args = args,
+				     blocks = blocks,
+				     name = name,
+				     raises = NONE,
+				     returns = returns,
+				     start = start}
 		  end
 		  local
 		     val i = (Var.newNoname (), Type.int)
@@ -264,16 +259,13 @@
 			Dexp.linearize (body, Handler.CallerHandler)
 		     val blocks = Vector.fromList blocks
 		  in
-		     val _ = List.push
-		             (newFunctions,
-			      shrink (Function.new
-				      {args = args,
-				       blocks = blocks,
-				       name = loop,
-				       raises = NONE,
-				       returns = returns,
-				       sourceInfo = SourceInfo.polyEqual,
-				       start = start}))
+		     val _ =
+			newFunction {args = args,
+				     blocks = blocks,
+				     name = loop,
+				     raises = NONE,
+				     returns = returns,
+				     start = start}
 		  end
 	       in
 		  name
@@ -415,7 +407,7 @@
 	 List.revMap 
 	 (functions, fn f =>
 	  let
-	     val {args, blocks, name, raises, returns, sourceInfo, start} =
+	     val {args, blocks, name, raises, returns, start} =
 		Function.dest f
 	  in
 	     shrink (Function.new {args = args,
@@ -423,7 +415,6 @@
 				   name = name,
 				   raises = raises,
 				   returns = returns,
-				   sourceInfo = sourceInfo,
 				   start = start})
 	  end)
       val program =



1.11      +1 -3      mlton/mlton/ssa/redundant-tests.fun

Index: redundant-tests.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant-tests.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- redundant-tests.fun	12 Dec 2002 01:14:22 -0000	1.10
+++ redundant-tests.fun	19 Dec 2002 23:43:36 -0000	1.11
@@ -180,8 +180,7 @@
       val numSimplified = ref 0
       fun simplifyFunction f =
 	  let
-	     val {args, blocks, name, raises, returns, sourceInfo, start} =
-		Function.dest f
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
 	     val _ =
 		Control.diagnostic
 		(fn () => 
@@ -481,7 +480,6 @@
 				   name = name,
 				   raises = raises,
 				   returns = returns,
-				   sourceInfo = sourceInfo,
 				   start = start})
 	  end
       val _ =



1.9       +1 -3      mlton/mlton/ssa/redundant.fun

Index: redundant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- redundant.fun	12 Dec 2002 01:14:22 -0000	1.8
+++ redundant.fun	19 Dec 2002 23:43:36 -0000	1.9
@@ -295,8 +295,7 @@
 	 List.revMap
 	 (functions, fn f =>
 	  let
-	     val {args, blocks, name, raises, returns, sourceInfo, start} =
-		Function.dest f
+	     val {args, blocks, name, raises, returns, start} = Function.dest f
 	     val {args, returns, returnsRed, ...} = funcReds name
 
 	     val blocks =
@@ -355,7 +354,6 @@
 				   name = name,
 				   raises = raises,
 				   returns = returns,
-				   sourceInfo = sourceInfo,
 				   start = start}
 	     val _ = Function.clear f
 	  in



1.21      +16 -21    mlton/mlton/ssa/remove-unused.fun

Index: remove-unused.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/remove-unused.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- remove-unused.fun	12 Dec 2002 01:14:23 -0000	1.20
+++ remove-unused.fun	19 Dec 2002 23:43:36 -0000	1.21
@@ -809,25 +809,20 @@
       val getArithOverflowWrapperLabel = getOriginalWrapperLabel
       val getArithSuccessWrapperLabel = getOriginalWrapperLabel
       val getRuntimeWrapperLabel = getOriginalWrapperLabel
-      fun getBugFunc (fi: FuncInfo.t): Label.t
-	= let
-	    val r = FuncInfo.bugLabel fi
-	  in
-	    case !r 
-	      of SOME l => l
-	       | NONE
-	       => let
-		    val l = Label.newNoname ()
-		    val block = Block.T {label = l,
-					 args = Vector.new0 (),
-					 statements = Vector.new0 (),
-					 transfer = Bug}
-		    val _ = r := SOME l
-		    val _ = List.push (FuncInfo.wrappers' fi, block)
-		  in
-		    l
-		  end
-	  end
+      fun getBugFunc (fi: FuncInfo.t): Label.t =
+	 (* Can't share the Bug block across different places because the
+	  * profile sourceInfo stack might be different.
+	  *)
+	 let
+	    val l = Label.newNoname ()
+	    val block = Block.T {label = l,
+				 args = Vector.new0 (),
+				 statements = Vector.new0 (),
+				 transfer = Bug}
+	    val _ = List.push (FuncInfo.wrappers' fi, block)
+	 in
+	    l
+	 end
       fun getReturnFunc (fi: FuncInfo.t): Label.t 
 	= let
 	    val r = FuncInfo.returnLabel fi
@@ -924,6 +919,7 @@
 	       => maybe (l, fn () => HandlerPop (getHandlerWrapperLabel' l))
 	       | HandlerPush l 
 	       => maybe (l, fn () => HandlerPush (getHandlerWrapperLabel' l))
+	       | Profile _ => SOME s
 	       | _ => let
 			fun doit' var
 			  = SOME (Statement.T {var = var,
@@ -1151,7 +1147,7 @@
       val shrink = shrinkFunction globals
       fun simplifyFunction (f: Function.t): Function.t option
 	= let
-	    val {args, blocks, name, sourceInfo, start, ...} = Function.dest f
+	    val {args, blocks, name, start, ...} = Function.dest f
 	    val fi = funcInfo name
 	  in
 	    if FuncInfo.isUsed fi
@@ -1193,7 +1189,6 @@
 						  name = name,
 						  raises = raises,
 						  returns = returns,
-						  sourceInfo = sourceInfo,
 						  start = start}))
 		   end
 	      else NONE



1.12      +2 -5      mlton/mlton/ssa/restore.fun

Index: restore.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/restore.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- restore.fun	12 Dec 2002 01:14:23 -0000	1.11
+++ restore.fun	19 Dec 2002 23:43:36 -0000	1.12
@@ -210,9 +210,7 @@
     in
       fn (f: Function.t) =>
       let
-	val {args, blocks, name, returns, raises, sourceInfo, start} =
-	   Function.dest f
-
+	val {args, blocks, name, returns, raises, start} = Function.dest f
 	(* check for violations *)
 	val violations = ref []
 	fun addDef (x, ty)
@@ -744,9 +742,8 @@
 	      Function.new {args = args,
 			    blocks = Vector.fromList (!blocks),
 			    name = name,
-			    returns = returns,
 			    raises = raises,
-			    sourceInfo = sourceInfo,
+			    returns = returns,
 			    start = entry}
 	    end
 	val f = rewrite ()



1.24      +3 -7      mlton/mlton/ssa/shrink.fun

Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- shrink.fun	19 Dec 2002 14:15:31 -0000	1.23
+++ shrink.fun	19 Dec 2002 23:43:36 -0000	1.24
@@ -245,7 +245,7 @@
       fn (f: Function.t, mayDelete: bool) =>
       let
 	 val _ = Function.clear f
-	 val {args, blocks, name, raises, returns, sourceInfo, start, ...} =
+	 val {args, blocks, name, raises, returns, start, ...} =
 	    Function.dest f
 	 val _ = Vector.foreach
 	         (args, fn (x, ty) => 
@@ -1247,7 +1247,6 @@
 			  name = name,
 			  raises = raises,
 			  returns = returns,
-			  sourceInfo = sourceInfo,
 			  start = meaningLabel start}
 (*	 val _ = save (f, "post") *)
 	 val _ = Function.clear f
@@ -1289,7 +1288,7 @@
 
 fun eliminateDeadBlocksFunction f =
    let
-      val {args, blocks, name, raises, returns, sourceInfo, start} =
+      val {args, blocks, name, raises, returns, start} =
 	 Function.dest f
       val {get = isLive, set = setLive, rem} =
 	 Property.getSetOnce (Label.plist, Property.initConst false)
@@ -1334,7 +1333,6 @@
 			     name = name,
 			     raises = raises,
 			     returns = returns,
-			     sourceInfo = sourceInfo,
 			     start = start}
 	    end
        val _ = Vector.foreach (blocks, rem o Block.label)
@@ -1344,9 +1342,7 @@
 
 fun eliminateDeadBlocks (Program.T {datatypes, globals, functions, main}) =
    let
-      val functions =
-	 List.revMap
-	 (functions, eliminateDeadBlocksFunction)
+      val functions = List.revMap (functions, eliminateDeadBlocksFunction)
    in
       Program.T {datatypes = datatypes,
 		 globals = globals,



1.11      +6 -6      mlton/mlton/ssa/simplify-types.fun

Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/simplify-types.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- simplify-types.fun	12 Dec 2002 01:14:23 -0000	1.10
+++ simplify-types.fun	19 Dec 2002 23:43:36 -0000	1.11
@@ -517,7 +517,6 @@
 		      Keep (ConApp {con = con,
 				    args = removeUselessVars args})
 		 | ConRep.Useless => Bugg)
-	  | Const _ => Keep e
 	  | PrimApp {prim, targs, args} =>
 	       Keep
 	       (let 
@@ -561,7 +560,6 @@
 		      fn _ => Error.bug "newOffset")
 	       end
 	  | Tuple xs => Keep (tuple xs)
-	  | Var _ => Keep e
 	  | _ => Keep e
       val simplifyExp =
 	 Trace.trace ("SimplifyTypes.simplifyExp",
@@ -656,7 +654,11 @@
 	    (* It is wrong to omit calling simplifyExp when var = NONE because
 	     * targs in a PrimApp may still need to be simplified.
 	     *)
-	    if not (Type.isUnit ty) orelse Exp.maySideEffect exp
+	    if not (Type.isUnit ty)
+	       orelse Exp.maySideEffect exp
+	       orelse (case exp of
+			  Profile _ => true
+			| _ => false)
 	       then
 		  (case simplifyExp exp of
 		      Bugg => Bugg
@@ -695,8 +697,7 @@
 	 end
       fun simplifyFunction f =
 	 let
-	    val {args, name, raises, returns, sourceInfo, start, ...} =
-	       Function.dest f
+	    val {args, name, raises, returns, start, ...} = Function.dest f
 	     val args = simplifyFormals args
 	     val blocks = ref []
 	     val _ =
@@ -711,7 +712,6 @@
 			  name = name,
 			  raises = raises,
 			  returns = returns,
-			  sourceInfo = sourceInfo,
 			  start = start}
 	 end
       val globals =



1.3       +33 -31    mlton/mlton/ssa/source-info.fun

Index: source-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/source-info.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- source-info.fun	12 Dec 2002 21:28:44 -0000	1.2
+++ source-info.fun	19 Dec 2002 23:43:36 -0000	1.3
@@ -1,38 +1,40 @@
 functor SourceInfo (S: SOURCE_INFO_STRUCTS): SOURCE_INFO =
 struct
 
-datatype t =
-   Bogus
- | Main
- | PolyEqual
- | Region of Region.t
-
-val bogus = Bogus
-val fromRegion = Region
-val main = Main
-val polyEqual = PolyEqual
-
-val toString =
-   fn Bogus => "<unknown>"
-    | Main => "<main>"
-    | PolyEqual => "<poly-equal>"
-    | Region r =>
-	 case Region.left r of
-	    NONE => "<unknown>"
-	  | SOME (SourcePos.T {file, line, ...}) =>
-	       let
-		  val s = "/basis-library/"
-		  val file = 
-		     case String.findSubstring {string = file,
-						substring = s} of
-			NONE => file
-		      | SOME i =>
-			   concat ["<basis>/",
-				   String.dropPrefix (file, i + String.size s)]
-	       in
-		  concat [file, ":", Int.toString line]
-	       end
+type t = string
+
+fun toString s = s
 
 val layout = Layout.str o toString
+
+val equals: t * t -> bool = op =
+
+val hash = String.hash
+   
+val main = "<main>"
+val polyEqual = "<poly-equal>"
+val unknown = "<unknown>"
+
+val basisPrefix = "<basis>/"
+   
+fun fromRegion r =
+   case Region.left r of
+      NONE => "<unknown>"
+    | SOME (SourcePos.T {file, line, ...}) =>
+	 let
+	    val s = "/basis-library/"
+	    val file = 
+	       case String.findSubstring {string = file, substring = s} of
+		  NONE => file
+		| SOME i =>
+		     concat [basisPrefix,
+			     String.dropPrefix (file, i + String.size s)]
+	 in
+	    concat [file, ":", Int.toString line]
+	 end
+
+fun isBasis s =
+   String.isPrefix {prefix = basisPrefix,
+		    string = s}
 
 end



1.3       +7 -1      mlton/mlton/ssa/source-info.sig

Index: source-info.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/source-info.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- source-info.sig	12 Dec 2002 19:35:25 -0000	1.2
+++ source-info.sig	19 Dec 2002 23:43:36 -0000	1.3
@@ -1,3 +1,6 @@
+type int = Int.t
+type word = Word.t
+   
 signature SOURCE_INFO_STRUCTS =
    sig
    end
@@ -8,10 +11,13 @@
 	 
       type t
 
-      val bogus: t
+      val equals: t * t -> bool
       val fromRegion: Region.t -> t
+      val hash: t -> word
+      val isBasis: t -> bool
       val layout: t -> Layout.t
       val main: t
       val polyEqual: t
       val toString: t -> string
+      val unknown: t
    end



1.50      +209 -7    mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -r1.49 -r1.50
--- ssa-tree.fun	12 Dec 2002 19:35:25 -0000	1.49
+++ ssa-tree.fun	19 Dec 2002 23:43:36 -0000	1.50
@@ -148,6 +148,34 @@
 			  xs)
    end
 
+structure ProfileExp =
+   struct
+      datatype t =
+	 Enter of SourceInfo.t
+       | Leave of SourceInfo.t
+
+      val toString =
+	 fn Enter si => concat ["Enter ", SourceInfo.toString si]
+	  | Leave si => concat ["Leave " , SourceInfo.toString si]
+
+      val layout = Layout.str o toString
+
+      val equals =
+	 fn (Enter si, Enter si') => SourceInfo.equals (si, si')
+	  | (Leave si, Leave si') => SourceInfo.equals (si, si')
+	  | _ => false
+
+      local
+	 val newHash = Random.word
+	 val enter = newHash ()
+	 val leave = newHash ()
+      in
+	 val hash =
+	    fn Enter si => Word.xorb (enter, SourceInfo.hash si)
+	     | Leave si => Word.xorb (leave, SourceInfo.hash si)
+      end
+   end
+
 structure Exp =
    struct
       datatype t =
@@ -159,6 +187,7 @@
        | PrimApp of {prim: Prim.t,
 		     targs: Type.t vector,
 		     args: Var.t vector}
+       | Profile of ProfileExp.t
        | Select of {tuple: Var.t,
 		    offset: int}
        | SetExnStackLocal
@@ -180,6 +209,7 @@
 	     | HandlerPop l => j l
 	     | HandlerPush l => j l
 	     | PrimApp {args, ...} => vs args
+	     | Profile _ => ()
 	     | Select {tuple, ...} => v tuple
 	     | SetExnStackLocal => ()
 	     | SetExnStackSlot => ()
@@ -203,6 +233,7 @@
 	     | HandlerPush l => HandlerPush (fl l)
 	     | PrimApp {prim, targs, args} =>
 		  PrimApp {prim = prim, targs = targs, args = fxs args}
+	     | Profile _ => e
 	     | Select {tuple, offset} =>
 		  Select {tuple = fx tuple, offset = offset}
 	     | SetExnStackLocal => e
@@ -236,6 +267,7 @@
 		       if isSome (Prim.numArgs prim)
 			  then seq [str " ", layoutTuple args]
 		       else empty]
+	     | Profile p => ProfileExp.layout p
 	     | Select {tuple, offset} =>
 		  seq [str "#", Int.layout (offset + 1), str " ",
 		       Var.layout tuple]
@@ -253,6 +285,8 @@
 	  | HandlerPop _ => false
 	  | HandlerPush _ => false
 	  | PrimApp {prim, ...} => Prim.isFunctional prim
+	  | Profile _ =>
+	       Error.bug "doesn't make sense to ask isFunctional Profile"
 	  | Select _ => true
 	  | SetExnStackLocal => false
 	  | SetExnStackSlot => false
@@ -268,6 +302,7 @@
 	  | HandlerPop _ => true
 	  | HandlerPush _ => true
 	  | PrimApp {prim,...} => Prim.maySideEffect prim
+	  | Profile _ => false
 	  | Select _ => false
 	  | SetExnStackLocal => true
 	  | SetExnStackSlot => true
@@ -285,10 +320,12 @@
 	  | (Const c, Const c') => Const.equals (c, c')
 	  | (HandlerPop l, HandlerPop l') => Label.equals (l, l')
 	  | (HandlerPush l, HandlerPush l') => Label.equals (l, l')
-	  | (PrimApp {prim, args, ...}, PrimApp {prim = prim', args = args', ...}) =>
+	  | (PrimApp {prim, args, ...},
+	     PrimApp {prim = prim', args = args', ...}) =>
 	       Prim.equals (prim, prim') andalso varsEquals (args, args')
-	  | (Select {tuple, offset}, Select {tuple = tuple', offset = offset'}) =>
-	       Var.equals (tuple, tuple') andalso offset = offset'
+	  | (Profile p, Profile p') => ProfileExp.equals (p, p')
+	  | (Select {tuple = t, offset = i}, Select {tuple = t', offset = i'}) =>
+	       Var.equals (t, t') andalso i = i'
 	  | (SetExnStackLocal, SetExnStackLocal) => true
 	  | (SetExnStackSlot, SetExnStackslot) => true
 	  | (SetHandler l, SetHandler l') => Label.equals (l, l')
@@ -303,6 +340,7 @@
 	 val handlerPop = newHash ()
 	 val handlerPush = newHash ()
 	 val primApp = newHash ()
+	 val profile = newHash ()
 	 val select = newHash ()
 	 val setExnStackLocal = newHash ()
 	 val setExnStackSlot = newHash ()
@@ -318,6 +356,7 @@
 	     | HandlerPop l => Word.xorb (handlerPop, Label.hash l)
 	     | HandlerPush l => Word.xorb (handlerPush, Label.hash l)
 	     | PrimApp {args, ...} => hashVars (args, primApp)
+	     | Profile p => Word.xorb (profile, ProfileExp.hash p)
 	     | Select {tuple, offset} =>
 		  Word.xorb (select, Var.hash tuple + Word.fromInt offset)
 	     | SetExnStackLocal => setExnStackLocal
@@ -345,6 +384,7 @@
 				case global x of
 				   NONE => Var.layout x
 				 | SOME s => Layout.str s))
+	  | Profile p => ProfileExp.toString p
 	  | SetExnStackLocal => "SetExnStackLocal"
 	  | SetExnStackSlot => "SetExnStackSlot"
 	  | SetSlotExnStack => "SetSlotExnStack"
@@ -353,6 +393,10 @@
 	  | SetHandler h => concat ["SetHandler ", Label.toString h]
 	  | Tuple xs => Var.prettys (xs, global)
 	  | Var x => Var.toString x
+
+      val isProfile =
+	 fn Profile _ => true
+	  | _ => false
    end
 datatype z = datatype Exp.t
 
@@ -506,6 +550,7 @@
 	 end
 
       val isNonTail = fn NonTail _ => true | _ => false
+      val isTail = not o isNonTail
 	 
       val equals =
 	 fn (Dead, Dead) => true
@@ -948,13 +993,12 @@
 structure Function =
    struct
       structure CPromise = ClearablePromise
-	 
+     
       type dest = {args: (Var.t * Type.t) vector,
 		   blocks: Block.t vector,
 		   name: Func.t,
 		   raises: Type.t vector option,
 		   returns: Type.t vector option,
-		   sourceInfo: SourceInfo.t,
 		   start: Label.t}
 
       (* There is a messy interaction between the laziness used in controlFlow
@@ -1661,7 +1705,7 @@
 		  make (Label.new, Label.plist, Label.layout)
 	    end
 	    fun lookupVars xs = Vector.map (xs, lookupVar)
-	    val {args, blocks, name, raises, returns, sourceInfo, start, ...} =
+	    val {args, blocks, name, raises, returns, start, ...} =
 	       dest f
 	    val args = Vector.map (args, fn (x, ty) => (bindVar x, ty))
 	    val bindLabel = ignore o bindLabel
@@ -1699,7 +1743,165 @@
 		 name = name,
 		 raises = raises,
 		 returns = returns,
-		 sourceInfo = sourceInfo,
+		 start = start}
+	 end
+
+      fun profile (f: t, sourceInfo): t =
+	 if !Control.profile = Control.ProfileNone
+	    then f
+	 else 
+	 let
+	    val {args, blocks, name, raises, returns, start} = dest f
+	    val extraBlocks = ref []
+	    val {get = labelBlock, set = setLabelBlock, rem} =
+	       Property.getSetOnce
+	       (Label.plist, Property.initRaise ("block", Label.layout))
+	    val _ =
+	       Vector.foreach
+	       (blocks, fn block as Block.T {label, ...} =>
+		setLabelBlock (label, block))
+	    val blocks =
+	       Vector.map
+	       (blocks, fn Block.T {args, label, statements, transfer} =>
+		let
+		   fun make (exp: Exp.t): Statement.t =
+		      Statement.T {exp = exp,
+				   ty = Type.unit,
+				   var = NONE}
+		   val statements =
+		      if Label.equals (label, start)
+			 then (Vector.concat
+			       [Vector.new1
+				(make (Exp.Profile
+				       (ProfileExp.Enter sourceInfo))),
+				statements])
+		      else statements
+		   fun leave () =
+		      make (Exp.Profile (ProfileExp.Leave sourceInfo))
+		   fun prefix (l: Label.t,
+			       statements: Statement.t vector): Label.t =
+		      let
+			 val Block.T {args, ...} = labelBlock l
+			 val c = Label.newNoname ()
+			 val xs = Vector.map (args, fn (x, _) => Var.new x)
+			 val _ =
+			    List.push
+			    (extraBlocks,
+			     Block.T
+			     {args = Vector.map2 (xs, args, fn (x, (_, t)) =>
+						  (x, t)),
+			      label = c,
+			      statements = statements,
+			      transfer = Goto {args = xs,
+					       dst = l}})
+		      in
+			 c
+		      end
+		   fun genHandler (): Statement.t vector * Label.t option =
+		      case raises of
+			 NONE => (statements, NONE)
+		       | SOME ts => 
+			    let
+			       val xs = Vector.map (ts, fn _ => Var.newNoname ())
+			       val l = Label.newNoname ()
+			       val _ =
+				  List.push
+				  (extraBlocks,
+				   Block.T
+				   {args = Vector.zip (xs, ts),
+				    label = l,
+				    statements = (Vector.new2
+						  (make (HandlerPop l),
+						   leave ())),
+				    transfer = Transfer.Raise xs})
+			    in
+			       (Vector.concat
+				[statements,
+				 Vector.new1 (make (HandlerPush l))],
+				SOME l)
+			    end
+		   fun genCont () =
+		      let
+			 val l = Label.newNoname ()
+			 val _ = 
+			    List.push
+			    (extraBlocks,
+			     Block.T {args = Vector.new0 (),
+				      label = l,
+				      statements = Vector.new0 (),
+				      transfer = Transfer.Bug})
+		      in
+			 l
+		      end
+		   fun addLeave () =
+		      (Vector.concat [statements,
+				      Vector.new1 (leave ())],
+		       transfer)
+		   datatype z = datatype Return.t
+		   datatype z = datatype Handler.t
+		   val (statements, transfer) =
+		      case transfer of
+			 Call {args, func, return} =>
+			    (case return of
+				Dead => (statements, transfer)
+			      | HandleOnly =>
+				   let
+				      val (statements, h) = genHandler ()
+				      val return =
+					 case h of
+					    NONE => Dead
+					  | SOME h =>
+					       NonTail {cont = genCont (),
+							handler = Handle h}
+				   in
+				      (statements,
+				       Call {args = args,
+					     func = func,
+					     return = return})
+				   end
+			      | NonTail {cont, handler} =>
+				   (case handler of
+				       CallerHandler =>
+					  let
+					     val (statements, h) = genHandler ()
+					     val (cont, handler) =
+						case h of
+						   NONE =>
+						      (cont, None)
+						 | SOME h =>
+						      (prefix
+						       (cont,
+							Vector.new1
+							(make (HandlerPop h))),
+						       Handle h)
+					  in
+					     (statements,
+					      Call {args = args,
+						    func = func,
+						    return =
+						    NonTail {cont = cont,
+							     handler = handler}})
+					  end
+				     | None => (statements, transfer)
+				     | Handle l => (statements, transfer))
+			      | Tail => addLeave ())
+		       | Raise _ => addLeave ()
+		       | Return _ => addLeave ()
+		       | _ => (statements, transfer)
+		in
+		   Block.T {args = args,
+			    label = label,
+			    statements = statements,
+			    transfer = transfer}
+		end)
+	    val _ = Vector.foreach (blocks, rem o Block.label)
+	    val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
+	 in
+	    new {args = args,
+		 blocks = blocks,
+		 name = name,
+		 raises = raises,
+		 returns = returns,
 		 start = start}
 	 end
    end



1.41      +13 -2     mlton/mlton/ssa/ssa-tree.sig

Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- ssa-tree.sig	12 Dec 2002 01:14:23 -0000	1.40
+++ ssa-tree.sig	19 Dec 2002 23:43:36 -0000	1.41
@@ -47,6 +47,15 @@
       structure Func: HASH_ID
       structure Label: HASH_ID
 
+      structure ProfileExp:
+	 sig
+	    datatype t =
+	       Enter of SourceInfo.t
+	     | Leave of SourceInfo.t
+
+	    val layout: t -> Layout.t
+	 end
+      
       structure Exp:
 	 sig
 	    datatype t =
@@ -63,6 +72,7 @@
 	     | PrimApp of {prim: Prim.t,
 			   targs: Type.t vector,
 			   args: Var.t vector}
+	     | Profile of ProfileExp.t
 	     | Select of {tuple: Var.t,
 			  offset: int}
 	     | SetExnStackLocal
@@ -74,6 +84,7 @@
 
 	    val equals: t * t -> bool
 	    val foreachVar: t * (Var.t -> unit) -> unit
+	    val isProfile: t -> bool
 	    val hash: t -> Word.t
 	    val layout: t -> Layout.t
 	    val maySideEffect: t -> bool
@@ -156,6 +167,7 @@
 	    val foreachHandler: t * (Label.t -> unit) -> unit
 	    val foreachLabel: t * (Label.t -> unit) -> unit
 	    val isNonTail: t -> bool
+	    val isTail: t -> bool
 	    val layout: t -> Layout.t
 	    val map: t * (Label.t -> Label.t) -> t
 	 end
@@ -253,7 +265,6 @@
 			    name: Func.t,
 			    raises: Type.t vector option,
 			    returns: Type.t vector option,
-			    sourceInfo: SourceInfo.t,
 			    start: Label.t}
 	    (* dfs (f, v) visits the blocks in depth-first order, applying v b
 	     * for block b to yield v', then visiting b's descendents,
@@ -276,8 +287,8 @@
 		      name: Func.t,
 		      raises: Type.t vector option,
 		      returns: Type.t vector option,
-		      sourceInfo: SourceInfo.t,
 		      start: Label.t} -> t
+	    val profile: t * SourceInfo.t -> t
 	    val start: t -> Label.t
 	 end
      



1.19      +110 -1    mlton/mlton/ssa/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- type-check.fun	21 Aug 2002 04:48:32 -0000	1.18
+++ type-check.fun	19 Dec 2002 23:43:36 -0000	1.19
@@ -64,6 +64,7 @@
 		| HandlerPop l => getLabel l
 		| HandlerPush l => getLabel l
 		| PrimApp {args, ...} => Vector.foreach (args, getVar)
+		| Profile _ => ()
 		| Select {tuple, ...} => getVar tuple
 		| SetExnStackLocal => ()
 		| SetExnStackSlot => ()
@@ -185,11 +186,119 @@
    end
 
 val checkScopes = Control.trace (Control.Pass, "checkScopes") checkScopes
-   
+
+structure Function =
+   struct
+      open Function
+	 
+      fun checkProf (f: t): unit =
+	 let
+	    val debug = false
+	    val {blocks, start, ...} = dest f
+	    val {get = labelInfo, rem, set = setLabelInfo, ...} =
+	       Property.getSetOnce
+	       (Label.plist,
+		Property.initRaise ("info", Label.layout))
+	    val _ = Vector.foreach (blocks, fn b as Block.T {label, ...} =>
+				    setLabelInfo (label,
+						  {block = b,
+						   sources = ref NONE}))
+	    fun goto (l: Label.t, sources: SourceInfo.t list) =
+	       let
+		  val _ =
+		     if not debug
+			then ()
+		     else
+		     let
+			open Layout
+		     in
+			outputl (seq [str "goto (",
+				      Label.layout l,
+				      str ", ",
+				      List.layout SourceInfo.layout sources,
+				      str ")"],
+				 Out.error)
+		     end
+		  val {block, sources = r} = labelInfo l
+	       in
+		  case !r of
+		     NONE =>
+			let
+			   val _ = r := SOME sources
+			   val Block.T {statements, transfer, ...} = block
+			   datatype z = datatype Statement.t
+			   datatype z = datatype ProfileExp.t
+			   val sources =
+			      Vector.fold
+			      (statements, sources,
+			       fn (Statement.T {exp, ...}, sources) =>
+			       case exp of
+				  Profile pe =>
+				     (case pe of
+					 Enter s => s :: sources
+				       | Leave s =>
+					    (case sources of
+						[] => Error.bug "unmatched Leave"
+					      | s' :: sources =>
+						   if SourceInfo.equals (s, s')
+						      then sources
+						   else Error.bug "mismatched Leave"))
+				| _ => sources)
+			   datatype z = datatype Handler.t
+			   datatype z = datatype Return.t
+			   val _ =
+			      if not debug
+				 then ()
+			      else
+			      let
+				 open Layout
+			      in
+				 outputl (List.layout SourceInfo.layout sources,
+					  Out.error)
+			      end
+			   val _ = 
+			      if (case transfer of
+				     Call {return, ...} =>
+					(case return of
+					    Dead => false
+					  | HandleOnly => true
+					  | NonTail {handler, ...} =>
+					       (case handler of
+						   CallerHandler => true
+						 | None => false
+						 | Handle _ => false)
+					  | Tail => true)
+				   | Raise _ => true
+				   | Return _ => true
+				   | _ => false)
+				 then (case sources of
+					  [] => ()
+					| _ => Error.bug "nonempty sources when leaving function")
+			      else ()
+			in
+			   Transfer.foreachLabel
+			   (transfer, fn l => goto (l, sources))
+			end
+		   | SOME sources' =>
+			if List.equals (sources, sources', SourceInfo.equals)
+			   then ()
+			else Error.bug "mismatched block"
+	       end
+	    val _ = goto (start, [])
+	    val _ = Vector.foreach (blocks, fn Block.T {label, ...} => rem label)
+	 in
+	    ()
+	 end
+   end
+
 fun typeCheck (program as Program.T {datatypes, functions, ...}): unit =
    let
       val _ = checkScopes program
       val _ = List.foreach (functions, fn f => (Function.inferHandlers f; ()))
+      val _ =
+	 if !Control.profile <> Control.ProfileNone
+	    then List.foreach (functions, fn f => Function.checkProf f)
+	 else ()
       val out = Out.error
       val print = Out.outputc out
       exception TypeError



1.14      +2 -3      mlton/mlton/ssa/useless.fun

Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- useless.fun	12 Dec 2002 01:14:23 -0000	1.13
+++ useless.fun	19 Dec 2002 23:43:36 -0000	1.14
@@ -805,6 +805,7 @@
 				end
 			then yes ty
 		     else NONE
+		| Profile _ => yes ty
 		| _ => NONE
 	 end
       val doitStatement =
@@ -975,8 +976,7 @@
 	 doitBlock
       fun doitFunction f =
 	 let
-	    val {args, blocks, name, raises, returns, sourceInfo, start} =
-	       Function.dest f
+	    val {args, blocks, name, raises, returns, start} = Function.dest f
 	    val {args = argsvs, returns = returnvs, raises = raisevs, ...} =
 	       func name
 	    val args = keepUsefulArgs args
@@ -996,7 +996,6 @@
 			  name = name,
 			  raises = raises,
 			  returns = returns,
-			  sourceInfo = sourceInfo,
 			  start = start}
 	 end
       val datatypes =



1.108     +70 -14    mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.107
retrieving revision 1.108
diff -u -r1.107 -r1.108
--- gc.c	12 Dec 2002 22:26:55 -0000	1.107
+++ gc.c	19 Dec 2002 23:43:36 -0000	1.108
@@ -93,7 +93,7 @@
 		assert (1 == (header & 1));					\
 		objectTypeIndex = (header & TYPE_INDEX_MASK) >> 1;		\
 		assert (0 <= objectTypeIndex					\
-				and objectTypeIndex < s->maxObjectTypeIndex);	\
+				and objectTypeIndex < s->numObjectTypes);	\
 		t = &s->objectTypes [objectTypeIndex];				\
 		tag = t->tag;							\
 		numNonPointers = t->numNonPointers;				\
@@ -606,7 +606,7 @@
 		if (DEBUG_PROF)
 			fprintf (stderr, "top = 0x%08x  index = %u\n",
 					(uint)top, index);
-		assert (0 <= index and index <= s->maxFrameIndex);
+		assert (0 <= index and index < s->numFrameLayouts);
 		layout = &(s->frameLayouts[index]);
 		assert (layout->numBytes > 0);
 		top -= layout->numBytes;
@@ -630,10 +630,13 @@
 	uint index;
 
 	if (s->native)
-		index = *((uint*)(returnAddress - 4));
+		index = *((uint*)(returnAddress - WORD_SIZE));
 	else
 		index = (uint)returnAddress;
-	assert (0 <= index and index <= s->maxFrameIndex);
+	if (DEBUG_DETAILED)
+		fprintf (stderr, "returnAddress = 0x%08x  index = %d  numFrameLayouts = %d\n",
+				returnAddress, index, s->numFrameLayouts);
+	assert (0 <= index and index < s->numFrameLayouts);
 	layout = &(s->frameLayouts[index]);
 	assert (layout->numBytes > 0);
 	return layout;
@@ -1030,7 +1033,7 @@
 		fprintf (stderr, "invariant\n");
 	assert (ratiosOk (s));
 	/* Frame layouts */
-	for (i = 0; i < s->maxFrameIndex; ++i) {
+	for (i = 0; i < s->numFrameLayouts; ++i) {
 		GC_frameLayout *layout;
 			layout = &(s->frameLayouts[i]);
 		if (layout->numBytes > 0) {
@@ -3221,14 +3224,21 @@
 }
 
 static void showProf (GC_state s) {
-	if (NULL == s->profileInfo)
-		die ("executable missing profiling info\n");
-	fprintf (stdout, "%s", s->profileInfo);
+	int i;
+
+	fprintf (stdout, "0x%08x\n", s->magic);
+	for (i = 0; i < s->profileSourcesSize; ++i)
+		fprintf (stdout, "%s\n", s->profileSources[i]);
 }
 
+/* To get the beginning and end of the text segment. */
+extern void	_start(void),
+		etext(void);
+
 int GC_init (GC_state s, int argc, char **argv) {
 	char *worldFile;
 	int i;
+	int j;
 
 	s->amInGC = FALSE;
 	s->bytesAllocated = 0;
@@ -3283,17 +3293,63 @@
 	worldFile = NULL;
 	unless (isAligned (s->pageSize, s->cardSize))
 		die ("page size must be a multiple of card size");
+	if (s->profileSourcesSize > 0) {
+		if (s->profileLabelsSize > 0) {
+			s->profileAllocIsOn = FALSE;
+			s->profileTimeIsOn = TRUE;
+		} else {
+			s->profileAllocIsOn = TRUE;
+			s->profileTimeIsOn = FALSE;
+		}
+	}
 	if (s->profileAllocIsOn) {
 		s->profileAllocIndex = PROFILE_ALLOC_MISC;
 		MLton_ProfileAlloc_setCurrent 
 			(MLton_ProfileAlloc_Data_malloc ());
-		if (DEBUG_PROFILE_ALLOC) {
-			fprintf (stderr, "s->profileAllocLabels = 0x%08x\n",
-					(uint)s->profileAllocLabels);
-			for (i = 0; i < s->profileAllocNumLabels; ++i)
-				fprintf (stderr, "profileAllocLabels[%d] = 0x%08x\n",
-						i, s->profileAllocLabels[i]);
+	}
+	if (s->profileTimeIsOn) {
+		pointer p;
+		uint sourceSeqsIndex;
+
+		/* Sort profileLabels by address. */
+		for (i = 1; i < s->profileLabelsSize; ++i)
+			for (j = i; s->profileLabels[j - 1].label
+					> s->profileLabels[j].label; --j) {
+				struct GC_profileLabel tmp;
+
+				tmp = s->profileLabels[j];
+				s->profileLabels[j] = s->profileLabels[j - 1];
+				s->profileLabels[j - 1] = tmp;
+			}
+		if (DEBUG_PROF)
+			for (i = 0; i < s->profileLabelsSize; ++i)
+				fprintf (stderr, "0x%08x  %u\n",
+						(uint)s->profileLabels[i].label,
+						s->profileLabels[i].sourceSeqsIndex);
+		/* Initialize s->textSources. */
+		s->textEnd = (pointer)&etext;
+		s->textStart = (pointer)&_start;
+		if (DEBUG)
+			for (i = 0; i < s->profileLabelsSize; ++i)
+				assert (s->textStart <= s->profileLabels[i].label
+					and s->profileLabels[i].label < s->textEnd);
+		s->textSources = 
+			(uint*)malloc ((s->textEnd - s->textStart) 
+						* sizeof(*s->textSources));
+		if (NULL == s->textSources)
+			die ("Out of memory: unable to allocate textSources");
+		p = s->textStart;
+		sourceSeqsIndex = SOURCE_SEQ_UNKNOWN;
+		for (i = 0; i < s->profileLabelsSize; ++i) {
+			while (p < s->profileLabels[i].label) {
+				s->textSources[p - s->textStart]
+					= sourceSeqsIndex;
+				++p;
+			}
+			sourceSeqsIndex = s->profileLabels[i].sourceSeqsIndex;
 		}
+		for ( ; p < s->textEnd; ++p)
+			s->textSources[p - s->textStart] = sourceSeqsIndex;
 	}
 	i = 1;
 	if (argc > 1 and (0 == strcmp (argv [1], "@MLton"))) {



1.47      +31 -6     mlton/runtime/gc.h

Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- gc.h	12 Dec 2002 22:26:56 -0000	1.46
+++ gc.h	19 Dec 2002 23:43:37 -0000	1.47
@@ -73,6 +73,7 @@
 	LIMIT_SLOP = 		512,
 	MARK_MASK =		0x80000000,
 	POINTER_SIZE =		WORD_SIZE,
+	SOURCE_SEQ_UNKNOWN = 	0,
 	STACK_TYPE_INDEX =	0,
 	STRING_TYPE_INDEX = 	1,
 	THREAD_TYPE_INDEX =	2,
@@ -128,6 +129,11 @@
   uint size;
 };
 
+struct GC_profileLabel {
+	pointer label;
+	uint sourceSeqsIndex;
+};
+
 /* ------------------------------------------------- */
 /*                  GC_frameLayout                   */
 /* ------------------------------------------------- */
@@ -278,11 +284,9 @@
 	 */
 	float markCompactGenerationalRatio;
 	uint maxBytesLive;
-	uint maxFrameIndex; /* 0 <= frameIndex < maxFrameIndex */
 	uint maxFrameSize;
 	uint maxHeap; /* if zero, then unlimited, else limit total heap */
 	uint maxHeapSizeSeen;
-	uint maxObjectTypeIndex; /* 0 <= typeIndex < maxObjectTypeIndex */
 	uint maxPause;		/* max time spent in any gc in milliseconds. */
 	uint maxStackSizeSeen;
 	bool messages; /* Print out a message at the start and end of each gc. */
@@ -295,11 +299,13 @@
  	 */
 	bool native;
 	uint numCopyingGCs;
+	uint numFrameLayouts; /* 0 <= frameIndex < numFrameLayouts */
 	uint numGlobals;	/* Number of pointers in globals array. */
  	ullong numLCs;
  	uint numMarkCompactGCs;
 	uint numMinorGCs;
 	uint numMinorsSinceLastMajor;
+	uint numObjectTypes; /* 0 <= typeIndex < numObjectTypes */
 	/* As long as the ratio of bytes live to nursery size is greater than
 	 * nurseryRatio, use minor GCs.
 	 */
@@ -316,9 +322,22 @@
 	ullong *profileAllocCounts;	/* allocation profiling */
 	uint profileAllocIndex;
 	bool profileAllocIsOn;
-	uint *profileAllocLabels;
-	uint profileAllocNumLabels;
-	string profileInfo;
+	/* An array of strings identifying source positions. */
+	string *profileSources;
+	uint profileSourcesSize;
+	/* Each entry in profileFrameSources is an index into 
+	 * profileSourceSeq.
+	 */
+	int *profileFrameSources;
+	uint profileFrameSourcesSize;
+	struct GC_profileLabel *profileLabels;
+	uint profileLabelsSize;
+	/* Each entry in profileSourceSeqs is a vector, whose first element is
+         * a length, and subsequent elements index into profileSources.
+	 */
+	int **profileSourceSeqs;
+	uint profileSourceSeqsSize;
+	bool profileTimeIsOn;
 	W32 ram;		/* ramSlop * totalRam */
 	float ramSlop;
  	struct rusage ru_gc; /* total resource usage spent in gc */
@@ -357,6 +376,12 @@
 	 * is done .
 	 */
 	bool summary; 
+	pointer textEnd;
+	/* An array of indices, one entry for each address in the text segment,
+	 * giving and index into profileSourceSeqs.
+	 */
+	uint *textSources;
+	pointer textStart;
 	pointer toSpace;	/* used during copying */
 	pointer toLimit;	/* used during copying */
 	uint totalRam;		/* bytes */
@@ -464,10 +489,10 @@
  *   intInfInits
  *   loadGlobals
  *   magic
- *   maxFrameIndex
  *   maxFrameSize
  *   maxObjectTypeIndex
  *   native
+ *   numFrameLayouts
  *   numGlobals
  *   objectTypes
  *   saveGlobals



1.7       +62 -35    mlton/runtime/basis/MLton/profile-alloc.c

Index: profile-alloc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/MLton/profile-alloc.c,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- profile-alloc.c	23 Nov 2002 00:29:12 -0000	1.6
+++ profile-alloc.c	19 Dec 2002 23:43:37 -0000	1.7
@@ -5,31 +5,41 @@
 #include "mlton-basis.h"
 #include "my-lib.h"
 
-extern struct GC_state gcState;
-
-#define	MAGIC	"MLton prof\n"
+enum {
+	DEBUG_PROFILE_ALLOC = FALSE,
+};
 
-extern void	_start(void),
-		etext(void);
-
-#define START ((uint)&_start)
-#define END (uint)&etext
+extern struct GC_state gcState;
 
 Pointer MLton_ProfileAlloc_current (void) {
-	return (Pointer)gcState.profileAllocCounts;
+	Pointer res;
+
+	res = (Pointer)gcState.profileAllocCounts;
+	if (DEBUG_PROFILE_ALLOC)
+		fprintf (stderr, "0x%0x8 = MLton_ProfileAlloc_current ()\n",
+				(uint)res);
+	return res;
 }
 
 void MLton_ProfileAlloc_setCurrent (Pointer d) {
+	if (DEBUG_PROFILE_ALLOC)
+		fprintf (stderr, "MLton_ProfileAlloc_setCurrent (0x%08x)\n",
+				(uint)d);
 	gcState.profileAllocCounts = (ullong*)d;
 }
 
 void MLton_ProfileAlloc_inc (Word amount) {
-	assert (gcState.profileAllocIsOn);
-	if (FALSE)
+	GC_state s;
+
+	s = &gcState;
+	if (DEBUG_PROFILE_ALLOC)
 		fprintf (stderr, "MLton_ProfileAlloc_inc (%u, %u)\n",
-				gcState.profileAllocIndex,
+				s->profileAllocIndex,
 				(uint)amount);
-	gcState.profileAllocCounts[gcState.profileAllocIndex] += amount;
+	assert (s->profileAllocIsOn);
+	assert (s->profileAllocIndex < s->profileSourceSeqsSize);
+	s->profileAllocCounts [s->profileSourceSeqs [s->profileAllocIndex] [1]] 
+		+= amount;
 }
 
 Pointer MLton_ProfileAlloc_Data_malloc (void) {
@@ -39,16 +49,22 @@
 	ullong *data;
 
 	assert (gcState.profileAllocIsOn);
-	data = (ullong*) malloc (gcState.profileAllocNumLabels * sizeof (*data));
+	data = (ullong*) malloc (gcState.profileSourcesSize * sizeof (*data));
 	if (data == NULL)
 		die ("Out of memory");
 	MLton_ProfileAlloc_Data_reset ((Pointer)data);
+	if (DEBUG_PROFILE_ALLOC)
+		fprintf (stderr, "0x%08x = MLton_ProfileAlloc_Data_malloc ()\n",
+				(uint)data);
 	return (Pointer)data;
 }
 
 void MLton_ProfileAlloc_Data_free (Pointer d) {
 	ullong *data;
 
+	if (DEBUG_PROFILE_ALLOC)
+		fprintf (stderr, "MLton_ProfileAlloc_Data_free (0x%08x)\n",
+				(uint)d);
 	assert (gcState.profileAllocIsOn);
 	data = (ullong*)d;
 	assert (data != NULL);
@@ -58,38 +74,49 @@
 void MLton_ProfileAlloc_Data_reset (Pointer d) {
 	uint *data;
 
+	if (DEBUG_PROFILE_ALLOC)
+		fprintf (stderr, "MLton_ProfileAlloc_Data_reset (0x%08x)\n",
+				(uint)data);
 	assert (gcState.profileAllocIsOn);
 	data = (uint*)d;
 	assert (data != NULL);
-	memset (data, 0, gcState.profileAllocNumLabels * sizeof(*data));
+	memset (data, 0, gcState.profileSourcesSize * sizeof(*data));
+}
+
+static void writeString (int fd, string s) {
+	swrite (fd, s, strlen(s));
+	swrite (fd, "\n", 1);
+}
+
+static void writeWord (int fd, word w) {
+	char buf[20];
+
+	sprintf (buf, "0x%08x", w);
+	writeString (fd, buf);
+}
+
+static void writeUllong (int fd, ullong u) {
+	char buf[20];
+
+	sprintf (buf, "%llu", u);
+	writeString (fd, buf);
 }
 
 void MLton_ProfileAlloc_Data_write (Pointer d, Word fd) {
-/* Write a profile data array out to a file descriptor
- * The file consists of:
- *	a 12 byte magic value ("MLton prof\n\000")
- *	the lowest address corresponding to a bin
- *	just past the highest address corresponding to a bin
- *	the counter size in bytes (4 or 8)
- *	the bins
- */
+/* Write a profile data array out to a file descriptor */
 	ullong *data;
 	uint i;
 
+	if (DEBUG_PROFILE_ALLOC)
+		fprintf (stderr, "MLton_ProfileAlloc_Data_write (0x%08x, %d)\n",
+				(uint)d, fd);
 	assert (gcState.profileAllocIsOn);
 	data = (ullong*)d;
-	swrite (fd, MAGIC, sizeof(MAGIC));
-	swriteUint (fd, gcState.magic);
-	swriteUint (fd, START);
-	swriteUint (fd, END);
-	swriteUint (fd, sizeof(*data));
-	swriteUint (fd, MLPROF_KIND_ALLOC);
-	for (i = 0; i < gcState.profileAllocNumLabels; ++i) {
-		if (data[i] > 0) {
-			swriteUint (fd, gcState.profileAllocLabels[i]);
-			swriteUllong (fd, data[i]);
-		}
-	}
+	writeString (fd, "MLton prof");
+	writeString (fd, "alloc");
+	writeWord (fd, gcState.magic);
+	for (i = 0; i < gcState.profileSourcesSize; ++i)
+		writeUllong (fd, data[i]);
 }
 
 #elif (defined (__CYGWIN__))



1.9       +43 -50    mlton/runtime/basis/MLton/profile-time.c

Index: profile-time.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/MLton/profile-time.c,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- profile-time.c	12 Dec 2002 22:26:56 -0000	1.8
+++ profile-time.c	19 Dec 2002 23:43:37 -0000	1.9
@@ -15,7 +15,6 @@
 #ifndef EIP
 #define EIP	14
 #endif
-#define	MAGIC	"MLton prof\n"
 
 enum {
 	DEBUG_PROFILE = FALSE,
@@ -23,18 +22,10 @@
 
 extern struct GC_state gcState;
 
-extern void	_start(void),
-		etext(void);
-
-/* Current is an array of uints, where each element corresponds to a range of
- * addresses of the program counter.  Counters cannot possibly overflow for
- * 2^32 / 100 seconds or a bit over 1 CPU year.
+/* Current is an array of uints, one for each source position.
+ * Counters cannot overflow for 2^32 / 100 seconds or a bit over 1 CPU year.
  */
-static uint	*current = NULL,
-		card = 0;
-
-#define START ((uint)&_start)
-#define END (uint)&etext
+static uint *current = NULL;
 
 Pointer MLton_ProfileTime_current () {
 	if (DEBUG_PROFILE)
@@ -60,8 +51,7 @@
 	 */
 	uint *data;
 	
-	assert(card != 0);
-	data = (uint *)malloc (card * sizeof(*data));
+	data = (uint *)malloc (gcState.profileSourcesSize * sizeof(*data));
 	if (data == NULL)
 		die ("Out of memory");
 	MLton_ProfileTime_Data_reset ((Pointer)data);
@@ -78,7 +68,7 @@
 		fprintf (stderr, "MLton_ProfileTime_Data_free (0x%08x)",
 				(uint)d);
 	data = (uint*)d;
-	assert ((card != 0) and (data != NULL));
+	assert (data != NULL);
 	free (data);
 	if (DEBUG_PROFILE)
 		fprintf (stderr, "\n");
@@ -88,19 +78,32 @@
 	uint *data;
 
 	data = (uint*)d;
-	assert ((card != 0) and (data != NULL)); 
-	memset (data, 0, card * sizeof(*data));
+	assert (data != NULL); 
+	memset (data, 0, gcState.profileSourcesSize * sizeof(*data));
+}
+
+static void writeString (int fd, string s) {
+	swrite (fd, s, strlen(s));
+	swrite (fd, "\n", 1);
+}
+
+static void writeWord (int fd, word w) {
+	char buf[20];
+
+	sprintf (buf, "0x%08x", w);
+	writeString (fd, buf);
+}
+
+static void writeUint (int fd, uint w) {
+	char buf[20];
+
+	sprintf (buf, "%u", w);
+	writeString (fd, buf);
 }
 
 void MLton_ProfileTime_Data_write (Pointer d, Word fd) {
-/* Write a profile data array out to a file descriptor
- * The file consists of:
- *	a 12 byte magic value ("MLton prof\n\000")
- *	the lowest address corresponding to a bin
- *	just past the highest address corresponding to a bin
- *	unknown ticks
- *	the nonzero bins
- *  		each bin is a 4 byte address followed by a 4 byte count
+/* Write a profile data array out to a file descriptor.
+ *
  * The `unknown ticks' is a count of the number of times that the monitored
  * program counter was not in the range of a bin.  This almost certainly
  * corresponds to times when it was pointing at shared library code.
@@ -114,42 +117,34 @@
 		fprintf (stderr, "MLton_ProfileTime_Data_Write (0x%08x, %ld)\n",
 				(uint)d, fd);
 	data = (uint*)d;
-	swrite (fd, MAGIC, sizeof(MAGIC));
-	swriteUint (fd, gcState.magic);
-	swriteUint (fd, START);
-	swriteUint (fd, END);
-	swriteUint (fd, sizeof(*data));
-	swriteUint (fd, MLPROF_KIND_TIME);
-	unless (0 == data[card]) {
-		swriteUint (fd, 0);
-		swriteUint (fd, data[card]);
-	}
-	for (i = 0; i < card - 1; ++i) {
-		unless (0 == data[i]) {
-			swriteUint (fd, START + i);
-			swriteUint (fd, data[i]); 
-		}
-	}
+	writeString (fd, "MLton prof");
+	writeString (fd, "time");
+	writeWord (fd, gcState.magic);
+	for (i = 0; i < gcState.profileSourcesSize; ++i)
+		writeUint (fd, data[i]);
 }
 
 /*
  * Called on each SIGPROF interrupt.
  */
 static void catcher (int sig, siginfo_t *sip, ucontext_t *ucp) {
-	uint	pc;
+	uint i;
+	pointer pc;
 
 #if (defined (__linux__))
-        pc = ucp->uc_mcontext.gregs[EIP];
+        pc = (pointer) ucp->uc_mcontext.gregs[EIP];
 #elif (defined (__FreeBSD__))
-	pc = ucp->uc_mcontext.mc_eip;
+	pc = (pointer) ucp->uc_mcontext.mc_eip;
 #else
 #error pc not defined
 #endif
-	if (START <= pc and pc < END)
-		++current[pc - START];
+	if (gcState.textStart <= pc and pc < gcState.textEnd)
+		i = gcState.textSources [pc - gcState.textStart];
 	else
-		++current[card];
-	
+		i = SOURCE_SEQ_UNKNOWN;
+	assert (i < gcState.profileSourceSeqsSize);
+
+	++current[gcState.profileSourceSeqs[i][1]];
 	unless (TRUE or gcState.amInGC)
 		free (GC_stackFrameIndices (&gcState));
 }
@@ -171,8 +166,6 @@
  */
 	struct sigaction	sa;
 
-
-	card = END - START + 1; /* +1 for bin for unknown ticks*/
 	sa.sa_handler = (void (*)(int))catcher;
 	sigemptyset (&sa.sa_mask);
 	sa.sa_flags = SA_ONSTACK | SA_RESTART | SA_SIGINFO;





-------------------------------------------------------
This SF.NET email is sponsored by: Geek Gift Procrastinating?
Get the perfect geek gift now!  Before the Holidays pass you by.
T H I N K G E E K . C O M      http://www.thinkgeek.com/sf/
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel