[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