[MLton-devel] cvs commit: source-level profiling
Stephen Weeks
sweeks@users.sourceforge.net
Thu, 02 Jan 2003 09:45:23 -0800
sweeks 03/01/02 09:45:23
Modified: basis-library/misc primitive.sml
basis-library/mlton profile-alloc.sml
include ccodegen.h codegen.h x86codegen.h
mlprof main.sml
mlton mlton-stubs-1997.cm mlton-stubs.cm mlton.cm
mlton/backend allocate-registers.fun backend.fun
c-function.fun c-function.sig
implement-handlers.fun implement-handlers.sig
limit-check.fun live.fun live.sig machine-atoms.fun
machine-atoms.sig machine.fun machine.sig
profile.fun rssa.fun rssa.sig runtime.fun
runtime.sig ssa-to-rssa.fun ssa-to-rssa.sig
mlton/closure-convert closure-convert.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-generate-transfers.fun
x86-mlton-basic.fun x86-mlton-basic.sig
x86-pseudo.sig x86-translate.fun x86.fun x86.sig
mlton/core-ml lookup-constant.fun
mlton/main compile.sml main.sml
mlton/ssa analyze.fun direct-exp.fun direct-exp.sig
flatten.fun inline.fun introduce-loops.fun
poly-equal.fun redundant.fun remove-unused.fun
restore.fun shrink.fun source-info.fun
source-info.sig sources.cm ssa-tree.fun
ssa-tree.sig type-check.fun useless.fun
regression .cvsignore
runtime Makefile gc.c gc.h my-lib.c my-lib.h
runtime/basis/MLton profile-alloc.c profile-time.c
Added: mlton/ssa profile-exp.sig
Log:
Third whack at source-level profiling, including allocation and time
profiling of the stack.
Summary: it works, but it's too slow in some cases.
Details:
The goal of stack profiling (aka cumulative profiling) is to at each
point of interest (clock tick or allocation) bump a counter for each
source function that is on the stack (once per functioon).
For allocation profiling, I added C calls upon each enter and leave of
a source function. These calls keep track of the number of
occurrences of each function on the stack, and store the current value
of totalBytesAllocated when a function is first entered, bumping the
counter by the difference in totalBytesAllocated when the function is
last left. This works, but the overhead of the C calls can really
hurt, often by a factor of 5X-10X and sometimes by more.
For time profiling, I had the SIGPROF handler walk the stack, keeping
track of whether times each function is on the stack and bumping a
counter once per function. This worked very well for most benchmarks,
but slowed merge down because it has very deep stacks. It was so slow
I killed it after hours. Here are the numbers.
run time ratio
benchmark MLton1
barnes-hut 1.01
boyer 0.87
checksum 1.03
count-graphs 1.07
DLXSimulator 1.02
fft 1.05
fib 1.38
hamlet 1.04
imp-for 1.54
knuth-bendix 1.13
lexgen 1.01
life 1.18
logic 1.03
mandelbrot 1.09
matrix-multiply 1.06
md5 1.25
merge *
mlyacc 1.03
model-elimination 1.06
mpuz 1.09
nucleic 1.09
peek 4.67
psdes-random 1.14
ratio-regions 1.04
ray 1.01
raytrace 1.00
simple 1.05
smith-normal-form 1.00
tailfib 0.81
tak 1.42
tensor 0.96
tsp 0.99
tyan 1.06
vector-concat 0.98
vector-rev 1.04
vliw 1.07
wc-input1 1.06
wc-scanStream 1.42
zebra 0.95
zern 0.98
The large ratio in peek is not due to the stack profiling -- it is
just due to profiling, since I saw it with stack profiling turned
off.
Unfortunately, the stack walking also makes a self-compile unbearably
slow (it did not complete in 10 hours).
After this checkin I will begin work on a new approach that I hope
will make the overhead acceptable for both stack and time profiling.
Here are some other changes:
Made implementHandlers work on Rssa instead of Ssa. This let me
eliminate SetExnStackSlot, SetExnStackLocal, and SetSlotExnStack from
Ssa. CheckHandlers now also works on Rssa instead of Ssa.
Eliminated SetExnStackSlot SetExnStackLocal and SetSlotExnStack from
MACHINE. These are now implemented with arithmetic and moves.
Changed Machine.Type.Label to Machine.Type.Label of Label.t so that
the type checker can track handlers and make sure that the handler
stack is set when doing a nontail call. This required changing
liveness to track the handler label.
Made handlers look more like continuations, with a frame layout and
the stack pointer pointing one word past them instead of at them when
raising. This is so stack walking can work in the middle of a raise,
when the stack is set to a handler frame, not a continuation frame.
Revision Changes Path
1.44 +1 -0 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- primitive.sml 29 Dec 2002 01:22:58 -0000 1.43
+++ primitive.sml 2 Jan 2003 17:45:08 -0000 1.44
@@ -319,6 +319,7 @@
end
val current =
_ffi "MLton_ProfileAlloc_current": unit -> Data.t;
+ val done = _ffi "MLton_ProfileAlloc_done": unit -> unit;
val setCurrent =
_ffi "MLton_ProfileAlloc_setCurrent": Data.t -> unit;
end
1.7 +6 -3 mlton/basis-library/mlton/profile-alloc.sml
Index: profile-alloc.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/profile-alloc.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- profile-alloc.sml 29 Dec 2002 01:22:58 -0000 1.6
+++ profile-alloc.sml 2 Jan 2003 17:45:08 -0000 1.7
@@ -1,14 +1,17 @@
structure MLtonProfileAlloc: MLTON_PROFILE =
struct
-
-structure P = MLtonProfile (open Primitive.MLton.ProfileAlloc)
+
+structure Prim = Primitive.MLton.ProfileAlloc
+structure P = MLtonProfile (open Prim)
open P
val _ =
if not isOn
then ()
else
- (Cleaner.addNew (Cleaner.atExit, P.cleanAtExit)
+ (Cleaner.addNew (Cleaner.atExit, fn () =>
+ (Prim.done ()
+ ; P.cleanAtExit ()))
; Cleaner.addNew (Cleaner.atLoadWorld, fn () =>
(P.cleanAtLoadWorld ()
; init ()))
1.46 +3 -24 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- ccodegen.h 19 Dec 2002 23:43:30 -0000 1.45
+++ ccodegen.h 2 Jan 2003 17:45:08 -0000 1.46
@@ -90,11 +90,11 @@
/* main */
/* ------------------------------------------------- */
-#define Main(cs, mmc, mfs, mg, pa, mc, ml) \
+#define Main(cs, mmc, mfs, mg, mc, ml) \
int main (int argc, char **argv) { \
struct cont cont; \
gcState.native = FALSE; \
- Initialize(cs, mmc, mfs, mg, pa); \
+ Initialize(cs, mmc, mfs, mg); \
if (gcState.isOriginal) { \
real_Init(); \
PrepFarJump(mc, ml); \
@@ -147,8 +147,6 @@
#define DU(n) Declare(uint, u, n)
#define Slot(ty, i) *(ty*)(stackTop + (i))
-
-
#define SC(i) Slot(uchar, i)
#define SD(i) Slot(double, i)
#define SI(i) Slot(int, i)
@@ -156,7 +154,6 @@
#define SU(i) Slot(uint, i)
#define Global(ty, i) (global ## ty [ i ])
-
#define GC(i) Global(uchar, i)
#define GD(i) Global(double, i)
#define GI(i) Global(int, i)
@@ -165,7 +162,6 @@
#define GU(i) Global(uint, i)
#define Offset(ty, b, o) (*(ty*)((b) + (o)))
-
#define OC(b, i) Offset(uchar, b, i)
#define OD(b, i) Offset(double, b, i)
#define OI(b, i) Offset(int, b, i)
@@ -173,7 +169,6 @@
#define OU(b, i) Offset(uint, b, i)
#define Contents(t, x) (*(t*)(x))
-
#define CC(x) Contents(uchar, x)
#define CD(x) Contents(double, x)
#define CI(x) Contents(int, x)
@@ -207,23 +202,7 @@
if (DEBUG_CCODEGEN) \
fprintf (stderr, "%d Raise\n", __LINE__); \
stackTop = StackBottom + ExnStack; \
- l_nextFun = *(int*)stackTop; \
- goto top; \
- } while (0)
-
-#define SetExnStackLocal(offset) \
- do { \
- ExnStack = stackTop + (offset) - StackBottom; \
- } while (0)
-
-#define SetSlotExnStack(offset) \
- do { \
- *(uint*)(stackTop + (offset)) = ExnStack; \
- } while (0)
-
-#define SetExnStackSlot(offset) \
- do { \
- ExnStack = *(uint*)(stackTop + (offset)); \
+ Return(); \
} while (0)
/* ------------------------------------------------- */
1.2 +12 -13 mlton/include/codegen.h
Index: codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/codegen.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- codegen.h 19 Dec 2002 23:43:31 -0000 1.1
+++ codegen.h 2 Jan 2003 17:45:09 -0000 1.2
@@ -37,29 +37,28 @@
sfread (globaluint, sizeof(uint), u, file); \
}
-#define Initialize(cs, mmc, mfs, mg, pa) \
+#define Initialize(cs, mmc, mfs, mg) \
gcState.cardSizeLog2 = cs; \
gcState.frameLayouts = frameLayouts; \
+ gcState.frameLayoutsSize = cardof(frameLayouts); \
+ gcState.frameSources = frameSources; \
+ gcState.frameSourcesSize = cardof(frameSources); \
gcState.globals = globalpointer; \
+ gcState.globalsSize = cardof(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.objectTypesSize = cardof(objectTypes); \
+ gcState.sourceLabels = sourceLabels; \
+ gcState.sourceLabelsSize = cardof(sourceLabels); \
gcState.saveGlobals = saveGlobals; \
+ gcState.sources = sources; \
+ gcState.sourcesSize = cardof(sources); \
+ gcState.sourceSeqs = sourceSeqs; \
+ gcState.sourceSeqsSize = cardof(sourceSeqs); \
gcState.stringInits = stringInits; \
MLton_init (argc, argv, &gcState); \
1.23 +2 -2 mlton/include/x86codegen.h
Index: x86codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86codegen.h,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- x86codegen.h 19 Dec 2002 23:43:31 -0000 1.22
+++ x86codegen.h 2 Jan 2003 17:45:09 -0000 1.23
@@ -34,12 +34,12 @@
pointer localpointer[p]; \
uint localuint[u]
-#define Main(cs, mmc, mfs, mg, pa, ml, reserveEsp) \
+#define Main(cs, mmc, mfs, mg, ml, reserveEsp) \
int main (int argc, char **argv) { \
pointer jump; \
extern pointer ml; \
gcState.native = TRUE; \
- Initialize(cs, mmc, mfs, mg, pa); \
+ Initialize(cs, mmc, mfs, mg); \
if (gcState.isOriginal) { \
real_Init(); \
jump = (pointer)&ml; \
1.21 +31 -14 mlton/mlprof/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- main.sml 19 Dec 2002 23:43:31 -0000 1.20
+++ main.sml 2 Jan 2003 17:45:09 -0000 1.21
@@ -138,11 +138,23 @@
val layout = Layout.str o toString
end
+structure Style =
+ struct
+ datatype t = Cumulative | Current
+
+ val toString =
+ fn Cumulative => "Cumulative"
+ | Current => "Current"
+
+ val layout = Layout.str o toString
+ end
+
structure ProfFile =
struct
datatype t = T of {counts: IntInf.t vector,
kind: Kind.t,
- magic: word}
+ magic: word,
+ total: IntInf.t}
local
fun make f (T r) = f r
@@ -150,9 +162,10 @@
val kind = make #kind
end
- fun layout (T {counts, kind, magic}) =
+ fun layout (T {counts, kind, magic, total}) =
Layout.record [("kind", Kind.layout kind),
("magic", Word.layout magic),
+ ("total", IntInf.layout total),
("counts", Vector.layout IntInf.layout counts)]
fun new {mlmonfile: File.t}: t =
@@ -169,8 +182,14 @@
"alloc\n" => Kind.Alloc
| "time\n" => Kind.Time
| _ => die "invalid profile kind"
+ val style =
+ case In.inputLine ins of
+ "cumulative\n" => Style.Cumulative
+ | "current\n" => Style.Current
+ | _ => die "invalid profile style"
fun line () = String.dropSuffix (In.inputLine ins, 1)
val magic = valOf (Word.fromString (line ()))
+ val total = valOf (IntInf.fromString (line ()))
fun loop ac =
case In.inputLine ins of
"" => Vector.fromListRev ac
@@ -179,24 +198,26 @@
in
T {counts = counts,
kind = kind,
- magic = magic}
+ magic = magic,
+ total = total}
end)
val new =
Trace.trace ("ProfFile.new", File.layout o #mlmonfile, layout) new
- fun merge (T {counts = c, kind = k, magic = m},
- T {counts = c', magic = m', ...}): t =
+ fun merge (T {counts = c, kind = k, magic = m, total = t},
+ T {counts = c', magic = m', total = t', ...}): t =
if m <> m'
then die "incompatible mlmon files"
else
T {counts = Vector.map2 (c, c', IntInf.+),
kind = k,
- magic = m}
+ magic = m,
+ total = IntInf.+ (t, t')}
end
fun attribute (AFile.T {magic = m, sources},
- ProfFile.T {counts, kind, magic = m'})
+ ProfFile.T {counts, kind, magic = m', ...})
: {name: string,
ticks: IntInf.t} ProfileInfo.t option =
if m <> m'
@@ -247,7 +268,7 @@
end
end)
-fun display (kind: Kind.t,
+fun display (ProfFile.T {kind, total, ...},
counts: {name: string, ticks: IntInf.t} ProfileInfo.t,
baseName: string,
depth: int) =
@@ -265,11 +286,7 @@
stuffing: string list,
totals: real list) =
let
- val totalInt =
- List.fold
- (profileInfo, IntInf.fromInt 0,
- fn ({data = {ticks, ...}, ...}, total) =>
- IntInf.+ (total, ticks))
+ val totalInt = total
val total = Real.fromIntInf totalInt
val _ =
if n = 0
@@ -486,7 +503,7 @@
NONE => die (concat [afile, " is incompatible with ",
mlmonfile])
| SOME z => z
- val _ = display (ProfFile.kind profFile, info, afile, !depth)
+ val _ = display (profFile, info, afile, !depth)
in
()
end
1.7 +3 -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.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- mlton-stubs-1997.cm 19 Dec 2002 23:43:31 -0000 1.6
+++ mlton-stubs-1997.cm 2 Jan 2003 17:45:09 -0000 1.7
@@ -245,6 +245,7 @@
atoms/hash-type.sig
atoms/cases.sig
ssa/source-info.sig
+ssa/profile-exp.sig
ssa/ssa-tree.sig
ssa/direct-exp.sig
ssa/analyze.sig
@@ -339,8 +340,6 @@
../lib/mlton/basic/unique-set.fun
backend/rssa.sig
backend/ssa-to-rssa.sig
-backend/implement-handlers.sig
-backend/implement-handlers.fun
backend/representation.sig
backend/representation.fun
backend/ssa-to-rssa.fun
@@ -353,6 +352,8 @@
backend/parallel-move.fun
backend/limit-check.sig
backend/limit-check.fun
+backend/implement-handlers.sig
+backend/implement-handlers.fun
backend/equivalence-graph.sig
backend/equivalence-graph.fun
backend/chunkify.sig
1.12 +3 -2 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- mlton-stubs.cm 19 Dec 2002 23:43:31 -0000 1.11
+++ mlton-stubs.cm 2 Jan 2003 17:45:09 -0000 1.12
@@ -244,6 +244,7 @@
atoms/hash-type.sig
atoms/cases.sig
ssa/source-info.sig
+ssa/profile-exp.sig
ssa/ssa-tree.sig
ssa/direct-exp.sig
ssa/analyze.sig
@@ -338,8 +339,6 @@
../lib/mlton/basic/unique-set.fun
backend/rssa.sig
backend/ssa-to-rssa.sig
-backend/implement-handlers.sig
-backend/implement-handlers.fun
backend/representation.sig
backend/representation.fun
backend/ssa-to-rssa.fun
@@ -352,6 +351,8 @@
backend/parallel-move.fun
backend/limit-check.sig
backend/limit-check.fun
+backend/implement-handlers.sig
+backend/implement-handlers.fun
backend/equivalence-graph.sig
backend/equivalence-graph.fun
backend/chunkify.sig
1.60 +3 -2 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- mlton.cm 19 Dec 2002 23:43:31 -0000 1.59
+++ mlton.cm 2 Jan 2003 17:45:09 -0000 1.60
@@ -215,6 +215,7 @@
atoms/hash-type.sig
atoms/cases.sig
ssa/source-info.sig
+ssa/profile-exp.sig
ssa/ssa-tree.sig
ssa/direct-exp.sig
ssa/analyze.sig
@@ -309,8 +310,6 @@
../lib/mlton/basic/unique-set.fun
backend/rssa.sig
backend/ssa-to-rssa.sig
-backend/implement-handlers.sig
-backend/implement-handlers.fun
backend/representation.sig
backend/representation.fun
backend/ssa-to-rssa.fun
@@ -323,6 +322,8 @@
backend/parallel-move.fun
backend/limit-check.sig
backend/limit-check.fun
+backend/implement-handlers.sig
+backend/implement-handlers.fun
backend/equivalence-graph.sig
backend/equivalence-graph.fun
backend/chunkify.sig
1.24 +18 -14 mlton/mlton/backend/allocate-registers.fun
Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- allocate-registers.fun 10 Dec 2002 21:45:47 -0000 1.23
+++ allocate-registers.fun 2 Jan 2003 17:45:10 -0000 1.24
@@ -42,8 +42,7 @@
local
open Type
in
- val labelSize = size label
- val handlerSize = labelSize + size word
+ val handlerSize = Runtime.labelSize + size word
end
structure Live = Live (open Rssa)
@@ -458,9 +457,9 @@
then
let
val (stack, {offset = handler, ...}) =
- Allocation.Stack.get (stack, Type.label)
- val (stack, {offset = link, ...}) =
Allocation.Stack.get (stack, Type.word)
+ val (stack, {offset = link, ...}) =
+ Allocation.Stack.get (stack, Type.ExnStack)
in
(stack, SOME {handler = handler, link = link})
end
@@ -479,8 +478,8 @@
Function.dfs
(f, fn R.Block.T {args, label, kind, statements, transfer, ...} =>
let
- val {begin, beginNoFormals,
- handlerSlots = (codeLive, linkLive)} = labelLive label
+ val {begin, beginNoFormals, handler = handlerLive,
+ link = linkLive} = labelLive label
fun addHS ops =
Vector.fromList
(case handlerLinkOffset of
@@ -488,17 +487,17 @@
| SOME {handler, link} =>
let
val ops =
- if codeLive
- then
+ case handlerLive of
+ NONE => ops
+ | SOME h =>
Operand.StackOffset {offset = handler,
- ty = Type.label}
+ ty = Type.label h}
:: ops
- else ops
val ops =
if linkLive
then
Operand.StackOffset {offset = link,
- ty = Type.word}
+ ty = Type.ExnStack}
:: ops
else ops
in
@@ -516,13 +515,18 @@
case handlerLinkOffset of
NONE => stackInit
| SOME {handler, link} =>
- {offset = handler, ty = Type.label}
- :: {offset = link, ty = Type.word}
+ {offset = handler, ty = Type.word} (* should be label *)
+ :: {offset = link, ty = Type.ExnStack}
:: stackInit
val a = Allocation.new (stackInit, registersInit)
val size =
Runtime.labelSize
- + Runtime.wordAlignInt (Allocation.stackSize a)
+ + (case kind of
+ Kind.Handler =>
+ (case handlerLinkOffset of
+ NONE => Error.bug "Handler with no handler offset"
+ | SOME {handler, ...} => handler)
+ | _ => Runtime.wordAlignInt (Allocation.stackSize a))
val a =
Vector.fold (args, a, fn ((x, _), a) =>
allocateVar (x, SOME label, false, a))
1.44 +61 -31 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- backend.fun 20 Dec 2002 20:27:15 -0000 1.43
+++ backend.fun 2 Jan 2003 17:45:10 -0000 1.44
@@ -48,13 +48,14 @@
structure Var = Var
end
-structure Profile = Profile (structure Machine = Machine
- structure Rssa = Rssa)
structure AllocateRegisters = AllocateRegisters (structure Machine = Machine
structure Rssa = Rssa)
structure Chunkify = Chunkify (Rssa)
+structure ImplementHandlers = ImplementHandlers (structure Rssa = Rssa)
structure LimitCheck = LimitCheck (structure Rssa = Rssa)
structure ParallelMove = ParallelMove ()
+structure Profile = Profile (structure Machine = Machine
+ structure Rssa = Rssa)
structure SignalCheck = SignalCheck(structure Rssa = Rssa)
structure SsaToRssa = SsaToRssa (structure Rssa = Rssa
structure Ssa = Ssa)
@@ -160,6 +161,8 @@
suffix = "rssa",
thunk = fn () => Profile.profile program,
typeCheck = R.Program.typeCheck o #program}
+ val program = pass ("implementHandlers", ImplementHandlers.doit, program)
+ val _ = R.Program.checkHandlers program
val frameProfileIndex =
if !Control.profile = Control.ProfileNone
then fn _ => 0
@@ -221,7 +224,7 @@
val frameLayoutsCounter = Counter.new 0
val _ = IntSet.reset ()
val table = HashSet.new {hash = Word.fromInt o #frameOffsetsIndex}
- val frameOffsets = ref []
+ val frameOffsets: int vector list ref = ref []
val frameOffsetsCounter = Counter.new 0
val {get = frameOffsetsIndex: IntSet.t -> int, ...} =
Property.get
@@ -229,17 +232,18 @@
Property.initFun
(fn offsets =>
let
- val _ = List.push (frameOffsets, IntSet.toList offsets)
+ val _ = List.push (frameOffsets,
+ QuickSort.sortVector
+ (Vector.fromList (IntSet.toList offsets),
+ op <=))
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))
+ (* Reverse lists because the index is from back of list. *)
+ val frameOffsets = Vector.fromListRev (!frameOffsets)
val frameLayouts = Vector.fromListRev (!frameLayouts)
val frameSources = Vector.fromListRev (!frameSources)
in
@@ -479,23 +483,53 @@
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 ()})
+ (* ExnStack = stackTop + (offset + WORD_SIZE) - StackBottom; *)
+ let
+ val tmp =
+ M.Operand.Register (Register.new (Type.word, NONE))
+ in
+ Vector.new2
+ (M.Statement.PrimApp
+ {args = (Vector.new2
+ (M.Operand.Runtime GCField.StackTop,
+ M.Operand.Int
+ (handlerOffset () + Runtime.wordSize))),
+ dst = SOME tmp,
+ prim = Prim.word32Add},
+ M.Statement.PrimApp
+ {args = (Vector.new2
+ (tmp,
+ M.Operand.Cast
+ (M.Operand.Runtime GCField.StackBottom,
+ M.Type.word))),
+ dst = SOME (M.Operand.Runtime GCField.ExnStack),
+ prim = Prim.word32Sub})
+ end
| SetExnStackSlot =>
+ (* ExnStack = *(uint* )(stackTop + offset); *)
Vector.new1
- (M.Statement.SetExnStackSlot {offset = linkOffset ()})
+ (M.Statement.move
+ {dst = M.Operand.Runtime GCField.ExnStack,
+ src = M.Operand.StackOffset {offset = linkOffset (),
+ ty = Type.ExnStack}})
| SetHandler h =>
Vector.new1
(M.Statement.move
{dst = M.Operand.StackOffset {offset = handlerOffset (),
- ty = Type.label},
+ ty = Type.label h},
src = M.Operand.Label h})
| SetSlotExnStack =>
+ (* *(uint* )(stackTop + offset) = ExnStack; *)
Vector.new1
- (M.Statement.SetSlotExnStack {offset = linkOffset ()})
+ (M.Statement.move
+ {dst = M.Operand.StackOffset {offset = linkOffset (),
+ ty = Type.ExnStack},
+ src = M.Operand.Runtime GCField.ExnStack})
+ | _ => Error.bug (concat
+ ["backend saw strange statement: ",
+ R.Statement.toString s])
end
val genStatement =
Trace.trace ("Backend.genStatement",
@@ -631,7 +665,7 @@
function = f,
varInfo = varInfo}
end
- (* Set the frameInfo for Conts and CReturns in this function. *)
+ (* Set the frameInfo for blocks in this function. *)
val _ =
Vector.foreach
(blocks, fn R.Block.T {kind, label, ...} =>
@@ -688,23 +722,21 @@
return = return})
| R.Transfer.Call {func, args, return} =>
let
+ datatype z = datatype R.Return.t
val (contLive, frameSize, return) =
case return of
- R.Return.Dead =>
- (Vector.new0 (), 0, NONE)
- | R.Return.Tail =>
- (Vector.new0 (), 0, NONE)
- | R.Return.HandleOnly =>
- (Vector.new0 (), 0, NONE)
- | R.Return.NonTail {cont, handler} =>
+ Dead => (Vector.new0 (), 0, NONE)
+ | Tail => (Vector.new0 (), 0, NONE)
+ | NonTail {cont, handler} =>
let
val {liveNoFormals, size, ...} =
labelRegInfo cont
+ datatype z = datatype R.Handler.t
val handler =
case handler of
- R.Handler.CallerHandler => NONE
- | R.Handler.None => NONE
- | R.Handler.Handle h => SOME h
+ Caller => NONE
+ | Dead => NONE
+ | Handle h => SOME h
in
(liveNoFormals,
size,
@@ -864,8 +896,8 @@
else NONE
in
(M.Kind.CReturn {dst = dst,
- frameInfo = frameInfo,
- func = func},
+ frameInfo = frameInfo,
+ func = func},
liveNoFormals,
Vector.new0 ())
end
@@ -875,14 +907,12 @@
List.push
(handlers, {chunkLabel = Chunk.label chunk,
label = label})
- val {handler = offset, ...} =
- valOf handlerLinkOffset
val dsts = Vector.map (args, varOperand o #1)
val handles =
raiseOperands (Vector.map (dsts, M.Operand.ty))
in
- (M.Kind.Handler {handles = handles,
- offset = offset},
+ (M.Kind.Handler {frameInfo = frameInfo label,
+ handles = handles},
liveNoFormals,
M.Statement.moves {dsts = dsts,
srcs = handles})
1.6 +8 -20 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- c-function.fun 19 Dec 2002 23:43:32 -0000 1.5
+++ c-function.fun 2 Jan 2003 17:45:13 -0000 1.6
@@ -16,12 +16,10 @@
modifiesFrontier: bool,
modifiesStackTop: bool,
name: string,
- needsProfileAllocIndex: bool,
returnTy: Type.t option}
fun layout (T {bytesNeeded, ensuresBytesFree, mayGC, maySwitchThreads,
- modifiesFrontier, modifiesStackTop, name,
- needsProfileAllocIndex, returnTy}) =
+ modifiesFrontier, modifiesStackTop, name, returnTy}) =
Layout.record
[("bytesNeeded", Option.layout Int.layout bytesNeeded),
("ensuresBytesFree", Bool.layout ensuresBytesFree),
@@ -30,7 +28,6 @@
("modifiesFrontier", Bool.layout modifiesFrontier),
("modifiesStackTop", Bool.layout modifiesStackTop),
("name", String.layout name),
- ("needsProfileAllocIndex", Bool.layout needsProfileAllocIndex),
("returnTy", Option.layout Type.layout returnTy)]
local
@@ -43,7 +40,6 @@
val modifiesFrontier = make #modifiesFrontier
val modifiesStackTop = make #modifiesStackTop
val name = make #name
- val needsProfileAllocIndex = make #needsProfileAllocIndex
val returnTy = make #returnTy
end
@@ -79,7 +75,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_gc",
- needsProfileAllocIndex = false,
returnTy = NONE}
val t = make true
val f = make false
@@ -95,7 +90,6 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = name,
- needsProfileAllocIndex = false,
returnTy = returnTy}
val bug = vanilla {name = "MLton_bug",
@@ -104,18 +98,12 @@
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}
+val profileAllocIncLeaveEnter =
+ vanilla {name = "MLton_ProfileAlloc_incLeaveEnter",
+ returnTy = NONE}
+
+val profileAllocSetCurrentSource =
+ vanilla {name = "MLton_ProfileAlloc_setCurrentSource",
+ returnTy = NONE}
end
1.5 +2 -3 mlton/mlton/backend/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-function.sig 19 Dec 2002 23:43:32 -0000 1.4
+++ c-function.sig 2 Jan 2003 17:45:13 -0000 1.5
@@ -31,7 +31,6 @@
mayGC: bool,
maySwitchThreads: bool,
name: string,
- needsProfileAllocIndex: bool,
returnTy: Type.t option}
val bug: t
@@ -46,8 +45,8 @@
val modifiesFrontier: t -> bool
val modifiesStackTop: t -> bool
val name: t -> string
- val needsProfileAllocIndex: t -> bool
- val profileAllocInc: t
+ val profileAllocIncLeaveEnter: t
+ val profileAllocSetCurrentSource: t
val returnTy: t -> Type.t option
val size: t
val vanilla: {name: string, returnTy: Type.t option} -> t
1.7 +44 -49 mlton/mlton/backend/implement-handlers.fun
Index: implement-handlers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/implement-handlers.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- implement-handlers.fun 19 Dec 2002 23:43:32 -0000 1.6
+++ implement-handlers.fun 2 Jan 2003 17:45:13 -0000 1.7
@@ -9,9 +9,7 @@
struct
open S
-open Ssa
-datatype z = datatype Exp.t
-datatype z = datatype Transfer.t
+open Rssa
structure LabelInfo =
struct
@@ -27,7 +25,7 @@
("visited", Bool.layout (!visited))]
end
-fun doit (Program.T {datatypes, globals, functions, main}) =
+fun doit (Program.T {functions, main, objectTypes}) =
let
fun implementFunction (f: Function.t): Function.t =
let
@@ -75,10 +73,11 @@
if List.equals (hs, hs', Label.equals)
then ()
else bug "handler stack mismatch"
+ datatype z = datatype Statement.t
val hs =
if not (Vector.exists
- (statements, fn Statement.T {var, exp, ...} =>
- case exp of
+ (statements, fn s =>
+ case s of
HandlerPop _ => true
| HandlerPush _ => true
| _ => false))
@@ -92,40 +91,36 @@
val (hs, ac) =
Vector.fold
(statements, (hs, []), fn (s, (hs, ac)) =>
- let
- val Statement.T {var, ty, exp, ...} = s
- in
- case Statement.exp s of
- HandlerPop _ =>
- (case hs of
- [] => bug "pop of empty handler stack"
- | _ :: hs =>
- let
- val s =
- case hs of
- [] =>
- Statement.setExnStackSlot
- | h :: _ =>
- Statement.setHandler h
- in (hs, s :: ac)
- end)
- | HandlerPush h =>
- let
- val ac =
- Statement.setHandler h :: ac
- val ac =
- case hs of
- [] =>
- Statement.setExnStackLocal
- :: Statement.setSlotExnStack
- :: ac
- | _ => ac
- in
- (h :: hs, ac)
- end
- | _ => (hs, s :: ac)
- end)
- val _ =
+ case s of
+ HandlerPop _ =>
+ (case hs of
+ [] => bug "pop of empty handler stack"
+ | _ :: hs =>
+ let
+ val s =
+ case hs of
+ [] =>
+ Statement.SetExnStackSlot
+ | h :: _ =>
+ Statement.SetHandler h
+ in (hs, s :: ac)
+ end)
+ | HandlerPush h =>
+ let
+ val ac =
+ Statement.SetHandler h :: ac
+ val ac =
+ case hs of
+ [] =>
+ Statement.SetExnStackLocal
+ :: Statement.SetSlotExnStack
+ :: ac
+ | _ => ac
+ in
+ (h :: hs, ac)
+ end
+ | _ => (hs, s :: ac))
+ val _ =
replacement := SOME (Vector.fromListRev ac)
in
hs
@@ -138,15 +133,16 @@
val _ = visit (start, [])
val blocks =
Vector.map
- (blocks, fn b as Block.T {label, args, transfer, ...} =>
+ (blocks, fn b as Block.T {args, kind, label, transfer, ...} =>
let
val {replacement, visited, ...} = labelInfo label
in
if !visited
- then Block.T {label = label,
- args = args,
- transfer = transfer,
- statements = valOf (! replacement)}
+ then Block.T {args = args,
+ kind = kind,
+ label = label,
+ statements = valOf (! replacement),
+ transfer = transfer}
else b
end)
in
@@ -158,10 +154,9 @@
start = start}
end
in
- Program.T {datatypes = datatypes,
- globals = globals,
- functions = List.revMap (functions, implementFunction),
- main = main}
+ Program.T {functions = List.revMap (functions, implementFunction),
+ main = main,
+ objectTypes = objectTypes}
end
end
1.3 +2 -2 mlton/mlton/backend/implement-handlers.sig
Index: implement-handlers.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/implement-handlers.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- implement-handlers.sig 16 Apr 2002 12:10:52 -0000 1.2
+++ implement-handlers.sig 2 Jan 2003 17:45:14 -0000 1.3
@@ -7,12 +7,12 @@
*)
signature IMPLEMENT_HANDLERS_STRUCTS =
sig
- structure Ssa: SSA
+ structure Rssa: RSSA
end
signature IMPLEMENT_HANDLERS =
sig
include IMPLEMENT_HANDLERS_STRUCTS
- val doit: Ssa.Program.t -> Ssa.Program.t
+ val doit: Rssa.Program.t -> Rssa.Program.t
end
1.33 +0 -1 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- limit-check.fun 20 Dec 2002 18:29:41 -0000 1.32
+++ limit-check.fun 2 Jan 2003 17:45:14 -0000 1.33
@@ -133,7 +133,6 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = "MLton_allocTooLarge",
- needsProfileAllocIndex = false,
returnTy = NONE}
val _ =
newBlocks :=
1.15 +58 -39 mlton/mlton/backend/live.fun
Index: live.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/live.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- live.fun 10 Apr 2002 07:02:19 -0000 1.14
+++ live.fun 2 Jan 2003 17:45:14 -0000 1.15
@@ -38,7 +38,8 @@
structure LiveInfo =
struct
datatype t = T of {live: Var.t list ref,
- liveHS: bool ref * bool ref,
+ liveHS: {handler: Label.t option ref,
+ link: unit option ref},
name: string,
preds: t list ref}
@@ -46,13 +47,16 @@
fun new (name: string) =
T {live = ref [],
- liveHS = (ref false, ref false),
+ liveHS = {handler = ref NONE,
+ link = ref NONE},
name = name,
preds = ref []}
fun live (T {live = r, ...}) = !r
- fun liveHS (T {liveHS = (c, l), ...}) = (!c, !l)
+ fun liveHS (T {liveHS = {handler, link}, ...}) =
+ {handler = !handler,
+ link = isSome (!link)}
fun equals (T {live = r, ...}, T {live = r', ...}) = r = r'
@@ -91,9 +95,9 @@
Property.get (Var.plist,
Property.initFun (fn _ => {defined = ref NONE,
used = ref []}))
- datatype u = Def of LiveInfo.t | Use of LiveInfo.t
- val handlerCodeDefUses: u list ref = ref []
- val handlerLinkDefUses: u list ref = ref []
+ datatype 'a defuse = Def of LiveInfo.t | Use of 'a * LiveInfo.t
+ val handlerCodeDefUses: Label.t defuse list ref = ref []
+ val handlerLinkDefUses: unit defuse list ref = ref []
val allVars: Var.t list ref = ref []
fun setDefined (x: Var.t, defined): unit =
if shouldConsider x
@@ -143,7 +147,8 @@
*)
val _ =
case kind of
- Kind.Cont {handler, ...} => Option.app (handler, goto)
+ Kind.Cont {handler, ...} =>
+ Handler.foreachLabel (handler, goto)
| _ => ()
fun define (x: Var.t): unit = setDefined (x, b)
fun use (x: Var.t): unit =
@@ -167,9 +172,12 @@
use = use})
val _ =
case s of
- SetExnStackSlot => List.push (handlerLinkDefUses, Use b)
- | SetHandler _ => List.push (handlerCodeDefUses, Def b)
- | SetSlotExnStack => List.push (handlerLinkDefUses, Def b)
+ SetExnStackSlot =>
+ List.push (handlerLinkDefUses, Use ((), b))
+ | SetHandler _ =>
+ List.push (handlerCodeDefUses, Def b)
+ | SetSlotExnStack =>
+ List.push (handlerLinkDefUses, Def b)
| _ => ()
in
()
@@ -179,7 +187,8 @@
val {block = Block.T {kind, ...}, ...} = labelInfo l
in
case kind of
- Kind.Handler => List.push (handlerCodeDefUses, Use b)
+ Kind.Handler =>
+ List.push (handlerCodeDefUses, Use (l, b))
| _ => goto l
end
val _ =
@@ -228,45 +237,55 @@
* occurs before the use. But, a back propagated use will always
* come after a def in the same block
*)
- fun handlerLink (defuse, sel) =
+ fun handlerLink (defuse: 'a defuse list ref,
+ sel: {handler: Label.t option ref,
+ link: unit option ref} -> 'a option ref) =
let
- val todo: LiveInfo.t list ref = ref []
+ val todo: ('a * LiveInfo.t) list ref = ref []
val defs =
List.foldr
- (!defuse, [],
- fn (Def b, defs) => b::defs
- | (Use (b as LiveInfo.T {liveHS, ...}), defs) =>
- if List.exists (defs, fn b' => LiveInfo.equals (b, b'))
- then defs
- else (sel liveHS := true
- ; List.push (todo, b)
- ; defs))
- fun consider (b as LiveInfo.T {liveHS, ...}) =
+ (!defuse, [], fn (du, defs) =>
+ case du of
+ Def b => b::defs
+ | Use (a, b as LiveInfo.T {liveHS, ...}) =>
+ let
+ val _ =
+ if List.exists (defs, fn b' =>
+ LiveInfo.equals (b, b'))
+ then ()
+ else (sel liveHS := SOME a
+ ; List.push (todo, (a, b)))
+ in
+ defs
+ end)
+ fun consider (b as LiveInfo.T {liveHS, ...}, a: 'a) =
if List.exists (defs, fn b' => LiveInfo.equals (b, b'))
- orelse !(sel liveHS)
+ orelse isSome (!(sel liveHS))
then ()
- else (sel liveHS := true
- ; List.push (todo, b))
+ else (sel liveHS := SOME a
+ ; List.push (todo, (a, b)))
fun loop () =
case !todo of
[] => ()
- | LiveInfo.T {preds, ...} :: bs =>
+ | (a, LiveInfo.T {preds, ...}) :: bs =>
(todo := bs
- ; List.foreach (!preds, consider)
+ ; List.foreach (!preds, fn b => consider (b, a))
; loop ())
val _ = loop ()
in
()
end
- val _ = handlerLink (handlerCodeDefUses, #1)
- val _ = handlerLink (handlerLinkDefUses, #2)
+ val _ = handlerLink (handlerCodeDefUses, #handler)
+ val _ = handlerLink (handlerLinkDefUses, #link)
fun labelLive (l: Label.t) =
let
val {bodyInfo, argInfo, ...} = labelInfo l
+ val {handler, link} = LiveInfo.liveHS bodyInfo
in
{begin = LiveInfo.live bodyInfo,
beginNoFormals = LiveInfo.live argInfo,
- handlerSlots = LiveInfo.liveHS bodyInfo}
+ handler = handler,
+ link = link}
end
val _ =
Control.diagnostics
@@ -277,16 +296,16 @@
(blocks, fn b =>
let
val l = Block.label b
- val {begin, beginNoFormals, handlerSlots} = labelLive l
+ val {begin, beginNoFormals, handler, link} = labelLive l
in
- display (seq [Label.layout l,
- str " ",
- record [("begin", List.layout Var.layout begin),
- ("beginNoFormals",
- List.layout Var.layout beginNoFormals),
- ("handlerSlots",
- Layout.tuple2 (Bool.layout, Bool.layout)
- handlerSlots)]])
+ display
+ (seq [Label.layout l,
+ str " ",
+ record [("begin", List.layout Var.layout begin),
+ ("beginNoFormals",
+ List.layout Var.layout beginNoFormals),
+ ("handler", Option.layout Label.layout handler),
+ ("link", Bool.layout link)]])
end)
end)
in
1.11 +2 -1 mlton/mlton/backend/live.sig
Index: live.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/live.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- live.sig 10 Apr 2002 07:02:19 -0000 1.10
+++ live.sig 2 Jan 2003 17:45:14 -0000 1.11
@@ -21,5 +21,6 @@
(* live at the beginning of a block, except formals. *)
beginNoFormals: Var.t list,
(* live handler slots at beginning of block. *)
- handlerSlots: bool * bool}
+ handler: Label.t option,
+ link: bool}
end
1.5 +14 -7 mlton/mlton/backend/machine-atoms.fun
Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- machine-atoms.fun 20 Dec 2002 04:37:12 -0000 1.4
+++ machine-atoms.fun 2 Jan 2003 17:45:14 -0000 1.5
@@ -9,7 +9,7 @@
struct
open S
-
+
structure PointerTycon =
struct
datatype t = T of {index: int,
@@ -54,9 +54,10 @@
| CPointer
| EnumPointers of {enum: int vector,
pointers: PointerTycon.t vector}
+ | ExnStack
| Int
| IntInf
- | Label
+ | Label of Label.t
| MemChunk of memChunk
| Real
| Word
@@ -81,9 +82,10 @@
Vector.layout (fn x => x)
(Vector.concat [Vector.map (enum, Int.layout),
Vector.map (pointers, PointerTycon.layout)])
+ | ExnStack => str "exnStack"
| Int => str "int"
| IntInf => str "intInf"
- | Label => str "Label"
+ | Label l => seq [str "Label ", Label.layout l]
| MemChunk m => seq [str "MemChunk ", layoutMemChunk m]
| Real => str "real"
| Word => str "word"
@@ -107,9 +109,10 @@
e = e'
andalso (MLton.eq (p, p')
orelse Vector.equals (p, p', PointerTycon.equals))
+ | (ExnStack, ExnStack) => true
| (Int, Int) => true
| (IntInf, IntInf) => true
- | (Label, Label) => true
+ | (Label l, Label l') => Label.equals (l, l')
| (MemChunk m, MemChunk m') => equalsMemChunk (m, m')
| (Real, Real) => true
| (Word, Word) => true
@@ -131,9 +134,10 @@
fn Char => byte
| CPointer => word
| EnumPointers _ => word
+ | ExnStack => word
| Int => word
| IntInf => word
- | Label => word
+ | Label _ => word
| MemChunk _ => word
| Real => double
| Word => word
@@ -148,9 +152,10 @@
andalso Vector.isSorted (pointers, PointerTycon.<=)
andalso (0 = Vector.length pointers
orelse Vector.forall (enum, Int.isOdd))
+ | ExnStack => true
| Int => true
| IntInf => true
- | Label => true
+ | Label _ => true
| MemChunk m => isOkMemChunk m
| Real => true
| Word => true
@@ -216,6 +221,7 @@
pointers = Vector.new0 ()}
val char = Char
val cpointer = CPointer
+ val exnStack = ExnStack
val int = Int
val intInf = IntInf
val label = Label
@@ -265,9 +271,10 @@
if 0 = Vector.length pointers
then R.int
else R.pointer
+ | ExnStack => R.uint
| Int => R.int
| IntInf => R.pointer
- | Label => R.uint
+ | Label _ => R.uint
| MemChunk _ => R.pointer
| Real => R.double
| Word => R.word
1.5 +4 -2 mlton/mlton/backend/machine-atoms.sig
Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- machine-atoms.sig 20 Dec 2002 04:37:12 -0000 1.4
+++ machine-atoms.sig 2 Jan 2003 17:45:14 -0000 1.5
@@ -48,9 +48,10 @@
*)
| EnumPointers of {enum: int vector,
pointers: PointerTycon.t vector}
+ | ExnStack
| Int
| IntInf
- | Label
+ | Label of Label.t
| MemChunk of memChunk (* An internal pointer. *)
| Real
| Word
@@ -62,11 +63,12 @@
val cpointer: t
val dePointer: t -> PointerTycon.t option
val equals: t * t -> bool
+ val exnStack: t
val fromRuntime: Runtime.Type.t -> t
val int: t
val intInf: t
val isPointer: t -> bool
- val label: t
+ val label: Label.t -> t
val layout: t -> Layout.t
val name: t -> string (* simple one letter abbreviation *)
val pointer: PointerTycon.t -> t
1.37 +103 -40 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- machine.fun 20 Dec 2002 20:26:33 -0000 1.36
+++ machine.fun 2 Jan 2003 17:45:14 -0000 1.37
@@ -251,12 +251,15 @@
| GCState => Type.cpointer
| Global g => Global.ty g
| Int _ => Type.int
- | Label _ => Type.label
+ | Label l => Type.label l
| Line => Type.int
| Offset {ty, ...} => ty
| Real _ => Type.real
| Register r => Register.ty r
- | Runtime z => Type.fromRuntime (GCField.ty z)
+ | Runtime f =>
+ (case f of
+ GCField.ExnStack => Type.exnStack
+ | _ => Type.fromRuntime (GCField.ty f))
| SmallIntInf _ => Type.intInf
| StackOffset {ty, ...} => ty
| Word _ => Type.word
@@ -503,8 +506,8 @@
frameInfo: FrameInfo.t option,
func: CFunction.t}
| Func
- | Handler of {handles: Operand.t vector,
- offset: int}
+ | Handler of {frameInfo: FrameInfo.t,
+ handles: Operand.t vector}
| Jump
fun layout k =
@@ -523,9 +526,9 @@
("frameInfo", Option.layout FrameInfo.layout frameInfo),
("func", CFunction.layout func)]]
| Func => str "Func"
- | Handler {handles, offset} =>
+ | Handler {frameInfo, handles} =>
seq [str "Handler ",
- record [("offset", Int.layout offset),
+ record [("frameInfo", FrameInfo.layout frameInfo),
("handles",
Vector.layout Operand.layout handles)]]
| Jump => str "Jump"
@@ -534,6 +537,7 @@
val frameInfoOpt =
fn Cont {frameInfo, ...} => SOME frameInfo
| CReturn {frameInfo, ...} => frameInfo
+ | Handler {frameInfo, ...} => SOME frameInfo
| _ => NONE
end
@@ -654,7 +658,7 @@
FrameInfo.T {frameLayoutsIndex, ...}) =
#size (Vector.sub (frameLayouts, frameLayoutsIndex))
- fun layouts (p as T {chunks, frameOffsets, handlesSignals,
+ fun layouts (p as T {chunks, frameLayouts, frameOffsets, handlesSignals,
main = {label, ...},
maxFrameSize, objectTypes, ...},
output': Layout.t -> unit) =
@@ -667,7 +671,13 @@
("main", Label.layout label),
("maxFrameSize", Int.layout maxFrameSize),
("frameOffsets",
- Vector.layout (Vector.layout Int.layout) frameOffsets)])
+ Vector.layout (Vector.layout Int.layout) frameOffsets),
+ ("frameLayouts",
+ Vector.layout (fn {frameOffsetsIndex, size} =>
+ record [("frameOffsetsIndex",
+ Int.layout frameOffsetsIndex),
+ ("size", Int.layout size)])
+ frameLayouts)])
; output (str "\nObjectTypes:")
; Vector.foreachi (objectTypes, fn (i, ty) =>
output (seq [str "pt_", Int.layout i,
@@ -704,6 +714,15 @@
Trace.trace2 ("Alloc.doesDefine", layout, Operand.layout,
Bool.layout)
doesDefine
+
+ fun peekOffset (T zs, i: int): {offset: int,
+ ty: Type.t} option =
+ List.peekMap
+ (zs, fn Operand.StackOffset (ot as {offset, ...}) =>
+ if i = offset
+ then SOME ot
+ else NONE
+ | _ => NONE)
end
fun typeCheck (program as
@@ -943,11 +962,6 @@
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 {frameLayoutsIndex, ...}) =
- 0 <= frameLayoutsIndex
- andalso frameLayoutsIndex < Vector.length frameLayouts
- fun checkFrameInfo i =
- check' (i, "frame info", frameInfoOk, FrameInfo.layout)
val labelKind = Block.kind o labelBlock
fun labelIsJump (l: Label.t): bool =
case labelKind l of
@@ -956,32 +970,66 @@
fun checkKind (k: Kind.t, alloc: Alloc.t): Alloc.t option =
let
datatype z = datatype Kind.t
+ exception No
+ fun frame (FrameInfo.T {frameLayoutsIndex}): bool =
+ let
+ val {frameOffsetsIndex, size} =
+ Vector.sub (frameLayouts, frameLayoutsIndex)
+ handle Subscript => raise No
+ val Alloc.T zs = alloc
+ val liveOffsets =
+ List.fold
+ (zs, [], fn (z, liveOffsets) =>
+ case z of
+ Operand.StackOffset {offset, ty} =>
+ if Type.isPointer ty
+ then offset :: liveOffsets
+ else liveOffsets
+ | _ => raise No)
+ val liveOffsets =
+ Vector.fromArray
+ (QuickSort.sortArray
+ (Array.fromList liveOffsets, op <=))
+ val liveOffsets' =
+ Vector.sub (frameOffsets, frameOffsetsIndex)
+ handle Subscript => raise No
+ in
+ liveOffsets = liveOffsets'
+ end handle No => false
+ fun slotsAreInFrame (fi: FrameInfo.t): bool =
+ let
+ val {size, ...} = getFrameInfo fi
+ in
+ Alloc.forall
+ (alloc, fn z =>
+ case z of
+ Operand.StackOffset {offset, ty} =>
+ offset + Type.size ty <= size
+ | _ => false)
+ end
in
case k of
Cont {args, frameInfo} =>
- let
- val _ = checkFrameInfo frameInfo
- val {size, ...} = getFrameInfo frameInfo
- in
- if (Alloc.forall
- (alloc, fn z =>
- case z of
- Operand.StackOffset {offset, ty} =>
- offset + Type.size ty <= size
- | _ => false))
- then
- SOME (Vector.fold
- (args, alloc, fn (z, alloc) =>
- Alloc.define (alloc, z)))
- else NONE
- end
+ if frame frameInfo
+ andalso slotsAreInFrame frameInfo
+ then SOME (Vector.fold
+ (args, alloc, fn (z, alloc) =>
+ Alloc.define (alloc, z)))
+ else NONE
| CReturn {dst, frameInfo, ...} =>
- (Option.app (frameInfo, checkFrameInfo)
- ; SOME (case dst of
- NONE => alloc
- | SOME z => Alloc.define (alloc, z)))
+ if (case frameInfo of
+ NONE => true
+ | SOME fi => (frame fi
+ andalso slotsAreInFrame fi))
+ then SOME (case dst of
+ NONE => alloc
+ | SOME z => Alloc.define (alloc, z))
+ else NONE
| Func => SOME alloc
- | Handler _ => SOME alloc
+ | Handler {frameInfo, ...} =>
+ if frame frameInfo
+ then SOME alloc
+ else NONE
| Jump => SOME alloc
end
fun checkStatement (s: Statement.t, alloc: Alloc.t)
@@ -1051,11 +1099,27 @@
end
else SOME alloc
| SetExnStackLocal {offset} =>
- (checkOperand
- (Operand.StackOffset {offset = offset,
- ty = Type.label},
- alloc)
- ; SOME alloc)
+ (case Alloc.peekOffset (alloc, offset) of
+ NONE => NONE
+ | SOME {ty, ...} =>
+ (case ty of
+ Type.Label l =>
+ let
+ val Block.T {kind, ...} = labelBlock l
+ in
+ case kind of
+ Kind.Handler {frameInfo, ...} =>
+ let
+ val {size, ...} =
+ getFrameInfo frameInfo
+ in
+ if offset = size
+ then SOME alloc
+ else NONE
+ end
+ | _ => NONE
+ end
+ | _ => NONE))
| SetExnStackSlot {offset} =>
(checkOperand
(Operand.StackOffset {offset = offset,
@@ -1213,7 +1277,6 @@
| CCall {args, frameInfo, func, return} =>
let
val _ = checkOperands (args, alloc)
- val _ = Option.app (frameInfo, checkFrameInfo)
in
case return of
NONE => true
1.28 +2 -2 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- machine.sig 20 Dec 2002 18:29:42 -0000 1.27
+++ machine.sig 2 Jan 2003 17:45:14 -0000 1.28
@@ -173,8 +173,8 @@
frameInfo: FrameInfo.t option,
func: CFunction.t}
| Func
- | Handler of {handles: Operand.t vector,
- offset: int}
+ | Handler of {frameInfo: FrameInfo.t,
+ handles: Operand.t vector}
| Jump
val frameInfoOpt: t -> FrameInfo.t option
1.6 +262 -180 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- profile.fun 21 Dec 2002 02:58:12 -0000 1.5
+++ profile.fun 2 Jan 2003 17:45:15 -0000 1.6
@@ -3,7 +3,6 @@
open S
open Rssa
-
structure Graph = DirectedGraph
local
open Graph
@@ -121,7 +120,11 @@
title = "call graph"})))
fun makeSources () = Vector.fromListRev (!sourceInfos)
end
- val unknownIndex = sourceInfoIndex SourceInfo.unknown
+ (* unknown must be 0, which == SOURCES_INDEX_UNKNOWN from gc.h *)
+ val unknownInfoNode = sourceInfoNode SourceInfo.unknown
+ val unknownIndex = InfoNode.index unknownInfoNode
+ (* gc must be 1 which == SOURCES_INDEX_GC from gc.h *)
+ val gcIndex = sourceInfoIndex SourceInfo.gc
val mainIndex = sourceInfoIndex SourceInfo.main
local
val table: {hash: word,
@@ -155,7 +158,7 @@
(* Ensure that SourceInfo unknown is index 0. *)
val unknownSourceSeq = sourceSeqIndex [sourceInfoIndex SourceInfo.unknown]
(* Treat the empty source sequence as unknown. *)
- val sourceSeqIndex =
+ val sourceSeqIndexSafe =
fn [] => unknownSourceSeq
| s => sourceSeqIndex s
val {get = labelInfo: Label.t -> {block: Block.t,
@@ -166,7 +169,7 @@
val labels = ref []
fun profileLabel (sourceSeq: int list): Statement.t =
let
- val index = sourceSeqIndex sourceSeq
+ val index = sourceSeqIndexSafe sourceSeq
val l = ProfileLabel.new ()
val _ = List.push (labels, {label = l,
sourceSeqsIndex = index})
@@ -204,17 +207,6 @@
let
val {args, blocks, name, raises, returns, start} = Function.dest f
val {callees, ...} = funcInfo name
- fun enter (si: SourceInfo.t, ps: Push.t list) =
- let
- val n as InfoNode.T {node, ...} = sourceInfoNode si
- val _ =
- case firstEnter ps of
- NONE => List.push (callees, node)
- | SOME (InfoNode.T {node = node', ...}) =>
- addEdge {from = node', to = node}
- in
- Push.Enter n :: ps
- end
val _ =
Vector.foreach
(blocks, fn block as Block.T {label, ...} =>
@@ -222,23 +214,20 @@
visited = ref false}))
val blocks = ref []
datatype z = datatype Statement.t
- datatype z = datatype ProfileStatement.t
+ datatype z = datatype ProfileExp.t
fun backward {args,
kind,
label,
- needsProfileAllocIndex,
sourceSeq,
statements: Statement.t list,
transfer: Transfer.t}: unit =
let
- val (_, npl, sourceSeq, statements) =
+ val (npl, sourceSeq, statements) =
List.fold
(statements,
- (needsProfileAllocIndex, true, sourceSeq, []),
- fn (s, (npai, npl, sourceSeq, ss)) =>
+ (true, sourceSeq, []), fn (s, (npl, sourceSeq, ss)) =>
case s of
- Object _ => (true, true, sourceSeq, s :: ss)
- | Profile ps =>
+ Profile ps =>
let
val ss =
if profileTime andalso npl
@@ -254,25 +243,49 @@
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)
+ (false, sourceSeq', ss)
end
- | _ => (npai, true, sourceSeq, s :: ss))
+ | _ => (true, sourceSeq, s :: ss))
val statements =
if profileTime andalso npl
then profileLabel sourceSeq :: statements
else statements
+ val (args, kind, label) =
+ if profileAlloc
+ andalso (case kind of
+ Kind.Cont _ => true
+ | Kind.Handler => true
+ | _ => false)
+ then
+ let
+ val newLabel = Label.newNoname ()
+ val func = CFunction.profileAllocSetCurrentSource
+ val sourceIndex =
+ case sourceSeq of
+ [] => unknownIndex
+ | n :: _ => n
+ val _ =
+ List.push
+ (blocks,
+ Block.T
+ {args = args,
+ kind = kind,
+ label = label,
+ statements = Vector.new0 (),
+ transfer =
+ Transfer.CCall {args = (Vector.new1
+ (Operand.word
+ (Word.fromInt
+ sourceIndex))),
+ func = func,
+ return = SOME newLabel}})
+ in
+ (Vector.new0 (),
+ Kind.CReturn {func = func},
+ newLabel)
+ end
+ else (args, kind, label)
in
List.push (blocks,
Block.T {args = args,
@@ -289,6 +302,202 @@
List.layout Statement.layout statements],
Unit.layout)
backward
+ fun maybeSplit {args,
+ bytesAllocated,
+ enters: InfoNode.t list,
+ kind,
+ label,
+ leaves: InfoNode.t list,
+ maybe: bool,
+ sourceSeq,
+ statements} =
+ if profileAlloc
+ andalso (not (List.isEmpty enters)
+ orelse not (List.isEmpty leaves)
+ orelse maybe)
+ then
+ let
+ val newLabel = Label.newNoname ()
+ val func = CFunction.profileAllocIncLeaveEnter
+ fun ssi (ns: InfoNode.t list): int =
+ sourceSeqIndex (List.revMap (ns, InfoNode.index))
+ val enters =
+ (* add the current source to the enters *)
+ (case firstEnter sourceSeq of
+ NONE => unknownInfoNode
+ | SOME n => n) :: enters
+ val transfer =
+ Transfer.CCall
+ {args = (Vector.new3
+ (Operand.word (Word.fromInt bytesAllocated),
+ Operand.word (Word.fromInt (ssi leaves)),
+ Operand.word (Word.fromInt (ssi enters)))),
+ func = func,
+ return = SOME newLabel}
+ val sourceSeq = Push.toSources sourceSeq
+ val _ =
+ backward {args = args,
+ kind = kind,
+ label = label,
+ sourceSeq = sourceSeq,
+ statements = statements,
+ transfer = transfer}
+ in
+ {args = Vector.new0 (),
+ bytesAllocated = 0,
+ enters = [],
+ kind = Kind.CReturn {func = func},
+ label = newLabel,
+ leaves = [],
+ statements = []}
+ end
+ else
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ enters = enters,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ statements = statements}
+ val maybeSplit =
+ Trace.trace
+ ("Profile.maybeSplit",
+ fn {enters, leaves, sourceSeq, ...} =>
+ Layout.record [("enters", List.layout InfoNode.layout enters),
+ ("leaves", List.layout InfoNode.layout leaves),
+ ("sourceSeq", List.layout Push.layout sourceSeq)],
+ Layout.ignore)
+ maybeSplit
+ fun forward {args, kind, label, sourceSeq, statements} =
+ Vector.fold
+ (statements,
+ {args = args,
+ bytesAllocated = 0,
+ enters = [],
+ kind = kind,
+ label = label,
+ leaves = [],
+ sourceSeq = sourceSeq,
+ statements = []},
+ fn (s, {args, bytesAllocated, enters, kind, label, leaves,
+ sourceSeq, statements}) =>
+ (
+ if debug
+ then
+ let
+ open Layout
+ in
+ outputl (record
+ [("statement", Statement.layout s),
+ ("enters", List.layout InfoNode.layout enters),
+ ("leaves", List.layout InfoNode.layout leaves)],
+ Out.error)
+ end
+ else ()
+ ;
+ case s of
+ Object {size, ...} =>
+ let
+ val {args, bytesAllocated, enters, kind, label,
+ leaves, statements} =
+ maybeSplit {args = args,
+ bytesAllocated = bytesAllocated,
+ enters = enters,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ maybe = false,
+ sourceSeq = sourceSeq,
+ statements = statements}
+ in
+ {args = args,
+ bytesAllocated = bytesAllocated + size,
+ enters = enters,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ sourceSeq = sourceSeq,
+ statements = s :: statements}
+ end
+ | Profile ps =>
+ let
+ val (enters, leaves, sourceSeq, statements) =
+ case ps of
+ Enter si =>
+ (if shouldPush (si, sourceSeq)
+ then
+ let
+ val n
+ as InfoNode.T {node, ...} =
+ sourceInfoNode si
+ val _ =
+ case firstEnter sourceSeq of
+ NONE =>
+ List.push (callees, node)
+ | SOME
+ (InfoNode.T
+ {node = node', ...}) =>
+ addEdge {from = node',
+ to = node}
+ in
+ (n :: enters,
+ leaves,
+ Push.Enter n :: sourceSeq,
+ s :: statements)
+ end
+ else (enters,
+ leaves,
+ Push.Skip si :: sourceSeq,
+ statements))
+ | Leave si =>
+ (case sourceSeq of
+ [] => Error.bug "unmatched Leave"
+ | p :: sourceSeq' =>
+ (case p of
+ Push.Enter (n as InfoNode.T {index, ...}) =>
+ if index = sourceInfoIndex si
+ then
+ let
+ val (enters, leaves) =
+ case enters of
+ [] =>
+ ([],
+ n :: leaves)
+ | _ :: enters =>
+ (enters, leaves)
+ in
+ (enters,
+ leaves,
+ sourceSeq',
+ s :: statements)
+ end
+ else Error.bug "mismatched leave"
+ | Push.Skip si' =>
+ if SourceInfo.equals (si, si')
+ then (enters,
+ leaves,
+ sourceSeq',
+ statements)
+ else Error.bug "mismatched leave"))
+ in
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ enters = enters,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ sourceSeq = sourceSeq,
+ statements = statements}
+ end
+ | _ => {args = args,
+ bytesAllocated = bytesAllocated,
+ enters = enters,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ sourceSeq = sourceSeq,
+ statements = s :: statements})
+ )
fun goto (l: Label.t, sourceSeq: Push.t list): unit =
let
val _ =
@@ -318,148 +527,29 @@
if Kind.isFrame kind
then List.push (frameProfileIndices,
(label,
- sourceSeqIndex
+ sourceSeqIndexSafe
(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,
- 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 =>
- if shouldPush (si, sourceSeq)
- then (true,
- enter (si, sourceSeq))
- else (false,
- Push.Skip si :: sourceSeq)
- | Leave si =>
- (case sourceSeq of
- [] =>
- Error.bug "unmatched Leave"
- | p :: sourceSeq' =>
- let
- val (keep, isOk) =
- case p of
- Push.Enter
- (InfoNode.T
- {index, ...}) =>
- (true,
- index = sourceInfoIndex si)
- | Push.Skip si' =>
- (false,
- SourceInfo.equals (si, si'))
- in
- if isOk
- 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 {args, bytesAllocated, enters, kind, label, leaves,
+ sourceSeq, statements} =
+ forward {args = args,
+ kind = kind,
+ label = label,
+ sourceSeq = sourceSeq,
+ statements = statements}
+ val {args, kind, label, statements, ...} =
+ maybeSplit {args = args,
+ bytesAllocated = bytesAllocated,
+ enters = enters,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ maybe = bytesAllocated > 0,
+ sourceSeq = sourceSeq,
+ statements = statements}
val _ =
Transfer.foreachLabel
(transfer, fn l => goto (l, sourceSeq))
- val npai =
- case transfer of
- Transfer.CCall {func, ...} =>
- CFunction.needsProfileAllocIndex func
- | _ => false
(* Record the call for the call graph. *)
val _ =
case transfer of
@@ -469,18 +559,10 @@
fn InfoNode.T {node, ...} =>
List.push (#callers (funcInfo func), node))
| _ => ()
- 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,
sourceSeq = Push.toSources sourceSeq,
statements = statements,
transfer = transfer}
1.26 +266 -82 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- rssa.fun 20 Dec 2002 18:29:42 -0000 1.25
+++ rssa.fun 2 Jan 2003 17:45:15 -0000 1.26
@@ -157,6 +157,8 @@
Bind of {isMutable: bool,
oper: Operand.t,
var: Var.t}
+ | HandlerPop of Label.t (* the label is redundant, but useful *)
+ | HandlerPush of Label.t
| Move of {dst: Operand.t,
src: Operand.t}
| Object of {dst: Var.t,
@@ -168,7 +170,7 @@
| PrimApp of {args: Operand.t vector,
dst: (Var.t * Type.t) option,
prim: Prim.t}
- | Profile of ProfileStatement.t
+ | Profile of ProfileExp.t
| ProfileLabel of ProfileLabel.t
| SetExnStackLocal
| SetExnStackSlot
@@ -188,6 +190,8 @@
case s of
Bind {oper, var, ...} =>
def (var, Operand.ty oper, useOperand (oper, a))
+ | HandlerPop _ => a
+ | HandlerPush _ => a
| Move {dst, src} => useOperand (src, useOperand (dst, a))
| Object {dst, stores, ty, ...} =>
Vector.fold (stores, def (dst, ty, a),
@@ -231,6 +235,8 @@
fn Bind {oper, var, ...} =>
seq [Var.layout var, constrain (Operand.ty oper),
str " = ", Operand.layout oper]
+ | HandlerPop l => seq [str "HandlerPop ", Label.layout l]
+ | HandlerPush l => seq [str "HandlerPush ", Label.layout l]
| Move {dst, src} =>
mayAlign [Operand.layout dst,
seq [str " = ", Operand.layout src]]
@@ -259,14 +265,17 @@
mayAlign [seq [Var.layout x, constrain t],
seq [str " = ", rest]]
end
- | Profile p => ProfileStatement.layout p
- | ProfileLabel l => seq [str "ProfileLabel ", ProfileLabel.layout l]
+ | Profile e => ProfileExp.layout e
+ | ProfileLabel p =>
+ seq [str "ProfileLabel ", ProfileLabel.layout p]
| SetExnStackLocal => str "SetExnStackLocal"
| SetExnStackSlot => str "SetExnStackSlot "
| SetHandler l => seq [str "SetHandler ", Label.layout l]
| SetSlotExnStack => str "SetSlotExnStack "
end
+ val toString = Layout.toString o layout
+
fun clear (s: t) =
foreachDef (s, Var.clear o #1)
end
@@ -283,8 +292,8 @@
| CCall of {args: Operand.t vector,
func: CFunction.t,
return: Label.t option}
- | Call of {func: Func.t,
- args: Operand.t vector,
+ | Call of {args: Operand.t vector,
+ func: Func.t,
return: Return.t}
| Goto of {dst: Label.t,
args: Operand.t vector}
@@ -310,29 +319,10 @@
record [("args", Vector.layout Operand.layout args),
("func", CFunction.layout func),
("return", Option.layout Label.layout return)]]
- | Call {args, func, return, ...} =>
- let
- val call = seq [Func.layout func, str " ",
- Vector.layout Operand.layout args]
- val call =
- case return of
- Return.Dead => seq [str "Dead ", call]
- | Return.HandleOnly => seq [str "HandleOnly ", call]
- | Return.Tail => call
- | Return.NonTail {cont, handler} =>
- let
- val call =
- seq [Label.layout cont, str " ", paren call]
- in
- case handler of
- Handler.CallerHandler => call
- | Handler.Handle l =>
- seq [call, str " handle ", Label.layout l]
- | Handler.None => seq [call, str " None"]
- end
- in
- call
- end
+ | Call {args, func, return} =>
+ seq [Func.layout func, str " ",
+ Vector.layout Operand.layout args,
+ str " ", Return.layout return]
| Goto {dst, args} =>
seq [Label.layout dst, str " ",
Vector.layout Operand.layout args]
@@ -426,7 +416,7 @@
structure Kind =
struct
datatype t =
- Cont of {handler: Label.t option}
+ Cont of {handler: Handler.t}
| CReturn of {func: CFunction.t}
| Handler
| Jump
@@ -438,7 +428,7 @@
case k of
Cont {handler} =>
seq [str "Cont ",
- record [("handler", Option.layout Label.layout handler)]]
+ record [("handler", Handler.layout handler)]]
| CReturn {func} =>
seq [str "CReturn ",
record [("func", CFunction.layout func)]]
@@ -450,7 +440,8 @@
case k of
Cont _ => true
| CReturn {func = CFunction.T {mayGC, ...}, ...} => mayGC
- | _ => false
+ | Handler => true
+ | Jump => false
end
local
@@ -683,6 +674,213 @@
; output (str "\nFunctions:")
; List.foreach (functions, fn f => Function.layouts (f, output))
end
+
+ structure ExnStack =
+ struct
+ structure ZPoint =
+ struct
+ datatype t = Caller | Me
+
+ val equals: t * t -> bool = op =
+
+ val toString =
+ fn Caller => "Caller"
+ | Me => "Me"
+
+ val layout = Layout.str o toString
+ end
+
+ structure L = FlatLattice (structure Point = ZPoint)
+ open L
+ structure Point = ZPoint
+
+ val me = point Point.Me
+ val caller = point Point.Caller
+ end
+
+ structure HandlerLat = FlatLattice (structure Point = Label)
+
+ structure HandlerInfo =
+ struct
+ datatype t = T of {block: Block.t,
+ global: ExnStack.t,
+ handler: HandlerLat.t,
+ slot: ExnStack.t,
+ visited: bool ref}
+
+ fun new (b: Block.t): t =
+ T {block = b,
+ global = ExnStack.new (),
+ handler = HandlerLat.new (),
+ slot = ExnStack.new (),
+ visited = ref false}
+
+ fun layout (T {global, handler, slot, ...}) =
+ Layout.record [("global", ExnStack.layout global),
+ ("slot", ExnStack.layout slot),
+ ("handler", HandlerLat.layout handler)]
+ end
+
+ fun checkHandlers (T {functions, ...}) =
+ let
+ fun checkFunction (f: Function.t): unit =
+ let
+ val {name, start, blocks, ...} = Function.dest f
+ val {get = labelInfo: Label.t -> HandlerInfo.t,
+ rem = remLabelInfo,
+ set = setLabelInfo} =
+ Property.getSetOnce
+ (Label.plist, Property.initRaise ("info", Label.layout))
+ val _ =
+ Vector.foreach
+ (blocks, fn b =>
+ setLabelInfo (Block.label b, HandlerInfo.new b))
+ (* Do a DFS of the control-flow graph. *)
+ fun visitLabel l = visitInfo (labelInfo l)
+ and visitInfo
+ (hi as HandlerInfo.T {block, global, handler, slot,
+ visited, ...}): unit =
+ if !visited
+ then ()
+ else
+ let
+ val _ = visited := true
+ val Block.T {label, statements, transfer, ...} = block
+ datatype z = datatype ExnStack.t
+ datatype z = datatype Statement.t
+ val {global, handler, slot} =
+ Vector.fold
+ (statements,
+ {global = global, handler = handler, slot = slot},
+ fn (s, {global, handler, slot}) =>
+ case s of
+ SetExnStackLocal => {global = ExnStack.me,
+ handler = handler,
+ slot = slot}
+ | SetExnStackSlot => {global = slot,
+ handler = handler,
+ slot = slot}
+ | SetSlotExnStack => {global = global,
+ handler = handler,
+ slot = slot}
+ | SetHandler l => {global = global,
+ handler = HandlerLat.point l,
+ slot = slot}
+ | _ => {global = global,
+ handler = handler,
+ slot = slot})
+ fun fail msg =
+ (Control.message
+ (Control.Silent, fn () =>
+ let open Layout
+ in align
+ [str "before: ", HandlerInfo.layout hi,
+ str "block: ", Block.layout block,
+ seq [str "after: ",
+ Layout.record
+ [("global", ExnStack.layout global),
+ ("slot", ExnStack.layout slot),
+ ("handler",
+ HandlerLat.layout handler)]],
+ Vector.layout
+ (fn Block.T {label, ...} =>
+ seq [Label.layout label,
+ str " ",
+ HandlerInfo.layout (labelInfo label)])
+ blocks]
+ end)
+ ; Error.bug (concat ["handler mismatch at ", msg]))
+ fun assert (msg, f) =
+ if f
+ then ()
+ else fail msg
+ fun goto (l: Label.t): unit =
+ let
+ val HandlerInfo.T {global = g, handler = h,
+ slot = s, ...} =
+ labelInfo l
+ val _ =
+ assert ("goto",
+ ExnStack.<= (global, g)
+ andalso ExnStack.<= (slot, s)
+ andalso HandlerLat.<= (handler, h))
+ in
+ visitLabel l
+ end
+ fun tail name =
+ assert (name,
+ ExnStack.forcePoint
+ (global, ExnStack.Point.Caller))
+ datatype z = datatype Transfer.t
+ in
+ case transfer of
+ Arith {overflow, success, ...} =>
+ (goto overflow; goto success)
+ | CCall {return, ...} => Option.app (return, goto)
+ | Call {func, return, ...} =>
+ assert
+ ("return",
+ let
+ datatype z = datatype Return.t
+ in
+ case (return) of
+ Dead => true
+ | NonTail {handler = h, ...} =>
+ (case h of
+ Handler.Caller =>
+ ExnStack.forcePoint
+ (global, ExnStack.Point.Caller)
+ | Handler.Dead => true
+ | Handler.Handle l =>
+ let
+ val res =
+ ExnStack.forcePoint
+ (global,
+ ExnStack.Point.Me)
+ andalso
+ HandlerLat.forcePoint
+ (handler, l)
+ val _ = goto l
+ in
+ res
+ end)
+ | Tail => true
+ end)
+ | Goto {dst, ...} => goto dst
+ | Raise _ => tail "raise"
+ | Return _ => tail "return"
+ | Switch s => Switch.foreachLabel (s, goto)
+ end
+ val info as HandlerInfo.T {global, ...} = labelInfo start
+ val _ = ExnStack.forcePoint (global, ExnStack.Point.Caller)
+ val _ = visitInfo info
+ val _ =
+ Control.diagnostics
+ (fn display =>
+ let
+ open Layout
+ val _ =
+ display (seq [str "checkHandlers ",
+ Func.layout name])
+ val _ =
+ Vector.foreach
+ (blocks, fn Block.T {label, ...} =>
+ display (seq
+ [Label.layout label,
+ str " ",
+ HandlerInfo.layout (labelInfo label)]))
+ in
+ ()
+ end)
+ val _ = Vector.foreach (blocks, fn b =>
+ remLabelInfo (Block.label b))
+ in
+ ()
+ end
+ val _ = List.foreach (functions, checkFunction)
+ in
+ ()
+ end
fun checkScopes (program as T {functions, main, ...}): unit =
let
@@ -905,6 +1103,8 @@
in
case s of
Bind {oper, ...} => (checkOperand oper; true)
+ | HandlerPop _ => true
+ | HandlerPush _ => true
| Move {dst, src} =>
(checkOperand dst
; checkOperand src
@@ -946,12 +1146,26 @@
| _ => false)
end
fun labelIsNullaryJump l = goto {dst = l, args = Vector.new0 ()}
+ fun tailIsOk (caller: Type.t vector option,
+ callee: Type.t vector option): bool =
+ case (caller, callee) of
+ (_, NONE) => true
+ | (SOME ts, SOME ts') => Vector.equals (ts, ts', Type.equals)
+ | _ => false
+ fun nonTailIsOk (formals: (Var.t * Type.t) vector,
+ returns: Type.t vector option): bool =
+ case returns of
+ NONE => true
+ | SOME ts =>
+ Vector.equals (formals, ts, fn ((_, t), t') =>
+ Type.equals (t, t'))
fun callIsOk {args, func, raises, return, returns} =
let
val Function.T {args = formals,
raises = raises',
returns = returns', ...} =
funcInfo func
+
in
Vector.equals (args, formals, fn (z, (_, t)) =>
Type.equals (t, Operand.ty z))
@@ -960,71 +1174,41 @@
Return.Dead =>
Option.isNone raises'
andalso Option.isNone returns'
- | Return.HandleOnly =>
- Option.isNone returns'
- andalso
- (case (raises, raises') of
- (_, NONE) => true
- | (SOME ts, SOME ts') =>
- Vector.equals (ts, ts', Type.equals)
- | _ => false)
- | Return.NonTail {cont, handler = h} =>
+ | Return.NonTail {cont, handler} =>
let
- val Block.T {args = contArgs, kind = contKind, ...} =
+ val Block.T {args = cArgs, kind = cKind, ...} =
labelBlock cont
in
- (case returns' of
- NONE => true
- | SOME ts' =>
- Vector.equals
- (contArgs, ts', fn ((_, t), t') =>
- Type.equals (t, t')))
- andalso
- (case contKind of
- Kind.Cont {handler = h'} =>
- (case (h, h') of
- (Handler.CallerHandler, NONE) =>
- true
- | (Handler.None, NONE) =>
- true
- | (Handler.Handle l, SOME l') =>
- Label.equals (l, l')
- andalso
+ nonTailIsOk (cArgs, returns')
+ andalso
+ (case cKind of
+ Kind.Cont {handler = h} =>
+ Handler.equals (handler, h)
+ andalso
+ (case h of
+ Handler.Caller =>
+ tailIsOk (raises, raises')
+ | Handler.Dead => true
+ | Handler.Handle l =>
let
val Block.T {args = hArgs,
- kind = hKind,
- ...} =
+ kind = hKind, ...} =
labelBlock l
in
+ nonTailIsOk (hArgs, raises')
+ andalso
(case hKind of
Kind.Handler => true
| _ => false)
- andalso
- (case raises' of
- NONE => true
- | SOME ts =>
- Vector.equals
- (ts, hArgs,
- fn (t, (_, t')) =>
- Type.equals (t, t')))
- end
- | _ => false)
+ end)
| _ => false)
end
| Return.Tail =>
- (case (returns, returns') of
- (_, NONE) => true
- | (SOME ts, SOME ts') =>
- Vector.equals (ts, ts', Type.equals)
- | _ => false)
- andalso
- (case (raises, raises') of
- (_, NONE) => true
- | (SOME ts, SOME ts') =>
- Vector.equals (ts, ts', Type.equals)
- | _ => false))
+ tailIsOk (raises, raises')
+ andalso tailIsOk (returns, returns'))
end
- fun checkFunction (Function.T {args, blocks, raises, returns, start,
+
+ fun checkFunction (Function.T {args, blocks, raises, returns, start,
...}) =
let
val _ = Vector.foreach (args, setVarType)
1.22 +13 -35 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- rssa.sig 20 Dec 2002 18:29:42 -0000 1.21
+++ rssa.sig 2 Jan 2003 17:45:15 -0000 1.22
@@ -14,38 +14,12 @@
structure Const: CONST
structure Func: HASH_ID
- structure Handler:
- sig
- datatype t =
- CallerHandler
- | None
- | Handle of Label.t (* label must be of Handler kind *)
-
- val foreachLabel: t * (Label.t -> unit) -> unit
- 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 =
- Dead
- | HandleOnly
- | NonTail of {cont: Label.t, (* label must be of Cont kind *)
- handler: Handler.t} (* must agree with the handler
- * associated with the cont. *)
- | Tail
-
- val foldLabel: t * 'a * (Label.t * 'a -> 'a) -> 'a
- val foreachLabel: t * (Label.t -> unit) -> unit
- end
+ structure Handler: HANDLER
+ sharing Handler.Label = Label
+ structure ProfileExp: PROFILE_EXP
+ sharing ProfileExp.SourceInfo = SourceInfo
+ structure Return: RETURN
+ sharing Return.Handler = Handler
structure Var: VAR
end
@@ -106,6 +80,8 @@
Bind of {isMutable: bool,
oper: Operand.t,
var: Var.t}
+ | HandlerPop of Label.t (* the label is redundant, but useful *)
+ | HandlerPush of Label.t
| Move of {dst: Operand.t,
src: Operand.t}
| Object of {dst: Var.t,
@@ -118,7 +94,7 @@
| PrimApp of {args: Operand.t vector,
dst: (Var.t * Type.t) option,
prim: Prim.t}
- | Profile of ProfileStatement.t
+ | Profile of ProfileExp.t
| ProfileLabel of ProfileLabel.t
| SetExnStackLocal
| SetExnStackSlot
@@ -136,8 +112,9 @@
val foldUse: t * 'a * (Var.t * 'a -> 'a) -> 'a
val foreachUse: t * (Var.t -> unit) -> unit
val layout: t -> Layout.t
+ val toString: t -> string
end
-
+
structure Transfer:
sig
datatype t =
@@ -188,7 +165,7 @@
structure Kind:
sig
datatype t =
- Cont of {handler: Label.t option}
+ Cont of {handler: Handler.t}
| CReturn of {func: CFunction.t}
| Handler
| Jump
@@ -248,6 +225,7 @@
objectTypes: ObjectType.t vector}
val clear: t -> unit
+ val checkHandlers: t -> unit
val handlesSignals: t -> bool
val layouts: t * (Layout.t -> unit) -> unit
val typeCheck: t -> unit
1.9 +6 -8 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- runtime.fun 10 Dec 2002 21:45:48 -0000 1.8
+++ runtime.fun 2 Jan 2003 17:45:15 -0000 1.9
@@ -19,11 +19,11 @@
CanHandle
| CardMap
| CurrentThread
+ | ExnStack
| Frontier
| Limit
| LimitPlusSlop
| MaxFrameSize
- | ProfileAllocIndex
| SignalIsPending
| StackBottom
| StackLimit
@@ -35,11 +35,11 @@
fn CanHandle => Type.int
| CardMap => Type.pointer
| CurrentThread => Type.pointer
+ | ExnStack => Type.word
| Frontier => Type.pointer
| Limit => Type.pointer
| LimitPlusSlop => Type.pointer
| MaxFrameSize => Type.word
- | ProfileAllocIndex => Type.word
| SignalIsPending => Type.int
| StackBottom => Type.pointer
| StackLimit => Type.pointer
@@ -52,15 +52,14 @@
val limitOffset: int ref = ref 0
val limitPlusSlopOffset: int ref = ref 0
val maxFrameSizeOffset: int ref = ref 0
- val profileAllocIndexOffset: int ref = ref 0
val signalIsPendingOffset: int ref = ref 0
val stackBottomOffset: int ref = ref 0
val stackLimitOffset: int ref = ref 0
val stackTopOffset: int ref = ref 0
fun setOffsets {canHandle, cardMap, currentThread, frontier, limit,
- limitPlusSlop, maxFrameSize, profileAllocIndex,
- signalIsPending, stackBottom, stackLimit, stackTop} =
+ limitPlusSlop, maxFrameSize, signalIsPending, stackBottom,
+ stackLimit, stackTop} =
(canHandleOffset := canHandle
; cardMapOffset := cardMap
; currentThreadOffset := currentThread
@@ -68,7 +67,6 @@
; limitOffset := limit
; limitPlusSlopOffset := limitPlusSlop
; maxFrameSizeOffset := maxFrameSize
- ; profileAllocIndexOffset := profileAllocIndex
; signalIsPendingOffset := signalIsPending
; stackBottomOffset := stackBottom
; stackLimitOffset := stackLimit
@@ -78,11 +76,11 @@
fn CanHandle => !canHandleOffset
| CardMap => !cardMapOffset
| CurrentThread => !currentThreadOffset
+ | ExnStack => Error.bug "exn stack offset not defined"
| Frontier => !frontierOffset
| Limit => !limitOffset
| LimitPlusSlop => !limitPlusSlopOffset
| MaxFrameSize => !maxFrameSizeOffset
- | ProfileAllocIndex => !profileAllocIndexOffset
| SignalIsPending => !signalIsPendingOffset
| StackBottom => !stackBottomOffset
| StackLimit => !stackLimitOffset
@@ -92,11 +90,11 @@
fn CanHandle => "CanHandle"
| CardMap => "CardMap"
| CurrentThread => "CurrentThread"
+ | ExnStack => "ExnStack"
| Frontier => "Frontier"
| Limit => "Limit"
| LimitPlusSlop => "LimitPlusSlop"
| MaxFrameSize => "MaxFrameSize"
- | ProfileAllocIndex => "ProfileAllocIndex"
| SignalIsPending => "SignalIsPending"
| StackBottom => "StackBottom"
| StackLimit => "StackLimit"
1.18 +1 -2 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- runtime.sig 10 Dec 2002 21:45:48 -0000 1.17
+++ runtime.sig 2 Jan 2003 17:45:15 -0000 1.18
@@ -25,11 +25,11 @@
CanHandle
| CardMap
| CurrentThread
+ | ExnStack
| Frontier (* The place where the next object is allocated. *)
| Limit (* frontier + heapSize - LIMIT_SLOP *)
| LimitPlusSlop (* frontier + heapSize *)
| MaxFrameSize
- | ProfileAllocIndex
| SignalIsPending
| StackBottom
| StackLimit (* Must have StackTop <= StackLimit *)
@@ -45,7 +45,6 @@
limit: int,
limitPlusSlop: int,
maxFrameSize: int,
- profileAllocIndex: int,
signalIsPending: int,
stackBottom: int,
stackLimit: int,
1.32 +30 -49 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.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- ssa-to-rssa.fun 20 Dec 2002 18:29:42 -0000 1.31
+++ ssa-to-rssa.fun 2 Jan 2003 17:45:15 -0000 1.32
@@ -49,7 +49,6 @@
modifiesFrontier = true,
modifiesStackTop = false,
name = name,
- needsProfileAllocIndex = true,
returnTy = SOME Type.pointer}
in
val intInfAdd = make ("IntInf_do_add", 2)
@@ -84,7 +83,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyCurrentThread",
- needsProfileAllocIndex = true,
returnTy = NONE}
val copyThread =
@@ -95,7 +93,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyThread",
- needsProfileAllocIndex = true,
returnTy = SOME Type.pointer}
val exit =
@@ -106,7 +103,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "MLton_exit",
- needsProfileAllocIndex = false,
returnTy = NONE}
val gcArrayAllocate =
@@ -117,7 +113,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_arrayAllocate",
- needsProfileAllocIndex = true,
returnTy = SOME Type.pointer}
local
@@ -129,7 +124,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = name,
- needsProfileAllocIndex = false,
returnTy = NONE}
in
val pack = make "GC_pack"
@@ -144,7 +138,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "Thread_switchTo",
- needsProfileAllocIndex = false,
returnTy = NONE}
val worldSave =
@@ -155,7 +148,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_saveWorld",
- needsProfileAllocIndex = false,
returnTy = NONE}
end
@@ -163,7 +155,6 @@
datatype z = datatype Statement.t
datatype z = datatype Transfer.t
-structure ImplementHandlers = ImplementHandlers (structure Ssa = Ssa)
structure Representation = Representation (structure Rssa = Rssa
structure Ssa = Ssa)
local
@@ -174,10 +165,9 @@
structure TyconRep = TyconRep
end
-fun convert (p: S.Program.t): Rssa.Program.t =
+fun convert (program as S.Program.T {functions, globals, main, ...})
+ : Rssa.Program.t =
let
- val program as S.Program.T {datatypes, globals, functions, main} =
- ImplementHandlers.doit p
val {conRep, objectTypes, refRep, toRtype, tupleRep, tyconRep} =
Representation.compute program
val conRep =
@@ -501,7 +491,7 @@
end
val {get = labelInfo: (Label.t ->
{args: (Var.t * S.Type.t) vector,
- cont: (Label.t option * Label.t) list ref,
+ cont: (Handler.t * Label.t) list ref,
handler: Label.t option ref}),
set = setLabelInfo, ...} =
Property.getSetOnce (Label.plist,
@@ -547,22 +537,12 @@
val info as {cont, ...} = labelInfo l
datatype z = datatype Handler.t
in
- case List.peek (!cont, fn (h', _) =>
- case (h, h') of
- (CallerHandler, NONE) => true
- | (None, NONE) => true
- | (Handle l, SOME l') => Label.equals (l, l')
- | _ => false) of
+ case List.peek (!cont, fn (h', _) => Handler.equals (h, h')) of
SOME (_, l) => l
| NONE =>
let
- val handler =
- case h of
- CallerHandler => NONE
- | None => NONE
- | Handle l => SOME l
- val l' = eta (l, Kind.Cont {handler = handler})
- val _ = List.push (cont, (handler, l'))
+ val l' = eta (l, Kind.Cont {handler = h})
+ val _ = List.push (cont, (h, l'))
in
l'
end
@@ -602,20 +582,23 @@
| S.Transfer.Bug => Transfer.bug
| S.Transfer.Call {func, args, return} =>
let
- datatype z = datatype Return.t
- datatype z = datatype Handler.t
+ datatype z = datatype S.Return.t
val return =
case return of
- NonTail {cont, handler} =>
+ Dead => Return.Dead
+ | NonTail {cont, handler} =>
let
- val handler = Handler.map
- (handler, fn handler =>
- labelHandler handler)
+ datatype z = datatype S.Handler.t
+ val handler =
+ case handler of
+ Caller => Handler.Caller
+ | Dead => Handler.Dead
+ | Handle l => Handler.Handle (labelHandler l)
in
- NonTail {cont = labelCont (cont, handler),
- handler = handler}
+ Return.NonTail {cont = labelCont (cont, handler),
+ handler = handler}
end
- | _ => return
+ | Tail => Return.Tail
in
Transfer.Call {func = func,
args = vos args,
@@ -666,13 +649,13 @@
case t of
Type.Char =>
c (Const.fromChar #"\000")
- | Type.CPointer =>
- Error.bug "bogus CPointer"
+ | Type.CPointer => Error.bug "bogus CPointer"
| Type.EnumPointers (ep as {enum, ...}) =>
Operand.Cast (Operand.int 1, t)
+ | Type.ExnStack => Error.bug "bogus ExnStack"
| Type.Int => c (Const.fromInt 0)
| Type.IntInf => SmallIntInf 0wx1
- | Type.Label => Error.bug "bogus Label"
+ | Type.Label _ => Error.bug "bogus Label"
| Type.MemChunk _ => Error.bug "bogus MemChunk"
| Type.Real => c (Const.fromReal "0.0")
| Type.Word => c (Const.fromWord 0w0)
@@ -754,6 +737,10 @@
| ConRep.Tuple rep =>
allocate (args, rep))
| S.Exp.Const c => move (Operand.Const c)
+ | S.Exp.HandlerPop l =>
+ add (Statement.HandlerPop (labelHandler l))
+ | S.Exp.HandlerPush l =>
+ add (Statement.HandlerPush (labelHandler l))
| S.Exp.PrimApp {prim, targs, args, ...} =>
let
fun a i = Vector.sub (args, i)
@@ -1195,7 +1182,7 @@
func = CFunction.worldSave}
| _ => normal ()
end
- | S.Exp.Profile pe => add (Statement.Profile pe)
+ | S.Exp.Profile e => add (Statement.Profile e)
| S.Exp.Select {tuple, offset} =>
let
val TupleRep.T {offsets, ...} =
@@ -1208,11 +1195,6 @@
offset = offset,
ty = ty})
end
- | S.Exp.SetExnStackLocal => add SetExnStackLocal
- | S.Exp.SetExnStackSlot => add SetExnStackSlot
- | S.Exp.SetHandler h =>
- add (SetHandler (labelHandler h))
- | S.Exp.SetSlotExnStack => add SetSlotExnStack
| S.Exp.Tuple ys =>
if 0 = Vector.length ys
then none ()
@@ -1221,7 +1203,6 @@
(case toRtype ty of
NONE => none ()
| SOME _ => move (varOp y))
- | _ => Error.bug "translateStatement saw strange PrimExp"
end
in
loop (Vector.length statements - 1, [], transfer)
@@ -1279,12 +1260,12 @@
args = Vector.new0 (),
statements = globals,
transfer = (S.Transfer.Call
- {func = main,
- args = Vector.new0 (),
+ {args = Vector.new0 (),
+ func = main,
return =
- Return.NonTail
+ S.Return.NonTail
{cont = bug,
- handler = S.Handler.None}})},
+ handler = S.Handler.Caller}})},
S.Block.T
{label = bug,
args = Vector.new0 (),
1.7 +1 -3 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.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ssa-to-rssa.sig 19 Dec 2002 23:43:32 -0000 1.6
+++ ssa-to-rssa.sig 2 Jan 2003 17:45:15 -0000 1.7
@@ -14,11 +14,9 @@
structure Ssa: SSA
sharing Rssa.Const = Ssa.Const
sharing Rssa.Func = Ssa.Func
- 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.ProfileExp = Ssa.ProfileExp
sharing Rssa.SourceInfo = Ssa.SourceInfo
sharing Rssa.Var = Ssa.Var
end
1.22 +2 -2 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.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- closure-convert.fun 19 Dec 2002 23:43:33 -0000 1.21
+++ closure-convert.fun 2 Jan 2003 17:45:15 -0000 1.22
@@ -101,7 +101,7 @@
(globals, fn {var, ty, ...} =>
Dexp.var (var, ty))),
ty = Type.unit (* bogus *)}},
- Ssa.Handler.CallerHandler)
+ Ssa.Handler.Caller)
val {blocks, ...} =
Function.dest
(Ssa.shrinkFunction
@@ -684,7 +684,7 @@
fun addFunc (ac, {args, body, name, returns, sourceInfo}) =
let
val (start, blocks) =
- Dexp.linearize (body, Ssa.Handler.CallerHandler)
+ Dexp.linearize (body, Ssa.Handler.Caller)
val f =
Function.profile
(shrinkFunction
1.40 +10 -12 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.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- c-codegen.fun 19 Dec 2002 23:43:33 -0000 1.39
+++ c-codegen.fun 2 Jan 2003 17:45:16 -0000 1.40
@@ -237,27 +237,25 @@
[C.int (!Control.cardSizeLog2),
C.bool (!Control.markCards),
C.int maxFrameSize,
- magic,
- C.bool (!Control.profile = Control.ProfileAlloc)]
+ magic]
@ additionalMainArgs,
print)
; print "\n"
end
fun declareProfileInfo () =
let
- val ProfileInfo.T {frameSources, labels, sourceSeqs,
- sources} =
+ 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,
+ ; declareArray ("struct GC_sourceLabel", "sourceLabels", labels,
fn (_, {label, sourceSeqsIndex}) =>
concat ["{(pointer)", ProfileLabel.toString label,
", ", C.int sourceSeqsIndex, "}"])
- ; declareArray ("string", "profileSources", sources,
+ ; declareArray ("string", "sources", sources,
C.string o SourceInfo.toString o #2)
; Vector.foreachi (sourceSeqs, fn (i, v) =>
(print (concat ["static int sourceSeq",
@@ -268,10 +266,9 @@
(print (concat [",", C.int i])))
; print "};\n"))
- ; declareArray ("int", "*profileSourceSeqs", sourceSeqs, fn (i, _) =>
+ ; declareArray ("int", "*sourceSeqs", sourceSeqs, fn (i, _) =>
concat ["sourceSeq", Int.toString i])
- ; declareArray ("int", "profileFrameSources", frameSources,
- C.int o #2)
+ ; declareArray ("int", "frameSources", frameSources, C.int o #2)
end
in
print (concat ["#define ", name, "CODEGEN\n\n"])
@@ -407,11 +404,11 @@
CanHandle => "gcState.canHandle"
| CardMap => "gcState.cardMapForMutator"
| CurrentThread => "gcState.currentThread"
+ | ExnStack => "ExnStack"
| Frontier => "frontier"
| Limit => "gcState.limit"
| LimitPlusSlop => "gcState.limitPlusSlop"
| MaxFrameSize => "gcState.maxFrameSize"
- | ProfileAllocIndex => "gcState.profileAllocIndex"
| SignalIsPending => "gcState.signalIsPending"
| StackBottom => "gcState.stackBottom"
| StackLimit => "gcState.stackLimit"
@@ -527,7 +524,7 @@
; print "\t"
; C.move ({dst = operandToString
(Operand.StackOffset {offset = ~Runtime.labelSize,
- ty = Type.label}),
+ ty = Type.label return}),
src = operandToString (Operand.Label return)},
print))
fun copyArgs (args: Operand.t vector): string list * (unit -> unit) =
@@ -618,7 +615,7 @@
creturn (Type.toRuntime (Operand.ty x)),
";\n"]))))
| Kind.Func => ()
- | Kind.Handler {offset, ...} => C.push (~offset, print)
+ | Kind.Handler {frameInfo, ...} => pop frameInfo
| Kind.Jump => ()
val _ =
if 0 = !Control.Native.commented
@@ -868,6 +865,7 @@
; declareRegisters ()
; C.callNoSemi ("ChunkSwitch", [ChunkLabel.toString chunkLabel],
print)
+ ; print "\n"
; Vector.foreach (blocks, fn Block.T {kind, label, ...} =>
if Kind.isEntry kind
then (print "case "
1.36 +10 -7 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.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- x86-generate-transfers.fun 20 Dec 2002 18:29:43 -0000 1.35
+++ x86-generate-transfers.fun 2 Jan 2003 17:45:17 -0000 1.36
@@ -582,8 +582,8 @@
(* entry from far assumptions *)
(farEntry AppendList.empty))
| Cont {label,
- frameInfo as FrameInfo.T {size,
- frameLayoutsIndex},
+ frameInfo = FrameInfo.T {size,
+ frameLayoutsIndex},
...}
=>
AppendList.append
@@ -610,13 +610,16 @@
size = pointerSize},
profileStackTopCommit)
end)))
- | Handler {label,
- offset,
+ | Handler {frameInfo = (FrameInfo.T
+ {frameLayoutsIndex, size}),
+ label,
...}
=> AppendList.append
(AppendList.fromList
[Assembly.pseudoop_p2align
(Immediate.const_int 4, NONE, NONE),
+ Assembly.pseudoop_long
+ [Immediate.const_int frameLayoutsIndex],
Assembly.label label],
(* entry from far assumptions *)
(farEntry
@@ -624,7 +627,7 @@
val stackTop
= x86MLton.gcState_stackTopContentsOperand ()
val bytes
- = x86.Operand.immediate_const_int (~ offset)
+ = x86.Operand.immediate_const_int (~ size)
in
AppendList.cons
((* stackTop += bytes *)
@@ -1036,9 +1039,9 @@
src = exnStack,
size = pointerSize}]))
(AppendList.single
- (* jmp *(stackTop) *)
+ (* jmp *(stackTop - WORD_SIZE) *)
(x86.Assembly.instruction_jmp
- {target = stackTopDeref,
+ {target = x86MLton.gcState_stackTopMinusWordDerefOperand (),
absolute = true})))
end
| CCall {args, dstsize,
1.11 +0 -3 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-mlton-basic.fun 16 Dec 2002 19:28:06 -0000 1.10
+++ x86-mlton-basic.fun 2 Jan 2003 17:45:18 -0000 1.11
@@ -371,9 +371,6 @@
val (_, _, gcState_maxFrameSizeContentsOperand) =
make (Field.MaxFrameSize, pointerSize, Classes.GCState)
- val (_, _, gcState_profileAllocIndexContentsOperand) =
- make (Field.ProfileAllocIndex, wordSize, Classes.GCState)
-
val (_, _, gcState_signalIsPendingContentsOperand) =
make (Field.SignalIsPending, wordSize, Classes.GCState)
1.20 +0 -1 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- x86-mlton-basic.sig 16 Dec 2002 19:28:06 -0000 1.19
+++ x86-mlton-basic.sig 2 Jan 2003 17:45:18 -0000 1.20
@@ -114,7 +114,6 @@
val gcState_limitContentsOperand: unit -> x86.Operand.t
val gcState_limitPlusSlopContentsOperand: unit -> x86.Operand.t
val gcState_maxFrameSizeContentsOperand: unit -> x86.Operand.t
- val gcState_profileAllocIndexContentsOperand: unit -> x86.Operand.t
val gcState_signalIsPendingContentsOperand: unit -> x86.Operand.t
val gcState_stackBottomContents: unit -> x86.MemLoc.t
val gcState_stackBottomContentsOperand: unit -> x86.Operand.t
1.15 +6 -4 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.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- x86-pseudo.sig 20 Dec 2002 18:29:44 -0000 1.14
+++ x86-pseudo.sig 2 Jan 2003 17:45:18 -0000 1.15
@@ -389,7 +389,9 @@
structure FrameInfo:
sig
- type t
+ datatype t = T of {size: int,
+ frameLayoutsIndex: int}
+
val frameInfo : {size: int,
frameLayoutsIndex: int} -> t
end
@@ -407,9 +409,9 @@
label: Label.t} -> t
val func: {label: Label.t,
live: MemLocSet.t} -> t
- val handler: {label: Label.t,
- live: MemLocSet.t,
- offset: int} -> t
+ val handler: {frameInfo: FrameInfo.t,
+ label: Label.t,
+ live: MemLocSet.t} -> t
val jump: {label: Label.t} -> t
val label: t -> Label.t
end
1.36 +8 -7 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.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- x86-translate.fun 20 Dec 2002 18:29:45 -0000 1.35
+++ x86-translate.fun 2 Jan 2003 17:45:18 -0000 1.36
@@ -167,12 +167,12 @@
CanHandle => gcState_canHandleContentsOperand ()
| CardMap => gcState_cardMapContentsOperand ()
| CurrentThread => gcState_currentThreadContentsOperand ()
+ | ExnStack =>
+ gcState_currentThread_exnStackContentsOperand ()
| Frontier => gcState_frontierContentsOperand ()
| Limit => gcState_limitContentsOperand ()
| LimitPlusSlop => gcState_limitPlusSlopContentsOperand ()
| MaxFrameSize => gcState_maxFrameSizeContentsOperand ()
- | ProfileAllocIndex =>
- gcState_profileAllocIndexContentsOperand ()
| SignalIsPending =>
gcState_signalIsPendingContentsOperand ()
| StackBottom => gcState_stackBottomContentsOperand ()
@@ -264,19 +264,20 @@
statements = [],
transfer = NONE})
end
- | Kind.Handler {offset, ...}
+ | Kind.Handler {frameInfo, ...}
=> let
in
AppendList.single
(x86.Block.T'
- {entry = SOME (x86.Entry.handler {label = label,
- live = x86.MemLocSet.empty,
- offset = offset}),
+ {entry = SOME (x86.Entry.handler
+ {frameInfo = frameInfoToX86 frameInfo,
+ label = label,
+ live = x86.MemLocSet.empty}),
statements = [],
transfer = NONE})
end
| Kind.CReturn {dst, frameInfo, func}
- => let
+ => let
val dst = Option.map (dst, Operand.convert)
in
x86MLton.creturn
1.34 +5 -5 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- x86.fun 20 Dec 2002 18:29:45 -0000 1.33
+++ x86.fun 2 Jan 2003 17:45:19 -0000 1.34
@@ -3618,9 +3618,9 @@
| Cont of {label: Label.t,
live: MemLocSet.t,
frameInfo: FrameInfo.t}
- | Handler of {label: Label.t,
- live: MemLocSet.t,
- offset: int}
+ | Handler of {frameInfo: FrameInfo.t,
+ label: Label.t,
+ live: MemLocSet.t}
| CReturn of {dst: (Operand.t * Size.t) option,
frameInfo: FrameInfo.t option,
func: CFunction.t,
@@ -3652,7 +3652,7 @@
", "),
"] ",
FrameInfo.toString frameInfo]
- | Handler {label, live, offset}
+ | Handler {frameInfo, label, live}
=> concat ["Handler::",
Label.toString label,
" [",
@@ -3663,7 +3663,7 @@
fn (memloc, l) => (MemLoc.toString memloc)::l),
", "),
"] (",
- Int.toString offset,
+ FrameInfo.toString frameInfo,
")"]
| CReturn {dst, frameInfo, func, label}
=> concat ["CReturn::",
1.24 +6 -6 mlton/mlton/codegen/x86-codegen/x86.sig
Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- x86.sig 20 Dec 2002 18:29:45 -0000 1.23
+++ x86.sig 2 Jan 2003 17:45:19 -0000 1.24
@@ -1031,9 +1031,9 @@
| Cont of {label: Label.t,
live: MemLocSet.t,
frameInfo: FrameInfo.t}
- | Handler of {label: Label.t,
- live: MemLocSet.t,
- offset: int}
+ | Handler of {frameInfo: FrameInfo.t,
+ label: Label.t,
+ live: MemLocSet.t}
| CReturn of {dst: (Operand.t * Size.t) option,
frameInfo: FrameInfo.t option,
func: Runtime.CFunction.t,
@@ -1048,9 +1048,9 @@
label: Label.t} -> t
val func : {label: Label.t,
live: MemLocSet.t} -> t
- val handler : {label: Label.t,
- live: MemLocSet.t,
- offset: int} -> t
+ val handler : {frameInfo: FrameInfo.t,
+ label: Label.t,
+ live: MemLocSet.t} -> t
val isFunc : t -> bool
val isNear : t -> bool
val jump : {label: Label.t} -> t
1.16 +0 -1 mlton/mlton/core-ml/lookup-constant.fun
Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- lookup-constant.fun 24 Nov 2002 01:19:44 -0000 1.15
+++ lookup-constant.fun 2 Jan 2003 17:45:19 -0000 1.16
@@ -128,7 +128,6 @@
"limit",
"limitPlusSlop",
"maxFrameSize",
- "profileAllocIndex",
"signalIsPending",
"stackBottom",
"stackLimit",
1.44 +0 -1 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- compile.sml 19 Dec 2002 23:43:35 -0000 1.43
+++ compile.sml 2 Jan 2003 17:45:19 -0000 1.44
@@ -380,7 +380,6 @@
limit = get "limit",
limitPlusSlop = get "limitPlusSlop",
maxFrameSize = get "maxFrameSize",
- profileAllocIndex = get "profileAllocIndex",
signalIsPending = get "signalIsPending",
stackBottom = get "stackBottom",
stackLimit = get "stackLimit",
1.105 +4 -4 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.104
retrieving revision 1.105
diff -u -r1.104 -r1.105
--- main.sml 29 Dec 2002 01:23:00 -0000 1.104
+++ main.sml 2 Jan 2003 17:45:19 -0000 1.105
@@ -344,16 +344,16 @@
val _ = if not (!Native.native) andalso !Native.IEEEFP
then usage "can't use -native false and -ieee-fp true"
else ()
- val _ = if not (!Native.native) andalso !profile <> ProfileNone
- then usage "can't profile with -native false"
+ val _ = if not (!Native.native) andalso !profile = ProfileTime
+ then usage "can't use -profile time with -native false"
else ()
val _ =
if !keepDot andalso List.isEmpty (!keepPasses)
then keepSSA := true
else ()
val _ =
- if !hostType = Cygwin andalso !profile <> ProfileNone
- then usage "profiling not allowed on Cygwin"
+ if !hostType = Cygwin andalso !profile = ProfileTime
+ then usage "can't use -profile time on Cygwin"
else ()
fun printVersion () = print (concat [version, " ", build, "\n"])
in
1.18 +19 -43 mlton/mlton/ssa/analyze.fun
Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- analyze.fun 19 Dec 2002 23:43:35 -0000 1.17
+++ analyze.fun 2 Jan 2003 17:45:20 -0000 1.18
@@ -72,40 +72,29 @@
let
val {args = formals, raises, returns} = func f
val _ = coerces (values args, formals)
+ fun noHandler () =
+ case (raises, shouldRaises) of
+ (NONE, NONE) => ()
+ | (NONE, SOME _) => ()
+ | (SOME _, NONE) =>
+ Error.bug "raise mismatch"
+ | (SOME vs, SOME vs') => coerces (vs, vs')
+ datatype z = datatype Return.t
in
case return of
- Return.Dead =>
+ Dead =>
if isSome returns orelse isSome raises
then Error.bug "return mismatch at Dead"
else ()
- | Return.HandleOnly =>
- let
- val _ =
- case (raises, shouldRaises) of
- (NONE, NONE) => ()
- | (NONE, SOME _) => ()
- | (SOME _, NONE) =>
- Error.bug "raise mismatch at HandleOnly"
- | (SOME vs, SOME vs') => coerces (vs, vs')
- in
- ()
- end
- | Return.NonTail {cont, handler} =>
+ | NonTail {cont, handler} =>
(Option.app (returns, fn vs =>
coerces (vs, labelValues cont))
; (case handler of
- Handler.CallerHandler =>
- let
- val _ =
- case (raises, shouldRaises) of
- (NONE, NONE) => ()
- | (NONE, SOME _) => ()
- | (SOME _, NONE) =>
- Error.bug "raise mismatch at NonTail"
- | (SOME vs, SOME vs') => coerces (vs, vs')
- in
- ()
- end
+ Handler.Caller => noHandler ()
+ | Handler.Dead =>
+ if isSome raises
+ then Error.bug "raise mismatch at nontail"
+ else ()
| Handler.Handle h =>
let
val _ =
@@ -114,20 +103,10 @@
| SOME vs => coerces (vs, labelValues h)
in
()
- end
- | Handler.None =>
- if isSome raises
- then Error.bug "raise mismatch at NonTail"
- else ()))
- | Return.Tail =>
+ end))
+ | Tail =>
let
- val _ =
- case (raises, shouldRaises) of
- (NONE, NONE) => ()
- | (NONE, SOME _) => ()
- | (SOME _, NONE) =>
- Error.bug "raise mismatch at Tail"
- | (SOME vs, SOME vs') => coerces (vs, vs')
+ val _ = noHandler ()
val _ =
case (returns, shouldReturns) of
(NONE, NONE) => ()
@@ -138,6 +117,7 @@
in
()
end
+
end
| Case {test, cases, default, ...} =>
let val test = value test
@@ -225,10 +205,6 @@
select {tuple = value tuple,
offset = offset,
resultType = ty}
- | SetHandler h => unit
- | SetExnStackLocal => unit
- | SetExnStackSlot => unit
- | SetSlotExnStack => unit
| Tuple xs =>
if 1 = Vector.length xs
then Error.bug "unary tuple"
1.11 +4 -5 mlton/mlton/ssa/direct-exp.fun
Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- direct-exp.fun 5 Nov 2002 19:08:07 -0000 1.10
+++ direct-exp.fun 2 Jan 2003 17:45:20 -0000 1.11
@@ -537,12 +537,11 @@
{statements = [],
transfer =
(case h of
- Handler.CallerHandler =>
- Transfer.Raise (Vector.new1 x)
+ Handler.Caller => Transfer.Raise (Vector.new1 x)
+ | Handler.Dead => Error.bug "raise to dead handler"
| Handler.Handle l =>
- Transfer.Goto {dst = l,
- args = Vector.new1 x}
- | Handler.None => Error.bug "raise to None")})
+ Transfer.Goto {args = Vector.new1 x,
+ dst = l})})
| Runtime {args, prim, ty} =>
loops
(args, h, fn xs =>
1.10 +4 -2 mlton/mlton/ssa/direct-exp.sig
Index: direct-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- direct-exp.sig 5 Nov 2002 19:08:07 -0000 1.9
+++ direct-exp.sig 2 Jan 2003 17:45:20 -0000 1.10
@@ -63,8 +63,10 @@
val layout: t -> Layout.t
val lett: {decs: {var: Var.t, exp: t} list,
body: t} -> t
- val linearize: t * Handler.t -> Label.t * Block.t list
- val linearizeGoto: t * Handler.t * Label.t -> Label.t * Block.t list
+ val linearize:
+ t * Return.Handler.t -> Label.t * Block.t list
+ val linearizeGoto:
+ t * Return.Handler.t * Label.t -> Label.t * Block.t list
val name: t * (Var.t -> t) -> t
val primApp: {args: t vector,
prim: Prim.t,
1.11 +3 -4 mlton/mlton/ssa/flatten.fun
Index: flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flatten.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- flatten.fun 19 Dec 2002 23:43:35 -0000 1.10
+++ flatten.fun 2 Jan 2003 17:45:20 -0000 1.11
@@ -169,18 +169,17 @@
in
case return of
Return.Dead => ()
- | Return.HandleOnly => unifyRaises ()
| Return.NonTail {cont, handler} =>
(Option.app
(funcReturns, fn rs =>
Rep.unifys (rs, labelArgs cont))
; case handler of
- Handler.CallerHandler => unifyRaises ()
+ Handler.Caller => unifyRaises ()
+ | Handler.Dead => ()
| Handler.Handle handler =>
Option.app
(funcRaises, fn rs =>
- Rep.unifys (rs, labelArgs handler))
- | Handler.None => ())
+ Rep.unifys (rs, labelArgs handler)))
| Return.Tail => (unifyReturns (); unifyRaises ())
end
| Goto {dst, args} => coerces (args, labelArgs dst)
1.12 +0 -4 mlton/mlton/ssa/inline.fun
Index: inline.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/inline.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- inline.fun 19 Dec 2002 23:43:35 -0000 1.11
+++ inline.fun 2 Jan 2003 17:45:21 -0000 1.12
@@ -28,10 +28,6 @@
| 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
fun expSize (size, max) (doExp, doTransfer) exp =
1.8 +0 -4 mlton/mlton/ssa/introduce-loops.fun
Index: introduce-loops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/introduce-loops.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- introduce-loops.fun 19 Dec 2002 23:43:36 -0000 1.7
+++ introduce-loops.fun 2 Jan 2003 17:45:21 -0000 1.8
@@ -19,13 +19,9 @@
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
1.14 +4 -7 mlton/mlton/ssa/poly-equal.fun
Index: poly-equal.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/poly-equal.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- poly-equal.fun 19 Dec 2002 23:43:36 -0000 1.13
+++ poly-equal.fun 2 Jan 2003 17:45:21 -0000 1.14
@@ -165,8 +165,7 @@
fn ((x, ty), (y, _), de) =>
Dexp.conjoin (de, equal (x, y, ty)))})}}
end))})
- val (start, blocks) =
- Dexp.linearize (body, Handler.CallerHandler)
+ val (start, blocks) = Dexp.linearize (body, Handler.Caller)
val blocks = Vector.fromList blocks
val _ =
newFunction {args = args,
@@ -214,8 +213,7 @@
(Dexp.int 0, length dv1, dv1, dv2)),
ty = Type.bool}))
end
- val (start, blocks) =
- Dexp.linearize (body, Handler.CallerHandler)
+ val (start, blocks) = Dexp.linearize (body, Handler.Caller)
val blocks = Vector.fromList blocks
in
val _ =
@@ -255,8 +253,7 @@
dlen, dv1, dv2)),
ty = Type.bool}))
end
- val (start, blocks) =
- Dexp.linearize (body, Handler.CallerHandler)
+ val (start, blocks) = Dexp.linearize (body, Handler.Caller)
val blocks = Vector.fromList blocks
in
val _ =
@@ -382,7 +379,7 @@
val (start',bs') =
Dexp.linearizeGoto
(equal (arg 0, arg 1, ty),
- Handler.None,
+ Handler.Dead,
l)
in
(finish (las,
1.10 +0 -1 mlton/mlton/ssa/redundant.fun
Index: redundant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/redundant.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- redundant.fun 19 Dec 2002 23:43:36 -0000 1.9
+++ redundant.fun 2 Jan 2003 17:45:21 -0000 1.10
@@ -148,7 +148,6 @@
in
case ret of
Return.Dead => ()
- | Return.HandleOnly => ()
| Return.NonTail {cont, ...} =>
Option.app (return', fn e =>
Eqrel.unify (e, labelInfo cont))
1.22 +11 -13 mlton/mlton/ssa/remove-unused.fun
Index: remove-unused.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/remove-unused.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- remove-unused.fun 19 Dec 2002 23:43:36 -0000 1.21
+++ remove-unused.fun 2 Jan 2003 17:45:21 -0000 1.22
@@ -454,13 +454,12 @@
val (cont, handler)
= case return
of Return.Dead => (None, None)
- | Return.HandleOnly => (None, Caller)
| Return.NonTail {cont, handler}
=> (Some cont,
- case handler
- of Handler.None => None
- | Handler.CallerHandler => Caller
- | Handler.Handle h => Some h)
+ case handler of
+ Handler.Caller => Caller
+ | Handler.Dead => None
+ | Handler.Handle h => Some h)
| Tail => (Caller, Caller)
val fi' = funcInfo func
in
@@ -960,13 +959,12 @@
val (cont, handler)
= case return
of Return.Dead => (None, None)
- | Return.HandleOnly => (None, Caller)
| Return.NonTail {cont, handler}
=> (Some cont,
- case handler
- of Handler.None => None
- | Handler.CallerHandler => Caller
- | Handler.Handle h => Some h)
+ case handler of
+ Handler.Caller => Caller
+ | Handler.Dead => None
+ | Handler.Handle h => Some h)
| Tail => (Caller, Caller)
val cont
= if FuncInfo.mayReturn fi'
@@ -1011,7 +1009,7 @@
val return
= case (cont, handler)
of (None, None) => Return.Dead
- | (None, Caller) => Return.HandleOnly
+ | (None, Caller) => Return.Tail
| (None, Some h)
=> Return.NonTail
{cont = getBugFunc fi,
@@ -1026,11 +1024,11 @@
| (Some c, None)
=> Return.NonTail
{cont = c,
- handler = Handler.None}
+ handler = Handler.Dead}
| (Some c, Caller)
=> Return.NonTail
{cont = c,
- handler = Handler.CallerHandler}
+ handler = Handler.Caller}
| (Some c, Some h)
=> Return.NonTail
{cont = c,
1.13 +7 -5 mlton/mlton/ssa/restore.fun
Index: restore.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/restore.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- restore.fun 19 Dec 2002 23:43:36 -0000 1.12
+++ restore.fun 2 Jan 2003 17:45:21 -0000 1.13
@@ -657,9 +657,10 @@
exp = HandlerPush handlerWrap}),
transfer = Call {func = func,
args = args,
- return = Return.NonTail
- {cont = contWrap,
- handler = Handler.Handle handlerWrap}}}
+ return =
+ Return.NonTail
+ {cont = contWrap,
+ handler = Handler.Handle handlerWrap}}}
val _ = List.push (blocks, callWrapBlock)
in
Goto {dst = callWrap, args = Vector.new0 ()}
@@ -671,8 +672,9 @@
in
case t
of Call {func, args,
- return = Return.NonTail {cont,
- handler = Handler.Handle handler}}
+ return = (Return.NonTail
+ {cont,
+ handler = Handler.Handle handler})}
=> if Vector.length (LabelInfo.phiArgs' (labelInfo handler)) = 0
then default ()
else rewriteNonTailHandle {func = func,
1.26 +3 -3 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- shrink.fun 21 Dec 2002 02:01:31 -0000 1.25
+++ shrink.fun 2 Jan 2003 17:45:21 -0000 1.26
@@ -799,9 +799,9 @@
val i = LabelMeaning.blockIndex m
val isTail =
(case handler of
- Handler.CallerHandler => true
- | Handler.Handle _ => false
- | Handler.None => true)
+ Handler.Caller => true
+ | Handler.Dead => true
+ | Handler.Handle _ => false)
andalso
(case LabelMeaning.aux m of
LabelMeaning.Bug => true
1.4 +2 -1 mlton/mlton/ssa/source-info.fun
Index: source-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/source-info.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- source-info.fun 19 Dec 2002 23:43:36 -0000 1.3
+++ source-info.fun 2 Jan 2003 17:45:21 -0000 1.4
@@ -10,7 +10,8 @@
val equals: t * t -> bool = op =
val hash = String.hash
-
+
+val gc = "<gc>"
val main = "<main>"
val polyEqual = "<poly-equal>"
val unknown = "<unknown>"
1.4 +1 -0 mlton/mlton/ssa/source-info.sig
Index: source-info.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/source-info.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- source-info.sig 19 Dec 2002 23:43:36 -0000 1.3
+++ source-info.sig 2 Jan 2003 17:45:21 -0000 1.4
@@ -12,6 +12,7 @@
type t
val equals: t * t -> bool
+ val gc: t
val fromRegion: Region.t -> t
val hash: t -> word
val isBasis: t -> bool
1.31 +6 -1 mlton/mlton/ssa/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/sources.cm,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- sources.cm 12 Dec 2002 19:35:25 -0000 1.30
+++ sources.cm 2 Jan 2003 17:45:21 -0000 1.31
@@ -7,9 +7,13 @@
*)
Group
+signature HANDLER
+signature PROFILE_EXP
+signature RETURN
signature SOURCE_INFO
signature SSA
-
+
+functor FlatLattice
functor Ssa
is
@@ -56,6 +60,7 @@
n-point-lattice.sig
poly-equal.fun
poly-equal.sig
+profile-exp.sig
redundant.fun
redundant.sig
redundant-tests.fun
1.51 +160 -544 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- ssa-tree.fun 19 Dec 2002 23:43:36 -0000 1.50
+++ ssa-tree.fun 2 Jan 2003 17:45:21 -0000 1.51
@@ -150,6 +150,8 @@
structure ProfileExp =
struct
+ structure SourceInfo = SourceInfo
+
datatype t =
Enter of SourceInfo.t
| Leave of SourceInfo.t
@@ -190,10 +192,6 @@
| Profile of ProfileExp.t
| Select of {tuple: Var.t,
offset: int}
- | SetExnStackLocal
- | SetExnStackSlot
- | SetSlotExnStack
- | SetHandler of Label.t
| Tuple of Var.t vector
| Var of Var.t
@@ -211,10 +209,6 @@
| PrimApp {args, ...} => vs args
| Profile _ => ()
| Select {tuple, ...} => v tuple
- | SetExnStackLocal => ()
- | SetExnStackSlot => ()
- | SetSlotExnStack => ()
- | SetHandler h => j h
| Tuple xs => vs xs
| Var x => v x
end
@@ -236,10 +230,6 @@
| Profile _ => e
| Select {tuple, offset} =>
Select {tuple = fx tuple, offset = offset}
- | SetExnStackLocal => e
- | SetExnStackSlot => e
- | SetHandler h => SetHandler (fl h)
- | SetSlotExnStack => e
| Tuple xs => Tuple (fxs xs)
| Var x => Var (fx x)
end
@@ -271,10 +261,6 @@
| Select {tuple, offset} =>
seq [str "#", Int.layout (offset + 1), str " ",
Var.layout tuple]
- | SetExnStackLocal => str "SetExnStackLocal"
- | SetExnStackSlot => str "SetExnStackSlot"
- | SetHandler h => seq [str "SetHandler ", Label.layout h]
- | SetSlotExnStack => str "SetSlotExnStack"
| Tuple xs => layoutTuple xs
| Var x => Var.layout x
end
@@ -288,10 +274,6 @@
| Profile _ =>
Error.bug "doesn't make sense to ask isFunctional Profile"
| Select _ => true
- | SetExnStackLocal => false
- | SetExnStackSlot => false
- | SetHandler _ => false
- | SetSlotExnStack => false
| Tuple _ => true
| Var _ => true
@@ -304,10 +286,6 @@
| PrimApp {prim,...} => Prim.maySideEffect prim
| Profile _ => false
| Select _ => false
- | SetExnStackLocal => true
- | SetExnStackSlot => true
- | SetHandler _ => true
- | SetSlotExnStack => true
| Tuple _ => false
| Var _ => false
@@ -326,10 +304,6 @@
| (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')
- | (SetSlotExnStack, SetSlotExnStack) => true
| (Tuple xs, Tuple xs') => varsEquals (xs, xs')
| (Var x, Var x') => Var.equals (x, x')
| _ => false
@@ -342,10 +316,6 @@
val primApp = newHash ()
val profile = newHash ()
val select = newHash ()
- val setExnStackLocal = newHash ()
- val setExnStackSlot = newHash ()
- val setHandler = newHash ()
- val setSlotExnStack = newHash ()
val tuple = newHash ()
fun hashVars (xs: Var.t vector, w: Word.t): Word.t =
Vector.fold (xs, w, fn (x, w) => Word.xorb (w, Var.hash x))
@@ -359,10 +329,6 @@
| Profile p => Word.xorb (profile, ProfileExp.hash p)
| Select {tuple, offset} =>
Word.xorb (select, Var.hash tuple + Word.fromInt offset)
- | SetExnStackLocal => setExnStackLocal
- | SetExnStackSlot => setExnStackSlot
- | SetHandler h => Word.xorb (Label.hash h, setHandler)
- | SetSlotExnStack => setSlotExnStack
| Tuple xs => hashVars (xs, tuple)
| Var x => Var.hash x
end
@@ -385,12 +351,8 @@
NONE => Var.layout x
| SOME s => Layout.str s))
| Profile p => ProfileExp.toString p
- | SetExnStackLocal => "SetExnStackLocal"
- | SetExnStackSlot => "SetExnStackSlot"
- | SetSlotExnStack => "SetSlotExnStack"
| Select {tuple, offset} =>
concat ["#", Int.toString (offset + 1), " ", Var.toString tuple]
- | SetHandler h => concat ["SetHandler ", Label.toString h]
| Tuple xs => Var.prettys (xs, global)
| Var x => Var.toString x
@@ -429,16 +391,14 @@
Exp.layout exp]
end
+ val toString = Layout.toString o layout
+
local
fun make (e: Exp.t) =
T {var = NONE,
ty = Type.unit,
exp = e}
in
- val setExnStackLocal = make Exp.SetExnStackLocal
- val setExnStackSlot = make Exp.SetExnStackSlot
- val setSlotExnStack = make Exp.SetSlotExnStack
- fun setHandler h = make (Exp.SetHandler h)
fun handlerPop h = make (Exp.HandlerPop h)
fun handlerPush h = make (Exp.HandlerPush h)
end
@@ -481,138 +441,144 @@
structure Handler =
struct
+ structure Label = Label
+
datatype t =
- CallerHandler
+ Caller
+ | Dead
| Handle of Label.t
- | None
- fun layout h =
+ fun layout (h: t): Layout.t =
let
open Layout
in
case h of
- CallerHandler => str "CallerHandler"
+ Caller => str "Caller"
+ | Dead => str "Dead"
| Handle l => seq [str "Handle ", Label.layout l]
- | None => str "None"
end
val equals =
- fn (CallerHandler, CallerHandler) => true
- | (None, None) => true
+ fn (Caller, Caller) => true
+ | (Dead, Dead) => true
| (Handle l, Handle l') => Label.equals (l, l')
| _ => false
- local
- val newHash = Random.word
- val callerHandler = newHash ()
- val handlee = newHash ()
- val none = newHash ()
- in
- val hash: t -> Word.t =
- fn CallerHandler => callerHandler
- | Handle l => Label.hash l
- | None => none
- end
-
- fun foldLabel (h, a, f) =
+ fun foldLabel (h: t, a: 'a, f: Label.t * 'a -> 'a): 'a =
case h of
- Handle l => f (l, a)
- | _ => a
+ Caller => a
+ | Dead => a
+ | Handle l => f (l, a)
fun foreachLabel (h, f) = foldLabel (h, (), f o #1)
fun map (h, f) =
case h of
- Handle l => Handle (f l)
- | _ => h
+ Caller => Caller
+ | Dead => Dead
+ | Handle l => Handle (f l)
+
+ local
+ val newHash = Random.word
+ val caller = newHash ()
+ val dead = newHash ()
+ val handlee = newHash ()
+ in
+ fun hash (h: t): word =
+ case h of
+ Caller => caller
+ | Dead => dead
+ | Handle l => Word.xorb (handlee, Label.hash l)
+ end
end
structure Return =
struct
+ structure Label = Label
+ structure Handler = Handler
+
datatype t =
Dead
- | HandleOnly
| NonTail of {cont: Label.t,
handler: Handler.t}
| Tail
- val layout =
+ fun layout r =
let
open Layout
in
- fn Dead => str "Dead"
- | HandleOnly => str "HandleOnly"
+ case r of
+ Dead => str "Dead"
| NonTail {cont, handler} =>
seq [str "NonTail ",
- record [("cont", Label.layout cont),
- ("handler", Handler.layout handler)]]
+ Layout.record
+ [("cont", Label.layout cont),
+ ("handler", Handler.layout handler)]]
| Tail => str "Tail"
end
- val isNonTail = fn NonTail _ => true | _ => false
- val isTail = not o isNonTail
-
- val equals =
- fn (Dead, Dead) => true
- | (HandleOnly, HandleOnly) => true
- | (NonTail {cont, handler},
- NonTail {cont = cont', handler = handler'}) =>
- Label.equals (cont, cont') andalso
- Handler.equals (handler, handler')
- | (Tail, Tail) => true
- | _ => false
+ fun equals (r, r'): bool =
+ case (r, r') of
+ (Dead, Dead) => true
+ | (NonTail {cont = c, handler = h},
+ NonTail {cont = c', handler = h'}) =>
+ Label.equals (c, c') andalso Handler.equals (h, h')
+ | (Tail, Tail) => true
+ | _ => false
- local
- val newHash = Random.word
- val dead = newHash ()
- val handleOnly = newHash ()
- val nonTail = newHash ()
- val tail = newHash ()
- fun hash2 (w1: Word.t, w2: Word.t) = Word.xorb (w1, w2)
- in
- val hash: t -> Word.t =
- fn Dead => dead
- | HandleOnly => handleOnly
- | NonTail {cont, handler} =>
- hash2 (Label.hash cont, Handler.hash handler)
- | Tail => tail
- end
-
- fun foreachHandler (r, f) =
- case r of
- NonTail {handler, ...} => Handler.foreachLabel (handler, f)
- | _ => ()
-
- fun foldLabel (r, a, f) =
+ fun foldLabel (r: t, a, f) =
case r of
- NonTail {cont, handler} =>
- f (cont, Handler.foldLabel (handler, a, f))
- | _ => a
+ Dead => a
+ | NonTail {cont, handler} =>
+ Handler.foldLabel (handler, f (cont, a), f)
+ | Tail => a
fun foreachLabel (r, f) = foldLabel (r, (), f o #1)
+ fun foreachHandler (r, f) =
+ case r of
+ Dead => ()
+ | NonTail {handler, ...} => Handler.foreachLabel (handler, f)
+ | Tail => ()
+
fun map (r, f) =
case r of
- NonTail {cont, handler} =>
+ Dead => Dead
+ | NonTail {cont, handler} =>
NonTail {cont = f cont,
handler = Handler.map (handler, f)}
- | _ => r
+ | Tail => Tail
- fun compose (c: t, r: t): t =
- case r of
+ fun compose (r, r') =
+ case r' of
Dead => Dead
- | HandleOnly =>
- (case c of
- Dead => Dead
- | HandleOnly => HandleOnly
- | NonTail _ => c
- | Tail => HandleOnly)
- | NonTail {cont, handler, ...} =>
- (case (handler, c) of
- (Handler.CallerHandler, NonTail {handler = h1, ...}) =>
- NonTail {cont = cont, handler = h1}
- | _ => r)
- | Tail => c
+ | NonTail {cont, handler} =>
+ NonTail
+ {cont = cont,
+ handler = (case handler of
+ Handler.Caller =>
+ (case r of
+ Dead => Handler.Caller
+ | NonTail {handler, ...} => handler
+ | Tail => Handler.Caller)
+ | Handler.Dead => handler
+ | Handler.Handle _ => handler)}
+ | Tail => r
+
+ local
+ val newHash = Random.word
+ val dead = newHash ()
+ val nonTail = newHash ()
+ val tail = newHash ()
+ in
+ fun hash r =
+ case r of
+ Dead => dead
+ | NonTail {cont, handler} =>
+ Word.xorb (Word.xorb (nonTail, Label.hash cont),
+ Handler.hash handler)
+ | Tail => tail
+ end
end
structure Transfer =
@@ -624,8 +590,8 @@
success: Label.t, (* Must be unary. *)
ty: Type.t}
| Bug (* MLton thought control couldn't reach here. *)
- | Call of {func: Func.t,
- args: Var.t vector,
+ | Call of {args: Var.t vector,
+ func: Func.t,
return: Return.t}
| Case of {test: Var.t,
cases: Label.t Cases.t,
@@ -746,27 +712,8 @@
Label.layout overflow, str " ()"]
| Bug => str "Bug"
| Call {func, args, return} =>
- let
- val call = seq [Func.layout func, str " ", layoutTuple args]
- val call =
- case return of
- Return.Dead => seq [str "Dead ", call]
- | Return.HandleOnly => seq [str "HandleOnly ", call]
- | Return.Tail => call
- | Return.NonTail {cont, handler} =>
- let
- val call =
- seq [Label.layout cont, str " ", paren call]
- in
- case handler of
- Handler.CallerHandler => call
- | Handler.Handle l =>
- seq [call, str " handle ", Label.layout l]
- | Handler.None => seq [call, str " None"]
- end
- in
- call
- end
+ seq [Func.layout func, str " ", layoutTuple args,
+ str " ", Return.layout return]
| Case arg => layoutCase arg
| Goto {dst, args} =>
seq [Label.layout dst, str " ", layoutTuple args]
@@ -913,52 +860,6 @@
; Vector.foreach (statements, Statement.clear))
end
-structure ExnStack =
- struct
- structure ZPoint =
- struct
- datatype t = Caller | Me
-
- val equals: t * t -> bool = op =
-
- val toString =
- fn Caller => "Caller"
- | Me => "Me"
-
- val layout = Layout.str o toString
- end
-
- structure L = FlatLattice (structure Point = ZPoint)
- open L
- structure Point = ZPoint
-
- val me = point Point.Me
- val caller = point Point.Caller
- end
-
-structure HandlerLat = FlatLattice (structure Point = Label)
-
-structure HandlerInfo =
- struct
- datatype t = T of {block: Block.t,
- global: ExnStack.t,
- handler: HandlerLat.t,
- slot: ExnStack.t,
- visited: bool ref}
-
- fun new (b: Block.t): t =
- T {block = b,
- global = ExnStack.new (),
- handler = HandlerLat.new (),
- slot = ExnStack.new (),
- visited = ref false}
-
- fun layout (T {global, handler, slot, ...}) =
- Layout.record [("global", ExnStack.layout global),
- ("slot", ExnStack.layout slot),
- ("handler", HandlerLat.layout handler)]
- end
-
structure Datatype =
struct
datatype t =
@@ -1090,256 +991,6 @@
in
()
end
-
- fun inferHandlers (f: t): Label.t list option array =
- let
- val {blocks, name, start, ...} = dest f
- val {get = labelIndex: Label.t -> int, set = setLabelIndex, ...} =
- Property.getSetOnce (Label.plist,
- Property.initRaise ("index", Label.layout))
- val _ =
- Vector.foreachi
- (blocks, fn (i, Block.T {label, ...}) =>
- setLabelIndex (label, i))
- val numBlocks = Vector.length blocks
- val handlerStack = Array.array (numBlocks, NONE)
- val visited = Array.array (numBlocks, false)
- (* Do a dfs from the start, figuring out the handler stack at
- * each label.
- *)
- fun visit (l: Label.t, hs: Label.t list): unit =
- let
- val i = labelIndex l
- val Block.T {statements, transfer, ...} =
- Vector.sub (blocks, i)
- in
- if Array.sub (visited, i)
- then ()
- else
- let
- val _ = Array.update (visited, i, true)
- fun bug msg =
- (Layout.outputl
- (Vector.layout
- (fn Block.T {label, ...} =>
- let open Layout
- in seq [Label.layout label,
- str " ",
- Option.layout (List.layout Label.layout)
- (Array.sub (handlerStack,
- labelIndex label))]
- end)
- blocks,
- Out.error)
- ; (Error.bug
- (concat
- ["inferHandlers bug found in ", Label.toString l,
- ": ", msg])))
- val _ =
- case Array.sub (handlerStack, i) of
- NONE => Array.update (handlerStack, i, SOME hs)
- | SOME hs' =>
- if List.equals (hs, hs', Label.equals)
- then ()
- else bug "handler stack mismatch"
- val hs =
- Vector.fold
- (statements, hs, fn (s, hs) =>
- let
- val Statement.T {var, ty, exp, ...} = s
- in
- case Statement.exp s of
- HandlerPop _ =>
- (case hs of
- [] => bug "pop of empty handler stack"
- | _ :: hs => hs)
- | HandlerPush h => h :: hs
- | _ => hs
- end)
- fun empty s =
- if List.isEmpty hs
- then ()
- else bug (concat ["nonempty stack ", s])
- fun top l =
- case hs of
- l' :: _ =>
- if Label.equals (l, l')
- then ()
- else bug "wrong handler on top"
- | _ => bug "empty stack"
- val _ =
- case transfer of
- Call {return, ...} =>
- (case return of
- Return.Dead => ()
- | Return.HandleOnly => empty "HandleOnly"
- | Return.NonTail {handler, ...} =>
- (case handler of
- Handler.CallerHandler =>
- empty "CallerHandler"
- | Handler.Handle l => top l
- | Handler.None => ())
- | Return.Tail => empty "tail")
- | Raise _ => empty "raise"
- | Return _ => empty "return"
- | _ => ()
- val _ =
- Transfer.foreachLabel (transfer, fn l =>
- visit (l, hs))
- in
- ()
- end
- end
- val _ = visit (start, [])
- in
- handlerStack
- end
-
- fun checkHandlers (f: t): unit =
- let
- val {name, start, blocks, ...} = dest f
- val {get = labelInfo: Label.t -> HandlerInfo.t,
- rem = remLabelInfo,
- set = setLabelInfo} =
- Property.getSetOnce
- (Label.plist, Property.initRaise ("info", Label.layout))
- val _ =
- Vector.foreach
- (blocks, fn b => setLabelInfo (Block.label b, HandlerInfo.new b))
- (* Do a DFS of the control-flow graph. *)
- fun visitLabel l = visitInfo (labelInfo l)
- and visitInfo
- (hi as HandlerInfo.T {block, global, handler, slot, visited, ...})
- : unit =
- if !visited
- then ()
- else
- let
- val _ = visited := true
- val Block.T {label, statements, transfer, ...} = block
- datatype z = datatype ExnStack.t
- val {global, handler, slot} =
- Vector.fold
- (statements,
- {global = global, handler = handler, slot = slot},
- fn (Statement.T {exp, ...}, {global, handler, slot}) =>
- case exp of
- SetExnStackLocal => {global = ExnStack.me,
- handler = handler,
- slot = slot}
- | SetExnStackSlot => {global = slot,
- handler = handler,
- slot = slot}
- | SetSlotExnStack => {global = global,
- handler = handler,
- slot = slot}
- | SetHandler l => {global = global,
- handler = HandlerLat.point l,
- slot = slot}
- | _ => {global = global, handler = handler, slot = slot})
- fun fail msg =
- (Control.message
- (Control.Silent, fn () =>
- let open Layout
- in align
- [str "before: ", HandlerInfo.layout hi,
- str "block: ", Block.layout block,
- seq [str "after: ",
- Layout.record
- [("global", ExnStack.layout global),
- ("slot", ExnStack.layout slot),
- ("handler", HandlerLat.layout handler)]],
- Vector.layout
- (fn Block.T {label, ...} =>
- seq [Label.layout label,
- str " ",
- HandlerInfo.layout (labelInfo label)])
- blocks]
- end)
- ; Error.bug (concat ["handler mismatch at ", msg]))
- fun assert (msg, f) =
- if f
- then ()
- else fail msg
- fun goto (l: Label.t): unit =
- let
- val HandlerInfo.T {global = g, handler = h,
- slot = s, ...} =
- labelInfo l
- val _ =
- assert ("goto",
- ExnStack.<= (global, g)
- andalso ExnStack.<= (slot, s)
- andalso HandlerLat.<= (handler, h))
- in
- visitLabel l
- end
- fun tail name =
- assert (name,
- ExnStack.forcePoint
- (global, ExnStack.Point.Caller))
- fun caller () =
- ExnStack.forcePoint (global, ExnStack.Point.Caller)
- in
- case transfer of
- Arith {overflow, success, ...} =>
- (goto overflow; goto success)
- | Bug => ()
- | Call {return, ...} =>
- assert
- ("return",
- case return of
- Return.Dead => true
- | Return.HandleOnly => caller ()
- | Return.NonTail {cont, handler = h, ...} =>
- (goto cont
- ; (case h of
- Handler.CallerHandler => caller ()
- | Handler.Handle l =>
- let
- val res =
- ExnStack.forcePoint
- (global, ExnStack.Point.Me)
- andalso (HandlerLat.forcePoint
- (handler, l))
- val _ = goto l
- in
- res
- end
- | Handler.None => true))
- | Return.Tail => caller ())
- | Case {cases, default, ...} =>
- (Cases.foreach (cases, goto)
- ; Option.app (default, goto))
- | Goto {dst, ...} => goto dst
- | Raise _ => tail "raise"
- | Return _ => tail "return"
- | Runtime {return, ...} => goto return
- end
- val info as HandlerInfo.T {global, ...} = labelInfo start
- val _ = ExnStack.forcePoint (global, ExnStack.Point.Caller)
- val _ = visitInfo info
- val _ =
- Control.diagnostics
- (fn display =>
- let
- open Layout
- val _ =
- display (seq [str "checkHandlers ",
- Func.layout name])
- val _ =
- Vector.foreach
- (blocks, fn Block.T {label, ...} =>
- display (seq [Label.layout label,
- str " ",
- HandlerInfo.layout (labelInfo label)]))
- in
- ()
- end)
- val _ = Vector.foreach (blocks, fn b => remLabelInfo (Block.label b))
- in
- ()
- end
local
structure Graph = DirectedGraph
@@ -1479,25 +1130,21 @@
Layout.str
(Var.pretty (x, global))))])
| Bug => ["bug"]
- | Call {func, args, return, ...} =>
+ | Call {func, args, return} =>
let
val f = Func.toString func
val args = Var.prettys (args, global)
- val call = [f, " ", args]
+ val _ =
+ case return of
+ Return.Dead => ()
+ | Return.NonTail {cont, handler} =>
+ (edge (cont, "", Dotted)
+ ; (Handler.foreachLabel
+ (handler, fn l =>
+ edge (l, "", Dashed))))
+ | Return.Tail => ()
in
- case return of
- Return.Dead => "Dead " :: call
- | Return.HandleOnly =>
- "HandleOnly " :: call
- | Return.NonTail {cont, handler} =>
- (edge (cont, "", Dotted)
- ; (case handler of
- Handler.CallerHandler => call
- | Handler.Handle l =>
- (edge (l, "", Dashed)
- ; call)
- | Handler.None => call @ [" None"]))
- | Return.Tail => call
+ [f, " ", args]
end
| Case {test, cases, default, ...} =>
let
@@ -1751,6 +1398,7 @@
then f
else
let
+ val _ = Control.diagnostic (fn () => layout f)
val {args, blocks, name, raises, returns, start} = dest f
val extraBlocks = ref []
val {get = labelBlock, set = setLabelBlock, rem} =
@@ -1797,94 +1445,62 @@
in
c
end
- fun genHandler (): Statement.t vector * Label.t option =
+ fun genHandler (cont: Label.t)
+ : Statement.t vector * Label.t * Handler.t =
case raises of
- NONE => (statements, NONE)
+ NONE => (statements, cont, Handler.Caller)
| SOME ts =>
let
val xs = Vector.map (ts, fn _ => Var.newNoname ())
val l = Label.newNoname ()
+ val pop = make (HandlerPop l)
+ val push = make (HandlerPush l)
val _ =
List.push
(extraBlocks,
Block.T
{args = Vector.zip (xs, ts),
label = l,
- statements = (Vector.new2
- (make (HandlerPop l),
- leave ())),
+ statements = Vector.new2 (pop, leave ()),
transfer = Transfer.Raise xs})
in
- (Vector.concat
- [statements,
- Vector.new1 (make (HandlerPush l))],
- SOME l)
+ (Vector.concat [statements, Vector.new1 push],
+ prefix (cont, Vector.new1 pop),
+ Handler.Handle 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 ())
+ let
+ datatype z = datatype Return.t
+ in
+ case return of
+ Dead => (statements, transfer)
+ | NonTail {cont, handler} =>
+ (case handler of
+ Handler.Dead => (statements, transfer)
+ | Handler.Caller =>
+ let
+ val (statements, cont, handler) =
+ genHandler cont
+ val return =
+ Return.NonTail
+ {cont = cont,
+ handler = handler}
+ in
+ (statements,
+ Call {args = args,
+ func = func,
+ return = return})
+ end
+ | Handler.Handle l =>
+ (statements, transfer))
+ | Tail => addLeave ()
+ end
| Raise _ => addLeave ()
| Return _ => addLeave ()
| _ => (statements, transfer)
@@ -1896,13 +1512,16 @@
end)
val _ = Vector.foreach (blocks, rem o Block.label)
val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
+ val f =
+ new {args = args,
+ blocks = blocks,
+ name = name,
+ raises = raises,
+ returns = returns,
+ start = start}
+ val _ = Control.diagnostic (fn () => layout f)
in
- new {args = args,
- blocks = blocks,
- name = name,
- raises = raises,
- returns = returns,
- start = start}
+ f
end
end
@@ -1920,10 +1539,7 @@
structure Program =
struct
open Program
-
- fun checkHandlers (T {functions, ...}) =
- List.foreach (functions, Function.checkHandlers)
-
+
local
structure Graph = DirectedGraph
structure Node = Graph.Node
@@ -1973,13 +1589,13 @@
let
val to = funcNode func
val {tail, nontail} = get to
+ datatype z = datatype Return.t
val is =
- (case return of
- Return.NonTail _ => true
- | _ => false)
- val r = if is
- then nontail
- else tail
+ case return of
+ Dead => false
+ | NonTail _ => true
+ | Tail => false
+ val r = if is then nontail else tail
in
if !r
then ()
1.42 +50 -84 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- ssa-tree.sig 19 Dec 2002 23:43:36 -0000 1.41
+++ ssa-tree.sig 2 Jan 2003 17:45:21 -0000 1.42
@@ -7,12 +7,51 @@
*)
type int = Int.t
type word = Word.t
-
+
signature SSA_TREE_STRUCTS =
sig
include ATOMS
end
+signature LABEL = HASH_ID
+
+signature HANDLER =
+ sig
+ structure Label: LABEL
+
+ datatype t =
+ Caller
+ | Dead
+ | Handle of Label.t
+
+ val equals: t * t -> bool
+ val foldLabel: t * 'a * (Label.t * 'a -> 'a) -> 'a
+ val foreachLabel: t * (Label.t -> unit) -> unit
+ val layout: t -> Layout.t
+ val map: t * (Label.t -> Label.t) -> t
+ end
+
+signature RETURN =
+ sig
+ structure Label: LABEL
+
+ structure Handler: HANDLER
+ sharing Label = Handler.Label
+
+ datatype t =
+ Dead
+ | NonTail of {cont: Label.t,
+ handler: Handler.t}
+ | Tail
+
+ val compose: t * t -> t
+ val foldLabel: t * 'a * (Label.t * 'a -> 'a) -> 'a
+ val foreachHandler: t * (Label.t -> unit) -> unit
+ val foreachLabel: t * (Label.t -> unit) -> unit
+ val layout: t -> Layout.t
+ val map: t * (Label.t -> Label.t) -> t
+ end
+
signature SSA_TREE =
sig
include SSA_TREE_STRUCTS
@@ -45,16 +84,9 @@
sharing Atoms = Type.Atoms
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 Label: LABEL
+ structure ProfileExp: PROFILE_EXP
+ sharing SourceInfo = ProfileExp.SourceInfo
structure Exp:
sig
@@ -75,10 +107,6 @@
| Profile of ProfileExp.t
| Select of {tuple: Var.t,
offset: int}
- | SetExnStackLocal
- | SetExnStackSlot
- | SetHandler of Label.t
- | SetSlotExnStack
| Tuple of Var.t vector
| Var of Var.t
@@ -89,6 +117,7 @@
val layout: t -> Layout.t
val maySideEffect: t -> bool
val replaceVar: t * (Var.t -> Var.t) -> t
+ val toString: t -> string
val unit: t
end
@@ -104,74 +133,17 @@
val handlerPush: Label.t -> t
val layout: t -> Layout.t
val prettifyGlobals: t vector -> (Var.t -> string option)
- val setExnStackLocal: t
- val setExnStackSlot: t
- val setHandler: Label.t -> t
- val setSlotExnStack: t
val var: t -> Var.t option
end
structure Cases: CASES sharing type Cases.con = Con.t
- structure Handler:
- sig
- datatype t =
- CallerHandler
- | None
- | Handle of Label.t
+ structure Handler: HANDLER
+ sharing Handler.Label = Label
- val equals: t * t -> bool
- val foreachLabel: t * (Label.t -> unit) -> unit
- val layout: t -> Layout.t
- val map: t * (Label.t -> Label.t) -> t
- end
+ structure Return: RETURN
+ sharing Return.Handler = Handler
- (*
- * These correspond to 6 of the possible 9 combinations of continuation and
- * handler each being one of {None, Caller, Some l}. None means that it
- * doesn't matter what the continuation (handler) is since the caller never
- * returns (raises). Caller means to keep the continuation (handler) the same
- * as in the caller. Some l means a nontail call in the case of continuations
- * and an installed handler in the case of handlers.
- *
- * 3 of the 9 possibilities are disallowed, and the correspondence is as below.
- *
- * Cont Handler equivalent
- * ------ ------- ---------------------------------------
- * None None Dead
- * None Caller HandleOnly
- * None Some h *disallowed*
- * Caller None *disallowed*
- * Caller Caller Tail
- * Caller Some h *disallowed*
- * Some l None Nontail {cont = l, handler = None}
- * Some l Caller Nontail {cont = l, handler = Caller}
- * Some l Some h Nontail {cont = l, handler = Handle l}
- *
- * We could have allowed the (None, Some h) and (Caller, Some h) cases, and
- * put some code in the backend to generate stubs, since if there is a handler
- * there must be some continuation. But I decided it was easier to just rule
- * them out, essentially meaning that remove-unused, or any other optimization
- * pass, needs to make stubs itself.
- *)
- structure Return:
- sig
- datatype t =
- Dead
- | HandleOnly
- | NonTail of {cont: Label.t, handler: Handler.t}
- | Tail
-
- val compose: t * t -> t
- val foldLabel: t * 'a * (Label.t * 'a -> 'a) -> 'a
- 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
-
structure Transfer:
sig
datatype t =
@@ -181,8 +153,8 @@
success: Label.t, (* Must be unary. *)
ty: Type.t} (* int or word *)
| Bug (* MLton thought control couldn't reach here. *)
- | Call of {func: Func.t,
- args: Var.t vector,
+ | Call of {args: Var.t vector,
+ func: Func.t,
return: Return.t}
| Case of {test: Var.t,
cases: Label.t Cases.t,
@@ -252,7 +224,6 @@
val alphaRename: t -> t
val blocks: t -> Block.t vector
- val checkHandlers: t -> unit
(* clear the plists for all bound variables and labels that appear
* in the function, but not the function name's plist.
*)
@@ -273,10 +244,6 @@
val dfs: t * (Block.t -> unit -> unit) -> unit
val dominatorTree: t -> Block.t Tree.t
val foreachVar: t * (Var.t * Type.t -> unit) -> unit
- (* inferHandlers uses the HandlerPush and HandlerPop statements
- * to infer the handler stack at the beginning of each block.
- *)
- val inferHandlers: t -> Label.t list option array
val layout: t -> Layout.t
val layoutDot:
t * (Var.t -> string option) -> {graph: Layout.t,
@@ -302,7 +269,6 @@
main: Func.t (* Must be nullary. *)
}
- val checkHandlers: t -> unit
val clear: t -> unit
val clearTop: t -> unit
val foreachVar: t * (Var.t * Type.t -> unit) -> unit
1.20 +164 -22 mlton/mlton/ssa/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- type-check.fun 19 Dec 2002 23:43:36 -0000 1.19
+++ type-check.fun 2 Jan 2003 17:45:21 -0000 1.20
@@ -66,10 +66,6 @@
| PrimApp {args, ...} => Vector.foreach (args, getVar)
| Profile _ => ()
| Select {tuple, ...} => getVar tuple
- | SetExnStackLocal => ()
- | SetExnStackSlot => ()
- | SetSlotExnStack => ()
- | SetHandler l => getLabel l
| Tuple xs => Vector.foreach (xs, getVar)
| Var x => getVar x
val _ = Option.app (var, fn x => bindVar (x, ty))
@@ -182,7 +178,8 @@
val _ = List.foreach (functions, loopFunc)
val _ = getFunc main
val _ = Program.clearTop program
- in ()
+ in
+ ()
end
val checkScopes = Control.trace (Control.Pass, "checkScopes") checkScopes
@@ -205,6 +202,28 @@
sources = ref NONE}))
fun goto (l: Label.t, sources: SourceInfo.t list) =
let
+ fun bug (msg: string): 'a =
+ let
+ val _ =
+ Vector.foreach
+ (blocks, fn Block.T {label, ...} =>
+ let
+ val {sources, ...} = labelInfo label
+ open Layout
+ in
+ outputl
+ (seq [Label.layout label,
+ str " ",
+ Option.layout
+ (List.layout SourceInfo.layout)
+ (!sources)],
+ Out.error)
+ end)
+ in
+ Error.bug
+ (concat ["checkProf bug found in ", Label.toString l,
+ ": ", msg])
+ end
val _ =
if not debug
then ()
@@ -238,14 +257,12 @@
Enter s => s :: sources
| Leave s =>
(case sources of
- [] => Error.bug "unmatched Leave"
+ [] => bug "unmatched Leave"
| s' :: sources =>
if SourceInfo.equals (s, s')
then sources
- else Error.bug "mismatched Leave"))
+ else bug "mismatched Leave"))
| _ => sources)
- datatype z = datatype Handler.t
- datatype z = datatype Return.t
val _ =
if not debug
then ()
@@ -259,21 +276,20 @@
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)
+ let
+ datatype z = datatype Return.t
+ in
+ case return of
+ Dead => false
+ | NonTail _ => false
+ | Tail => true
+ end
| Raise _ => true
| Return _ => true
| _ => false)
then (case sources of
[] => ()
- | _ => Error.bug "nonempty sources when leaving function")
+ | _ => bug "nonempty sources when leaving function")
else ()
in
Transfer.foreachLabel
@@ -282,7 +298,7 @@
| SOME sources' =>
if List.equals (sources, sources', SourceInfo.equals)
then ()
- else Error.bug "mismatched block"
+ else bug "mismatched block"
end
val _ = goto (start, [])
val _ = Vector.foreach (blocks, fn Block.T {label, ...} => rem label)
@@ -291,13 +307,139 @@
end
end
+fun checkHandlers (program as Program.T {datatypes, functions, ...}): unit =
+ let
+ fun checkFunction (f: Function.t): unit =
+ let
+ val {blocks, name, start, ...} = Function.dest f
+ val {get = labelIndex: Label.t -> int, rem = remLabelIndex,
+ set = setLabelIndex} =
+ Property.getSetOnce
+ (Label.plist, Property.initRaise ("index", Label.layout))
+ val _ =
+ Vector.foreachi
+ (blocks, fn (i, Block.T {label, ...}) =>
+ setLabelIndex (label, i))
+ val numBlocks = Vector.length blocks
+ val handlerStack = Array.array (numBlocks, NONE)
+ val visited = Array.array (numBlocks, false)
+ (* Do a dfs from the start, figuring out the handler stack at
+ * each label.
+ *)
+ fun visit (l: Label.t, hs: Label.t list): unit =
+ let
+ val i = labelIndex l
+ val Block.T {statements, transfer, ...} =
+ Vector.sub (blocks, i)
+ in
+ if Array.sub (visited, i)
+ then ()
+ else
+ let
+ val _ = Array.update (visited, i, true)
+ fun bug msg =
+ (Layout.outputl
+ (Vector.layout
+ (fn Block.T {label, ...} =>
+ let open Layout
+ in seq [Label.layout label,
+ str " ",
+ Option.layout (List.layout Label.layout)
+ (Array.sub (handlerStack,
+ labelIndex label))]
+ end)
+ blocks,
+ Out.error)
+ ; (Error.bug
+ (concat
+ ["checkHandlers bug found in ", Label.toString l,
+ ": ", msg])))
+ val _ =
+ case Array.sub (handlerStack, i) of
+ NONE => Array.update (handlerStack, i, SOME hs)
+ | SOME hs' =>
+ if List.equals (hs, hs', Label.equals)
+ then ()
+ else bug "handler stack mismatch"
+ val hs =
+ Vector.fold
+ (statements, hs, fn (s, hs) =>
+ let
+ val Statement.T {var, ty, exp, ...} = s
+ in
+ case Statement.exp s of
+ HandlerPop _ =>
+ (case hs of
+ [] => bug "pop of empty handler stack"
+ | _ :: hs => hs)
+ | HandlerPush h => h :: hs
+ | _ => hs
+ end)
+ fun empty s =
+ if List.isEmpty hs
+ then ()
+ else bug (concat ["nonempty stack ", s])
+ fun top l =
+ case hs of
+ l' :: _ =>
+ if Label.equals (l, l')
+ then ()
+ else bug "wrong handler on top"
+ | _ => bug "empty stack"
+ fun goto l = visit (l, hs)
+ val _ =
+ case transfer of
+ Arith {overflow, success, ...} =>
+ (goto overflow; goto success)
+ | Bug => ()
+ | Call {func, return, ...} =>
+ (case return of
+ Return.Dead => ()
+ | Return.NonTail {cont, handler} =>
+ (goto cont
+ ; (case handler of
+ Handler.Caller =>
+ empty "Handler.Caller"
+ | Handler.Dead => ()
+ | Handler.Handle l =>
+ (top l
+ ; goto l)))
+ | Return.Tail => ())
+ | Case {cases, default, ...} =>
+ (Option.app (default, goto)
+ ; Cases.foreach (cases, goto))
+ | Goto {dst, ...} => goto dst
+ | Raise _ => empty "raise"
+ | Return _ => empty "return"
+ | Runtime {return, ...} => goto return
+ in
+ ()
+ end
+ end
+ val _ = visit (start, [])
+ val _ = Vector.foreach (blocks, remLabelIndex o Block.label)
+ in
+ ()
+ end
+ val _ = List.foreach (functions, checkFunction)
+ in
+ ()
+ end
+
+val checkHandlers = Control.trace (Control.Pass, "checkHandlers") checkHandlers
+
+fun checkProf (Program.T {functions, ...}): unit =
+ List.foreach (functions, fn f => Function.checkProf f)
+
+val checkProf = Control.trace (Control.Pass, "checkProf") checkProf
+
fun typeCheck (program as Program.T {datatypes, functions, ...}): unit =
let
val _ = checkScopes program
- val _ = List.foreach (functions, fn f => (Function.inferHandlers f; ()))
+ val _ = checkHandlers program
val _ =
if !Control.profile <> Control.ProfileNone
- then List.foreach (functions, fn f => Function.checkProf f)
+ then checkProf program
else ()
val out = Out.error
val print = Out.outputc out
1.15 +12 -27 mlton/mlton/ssa/useless.fun
Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- useless.fun 19 Dec 2002 23:43:36 -0000 1.14
+++ useless.fun 2 Jan 2003 17:45:21 -0000 1.15
@@ -548,41 +548,27 @@
Call {func = g, return, ...} =>
let
val {raises = graisevs, ...} = func g
+ fun coerceRaise () =
+ case (graisevs, fraisevs) of
+ (NONE, NONE) => ()
+ | (NONE, SOME _) => ()
+ | (SOME _, NONE) =>
+ Error.bug "raise mismatch at Caller"
+ | (SOME vs, SOME vs') =>
+ Vector.foreach2 (vs', vs, coerce)
in
case return of
Return.Dead => ()
- | Return.HandleOnly =>
- (case (graisevs, fraisevs) of
- (NONE, NONE) => ()
- | (NONE, SOME _) => ()
- | (SOME _, NONE) =>
- Error.bug "raise mismatch at HandleOnly"
- | (SOME vs, SOME vs') =>
- Vector.foreach2 (vs', vs, coerce))
| Return.NonTail {handler, ...} =>
(case handler of
- Handler.None => ()
- | Handler.CallerHandler =>
- (case (graisevs, fraisevs) of
- (NONE, NONE) => ()
- | (NONE, SOME _) => ()
- | (SOME _, NONE) =>
- Error.bug "raise mismatch at HandleOnly"
- | (SOME vs, SOME vs') =>
- Vector.foreach2 (vs', vs, coerce))
+ Handler.Caller => coerceRaise ()
+ | Handler.Dead => ()
| Handler.Handle h =>
Option.app
(graisevs, fn graisevs =>
Vector.foreach2
(label h, graisevs, coerce)))
- | Return.Tail =>
- (case (graisevs, fraisevs) of
- (NONE, NONE) => ()
- | (NONE, SOME _) => ()
- | (SOME _, NONE) =>
- Error.bug "raise mismatch at HandleOnly"
- | (SOME vs, SOME vs') =>
- Vector.foreach2 (vs', vs, coerce))
+ | Return.Tail => coerceRaise ()
end
| _ => ())
end)
@@ -855,7 +841,6 @@
val (blocks, return) =
case return of
Return.Dead => ([], return)
- | Return.HandleOnly => ([], return)
| Return.Tail =>
(case (returns, freturns) of
(NONE, NONE) => ([], Return.Tail)
@@ -872,7 +857,7 @@
in ([b],
Return.NonTail
{cont = l,
- handler = Handler.CallerHandler})
+ handler = Handler.Caller})
end)
| Return.NonTail {cont, handler} =>
(case freturns of
1.1 mlton/mlton/ssa/profile-exp.sig
Index: profile-exp.sig
===================================================================
signature PROFILE_EXP_STRUCTS =
sig
end
signature PROFILE_EXP =
sig
include PROFILE_EXP_STRUCTS
structure SourceInfo: SOURCE_INFO
datatype t =
Enter of SourceInfo.t
| Leave of SourceInfo.t
val layout: t -> Layout.t
end
1.7 +1 -0 mlton/regression/.cvsignore
Index: .cvsignore
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/.cvsignore,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- .cvsignore 22 Nov 2002 22:45:20 -0000 1.6
+++ .cvsignore 2 Jan 2003 17:45:22 -0000 1.7
@@ -1,4 +1,5 @@
*.dat
+*.dot
*.ssa
PM
RepeatParserCombinator.txt
1.46 +1 -1 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- Makefile 29 Dec 2002 01:23:00 -0000 1.45
+++ Makefile 2 Jan 2003 17:45:22 -0000 1.46
@@ -339,7 +339,7 @@
%-gdb.o: %.c
$(CC) $(DEBUGFLAGS) -DASSERT=1 -c -o $@ $<
-%.o: %.c
+%.o: %.c gc.h
$(CC) $(CFLAGS) -c -o $@ $<
%-gdb.o: %.S
1.110 +221 -115 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.109
retrieving revision 1.110
diff -u -r1.109 -r1.110
--- gc.c 20 Dec 2002 17:17:20 -0000 1.109
+++ gc.c 2 Jan 2003 17:45:22 -0000 1.110
@@ -62,8 +62,6 @@
DEBUG_GENERATIONAL = FALSE,
DEBUG_MARK_COMPACT = FALSE,
DEBUG_MEM = FALSE,
- DEBUG_PROFILE_ALLOC = FALSE,
- DEBUG_PROF = FALSE,
DEBUG_RESIZING = FALSE,
DEBUG_SIGNALS = FALSE,
DEBUG_STACKS = FALSE,
@@ -93,7 +91,7 @@
assert (1 == (header & 1)); \
objectTypeIndex = (header & TYPE_INDEX_MASK) >> 1; \
assert (0 <= objectTypeIndex \
- and objectTypeIndex < s->numObjectTypes); \
+ and objectTypeIndex < s->objectTypesSize); \
t = &s->objectTypes [objectTypeIndex]; \
tag = t->tag; \
numNonPointers = t->numNonPointers; \
@@ -585,46 +583,6 @@
return 0 == stack->used;
}
-word *GC_stackFrameIndices (GC_state s) {
- pointer bottom;
- int i;
- word index;
- GC_frameLayout *layout;
- int numFrames;
- word *res;
- word returnAddress;
- pointer top;
-
- if (DEBUG_PROF)
- fprintf (stderr, "walking stack\n");
- assert (s->native);
- bottom = stackBottom (s->currentThread->stack);
- numFrames = 0;
- for (top = s->stackTop; top > bottom; ++numFrames) {
- returnAddress = *(word*)(top - WORD_SIZE);
- index = *(word*)(returnAddress - WORD_SIZE);
- if (DEBUG_PROF)
- fprintf (stderr, "top = 0x%08x index = %u\n",
- (uint)top, index);
- assert (0 <= index and index < s->numFrameLayouts);
- layout = &(s->frameLayouts[index]);
- assert (layout->numBytes > 0);
- top -= layout->numBytes;
- }
- res = (word*) malloc ((numFrames + 1) * sizeof(word));
- i = numFrames - 1;
- for (top = s->stackTop; top > bottom; --i) {
- returnAddress = *(word*)(top - WORD_SIZE);
- index = *(word*)(returnAddress - WORD_SIZE);
- res[i] = index;
- top -= s->frameLayouts[index].numBytes;
- }
- res[numFrames] = 0xFFFFFFFF;
- if (DEBUG_PROF)
- fprintf (stderr, "done walking stack\n");
- return res;
-}
-
static inline GC_frameLayout * getFrameLayout (GC_state s, word returnAddress) {
GC_frameLayout *layout;
uint index;
@@ -634,9 +592,9 @@
else
index = (uint)returnAddress;
if (DEBUG_DETAILED)
- fprintf (stderr, "returnAddress = 0x%08x index = %d numFrameLayouts = %d\n",
- returnAddress, index, s->numFrameLayouts);
- assert (0 <= index and index < s->numFrameLayouts);
+ fprintf (stderr, "returnAddress = 0x%08x index = %d frameLayoutsSize = %d\n",
+ returnAddress, index, s->frameLayoutsSize);
+ assert (0 <= index and index < s->frameLayoutsSize);
layout = &(s->frameLayouts[index]);
assert (layout->numBytes > 0);
return layout;
@@ -679,13 +637,6 @@
s->frontier = p;
}
-/* Pre: s->profileAllocIndex is set. */
-void GC_incProfileAlloc (GC_state s, W32 amount) {
- if (s->profileAllocIsOn)
- MLton_ProfileAlloc_inc (amount);
-}
-
-/* Pre: s->profileAllocIndex is set. */
static pointer object (GC_state s, uint header, W32 bytesRequested,
bool allocInOldGen) {
pointer frontier;
@@ -718,7 +669,6 @@
return result;
}
-/* Pre: s->profileAllocIndex is set. */
static GC_stack newStack (GC_state s, uint size, bool allocInOldGen) {
GC_stack stack;
@@ -776,7 +726,7 @@
static inline void foreachGlobal (GC_state s, GC_pointerFun f) {
int i;
- for (i = 0; i < s->numGlobals; ++i) {
+ for (i = 0; i < s->globalsSize; ++i) {
if (DEBUG_DETAILED)
fprintf (stderr, "foreachGlobal %u\n", i);
maybeCall (f, s, &s->globals [i]);
@@ -886,18 +836,22 @@
while (top > bottom) {
/* Invariant: top points just past a "return address". */
returnAddress = *(word*) (top - WORD_SIZE);
- if (DEBUG)
- fprintf(stderr,
- " top = %d return address = 0x%08x.\n",
- top - bottom,
- returnAddress);
+ if (DEBUG) {
+ fprintf (stderr, " top = %d return address = ",
+ top - bottom);
+ if (s->native)
+ fprintf (stderr, "0x%08x.\n",
+ returnAddress);
+ else
+ fprintf (stderr, "%u\n", returnAddress);
+ }
layout = getFrameLayout (s, returnAddress);
frameOffsets = layout->offsets;
top -= layout->numBytes;
for (i = 0 ; i < frameOffsets[0] ; ++i) {
if (DEBUG)
fprintf(stderr,
- " offset %u address %x\n",
+ " offset %u address 0x%08x\n",
frameOffsets[i + 1],
(uint)(*(pointer*)(top + frameOffsets[i + 1])));
maybeCall(f, s,
@@ -1028,16 +982,20 @@
fprintf (stderr, "invariant\n");
assert (ratiosOk (s));
/* Frame layouts */
- for (i = 0; i < s->numFrameLayouts; ++i) {
+ for (i = 0; i < s->frameLayoutsSize; ++i) {
GC_frameLayout *layout;
- layout = &(s->frameLayouts[i]);
+
+ layout = &(s->frameLayouts[i]);
if (layout->numBytes > 0) {
GC_offsets offsets;
- int j;
- assert(layout->numBytes <= s->maxFrameSize);
+// int j;
+
+ assert (layout->numBytes <= s->maxFrameSize);
offsets = layout->offsets;
- for (j = 0; j < offsets[0]; ++j)
- assert(offsets[j + 1] < layout->numBytes);
+// No longer correct, since handler frames have a "size" (i.e. return address)
+// pointing into the middle of the frame.
+// for (j = 0; j < offsets[0]; ++j)
+// assert (offsets[j + 1] < layout->numBytes);
}
}
if (s->mutatorMarksCards) {
@@ -2456,7 +2414,6 @@
fprintf (stderr, "Growing stack to size %s.\n",
uintToCommaString (stackBytes (size)));
assert (hasBytesFree (s, stackBytes (size), 0));
- s->profileAllocIndex = PROFILE_ALLOC_MISC;
stack = newStack (s, size, TRUE);
stackCopy (s->currentThread->stack, stack);
s->currentThread->stack = stack;
@@ -2658,7 +2615,6 @@
return ((w + 3) & ~ 3);
}
-/* Pre: s->profileAllocIndex is set. */
pointer GC_arrayAllocate (GC_state s, W32 ensureBytesFree, W32 numElts,
W32 header) {
uint numPointers;
@@ -2744,7 +2700,6 @@
return threadBytes () + stackBytes (initialStackSize (s));
}
-/* Pre: s->profileAllocIndex is set. */
static GC_thread newThreadOfSize (GC_state s, uint stackSize) {
GC_stack stack;
GC_thread t;
@@ -2761,7 +2716,6 @@
return t;
}
-/* Pre: s->profileAllocIndex is set. */
static GC_thread copyThread (GC_state s, GC_thread from, uint size) {
GC_thread to;
@@ -2785,7 +2739,6 @@
return to;
}
-/* Pre: s->profileAllocIndex is set. */
void GC_copyCurrentThread (GC_state s) {
GC_thread t;
GC_thread res;
@@ -2802,7 +2755,6 @@
s->savedThread = res;
}
-/* Pre: s->profileAllocIndex is set. */
pointer GC_copyThread (GC_state s, pointer thread) {
GC_thread res;
GC_thread t;
@@ -2819,6 +2771,169 @@
}
/* ---------------------------------------------------------------- */
+/* Profiling */
+/* ---------------------------------------------------------------- */
+
+void GC_foreachStackFrame (GC_state s, void (*f) (GC_state s, uint i)) {
+ pointer bottom;
+ word index;
+ GC_frameLayout *layout;
+ word returnAddress;
+ pointer top;
+
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, "walking stack");
+ assert (s->native);
+ bottom = stackBottom (s->currentThread->stack);
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, " bottom = 0x%08x top = 0x%08x.\n",
+ (uint)bottom, (uint)s->stackTop);
+ for (top = s->stackTop; top > bottom; top -= layout->numBytes) {
+ returnAddress = *(word*)(top - WORD_SIZE);
+ index = *(word*)(returnAddress - WORD_SIZE);
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, "top = 0x%08x index = %u\n",
+ (uint)top, index);
+ unless (0 <= index and index < s->frameLayoutsSize)
+ die ("top = 0x%08x returnAddress = 0x%08x index = %u\n",
+ (uint)top, returnAddress, index);
+ f (s, index);
+ layout = &(s->frameLayouts[index]);
+ assert (layout->numBytes > 0);
+ }
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, "done walking stack\n");
+}
+
+void GC_incProfileAlloc (GC_state s, W32 amount) {
+ if (s->profileAllocIsOn)
+ MLton_ProfileAlloc_inc (amount);
+}
+
+static void showProf (GC_state s) {
+ int i;
+
+ fprintf (stdout, "0x%08x\n", s->magic);
+ for (i = 0; i < s->sourcesSize; ++i)
+ fprintf (stdout, "%s\n", s->sources[i]);
+}
+
+static int compareProfileLabels (const void *v1, const void *v2) {
+ GC_profileLabel l1;
+ GC_profileLabel l2;
+
+ l1 = (GC_profileLabel)v1;
+ l2 = (GC_profileLabel)v2;
+ return (int)l1->label - (int)l2->label;
+}
+
+static void writeString (int fd, string s) {
+ swrite (fd, s, strlen(s));
+ swrite (fd, "\n", 1);
+}
+
+static void writeUint (int fd, uint w) {
+ char buf[20];
+
+ sprintf (buf, "%u", w);
+ writeString (fd, buf);
+}
+
+static void writeUllong (int fd, ullong u) {
+ char buf[20];
+
+ sprintf (buf, "%llu", u);
+ writeString (fd, buf);
+}
+
+static void writeWord (int fd, word w) {
+ char buf[20];
+
+ sprintf (buf, "0x%08x", w);
+ writeString (fd, buf);
+}
+
+static void profileHeaderWrite (GC_state s, string kind, int fd, ullong total) {
+ writeString (fd, "MLton prof");
+ writeString (fd, kind);
+ switch (s->profileStyle) {
+ case PROFILE_CUMULATIVE:
+ writeString (fd, "cumulative");
+ break;
+ case PROFILE_CURRENT:
+ writeString (fd, "current");
+ break;
+ }
+ writeWord (fd, s->magic);
+ writeUllong (fd, total);
+}
+
+void GC_profileAllocFree (GC_state s, GC_profileAlloc pa) {
+ free (pa->bytesAllocated);
+ switch (s->profileStyle) {
+ case PROFILE_CUMULATIVE:
+ free (pa->lastTotal);
+ free (pa->stackCount);
+ break;
+ case PROFILE_CURRENT:
+ break;
+ }
+ free (pa);
+}
+
+GC_profileAlloc GC_profileAllocNew (GC_state s) {
+ GC_profileAlloc pa;
+
+ NEW(pa);
+ pa->totalBytesAllocated = 0;
+ ARRAY (pa->bytesAllocated, s->sourcesSize);
+ switch (s->profileStyle) {
+ case PROFILE_CUMULATIVE:
+ ARRAY (pa->lastTotal, s->sourcesSize);
+ ARRAY (pa->stackCount, s->sourcesSize);
+ break;
+ case PROFILE_CURRENT:
+ break;
+ }
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "0x%08x = GC_profileAllocNew()\n",
+ (uint)pa);
+ return pa;
+}
+
+void GC_profileAllocWrite (GC_state s, GC_profileAlloc pa, int fd) {
+ int i;
+
+ profileHeaderWrite (s, "alloc", fd,
+ pa->totalBytesAllocated
+ + pa->bytesAllocated[SOURCES_INDEX_GC]);
+ for (i = 0; i < s->sourcesSize; ++i)
+ writeUllong (fd, pa->bytesAllocated[i]);
+}
+
+void GC_profileTimeFree (GC_state s, GC_profileTime pt) {
+ free (pt->ticks);
+ free (pt);
+}
+
+GC_profileTime GC_profileTimeNew (GC_state s) {
+ GC_profileTime pt;
+
+ NEW(pt);
+ ARRAY(pt->ticks, s->sourcesSize);
+ pt->totalTicks = 0;
+ return pt;
+}
+
+void GC_profileTimeWrite (GC_state s, GC_profileTime pt, int fd) {
+ int i;
+
+ profileHeaderWrite (s, "time", fd, pt->totalTicks);
+ for (i = 0; i < s->sourcesSize; ++i)
+ writeUint (fd, pt->ticks[i]);
+}
+
+/* ---------------------------------------------------------------- */
/* Initialization */
/* ---------------------------------------------------------------- */
@@ -3057,7 +3172,7 @@
inits = s->intInfInits;
frontier = s->frontier;
for (; (str = inits->mlstr) != NULL; ++inits) {
- assert (inits->globalIndex < s->numGlobals);
+ assert (inits->globalIndex < s->globalsSize);
neg = *str == '~';
if (neg)
++str;
@@ -3156,17 +3271,16 @@
if (DEBUG_DETAILED)
fprintf (stderr, "frontier after string allocation is 0x%08x\n",
(uint)frontier);
- s->frontier = frontier;
GC_incProfileAlloc (s, frontier - s->frontier);
s->bytesAllocated += frontier - s->frontier;
+ s->frontier = frontier;
}
-/* Pre: s->profileAllocIndex is set. */
static void newWorld (GC_state s) {
int i;
assert (isAligned (sizeof (struct GC_thread), WORD_SIZE));
- for (i = 0; i < s->numGlobals; ++i)
+ for (i = 0; i < s->globalsSize; ++i)
s->globals[i] = (pointer)BOGUS_POINTER;
setInitialBytesLive (s);
heapCreate (s, &s->heap, heapDesiredSize (s, s->bytesLive, 0),
@@ -3218,32 +3332,19 @@
setStack (s);
}
-static void showProf (GC_state s) {
- int i;
-
- fprintf (stdout, "0x%08x\n", s->magic);
- for (i = 0; i < s->profileSourcesSize; ++i)
- fprintf (stdout, "%s\n", s->profileSources[i]);
-}
+/* ---------------------------------------------------------------- */
+/* GC_init */
+/* ---------------------------------------------------------------- */
/* To get the beginning and end of the text segment. */
extern void _start(void),
etext(void);
-static int compareProfileLabels (const void *v1, const void *v2) {
- GC_profileLabel l1;
- GC_profileLabel l2;
-
- l1 = (GC_profileLabel)v1;
- l2 = (GC_profileLabel)v2;
- return (int)l1->label - (int)l2->label;
-}
-
int GC_init (GC_state s, int argc, char **argv) {
char *worldFile;
int i;
- s->amInGC = FALSE;
+ s->amInGC = TRUE;
s->bytesAllocated = 0;
s->bytesCopied = 0;
s->bytesCopiedMinor = 0;
@@ -3275,6 +3376,8 @@
s->numMinorsSinceLastMajor = 0;
s->nurseryRatio = 10.0;
s->oldGenArraySize = 0x100000;
+ s->profileStyle = PROFILE_CURRENT;
+ s->profileStyle = PROFILE_CUMULATIVE;
s->pageSize = getpagesize ();
s->ramSlop = 0.80;
s->savedThread = BOGUS_THREAD;
@@ -3296,8 +3399,9 @@
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) {
+ /* Initialize profiling. */
+ if (s->sourcesSize > 0) {
+ if (s->sourceLabelsSize > 0) {
s->profileAllocIsOn = FALSE;
s->profileTimeIsOn = TRUE;
} else {
@@ -3306,35 +3410,35 @@
}
}
if (s->profileAllocIsOn) {
- s->profileAllocIndex = PROFILE_ALLOC_MISC;
- MLton_ProfileAlloc_setCurrent
- (MLton_ProfileAlloc_Data_malloc ());
+ s->profileAlloc = GC_profileAllocNew (s);
}
if (s->profileTimeIsOn) {
pointer p;
uint sourceSeqsIndex;
+ if (PROFILE_CUMULATIVE == s->profileStyle)
+ ARRAY (s->sourceIsOnStack, s->sourcesSize);
/* Sort profileLabels by address. */
- qsort (s->profileLabels,
- s->profileLabelsSize,
- sizeof(*s->profileLabels),
+ qsort (s->sourceLabels,
+ s->sourceLabelsSize,
+ sizeof(*s->sourceLabels),
compareProfileLabels);
- if (DEBUG_PROF)
- for (i = 0; i < s->profileLabelsSize; ++i)
+ if (DEBUG_PROFILE_TIME)
+ for (i = 0; i < s->sourceLabelsSize; ++i)
fprintf (stderr, "0x%08x %u\n",
- (uint)s->profileLabels[i].label,
- s->profileLabels[i].sourceSeqsIndex);
+ (uint)s->sourceLabels[i].label,
+ s->sourceLabels[i].sourceSeqsIndex);
if (ASSERT)
- for (i = 1; i < s->profileLabelsSize; ++i)
- assert (s->profileLabels[i-1].label
- <= s->profileLabels[i].label);
+ for (i = 1; i < s->sourceLabelsSize; ++i)
+ assert (s->sourceLabels[i-1].label
+ <= s->sourceLabels[i].label);
/* 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);
+ for (i = 0; i < s->sourceLabelsSize; ++i)
+ assert (s->textStart <= s->sourceLabels[i].label
+ and s->sourceLabels[i].label < s->textEnd);
s->textSources =
(uint*)malloc ((s->textEnd - s->textStart)
* sizeof(*s->textSources));
@@ -3342,17 +3446,18 @@
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) {
+ for (i = 0; i < s->sourceLabelsSize; ++i) {
+ while (p < s->sourceLabels[i].label) {
s->textSources[p - s->textStart]
= sourceSeqsIndex;
++p;
}
- sourceSeqsIndex = s->profileLabels[i].sourceSeqsIndex;
+ sourceSeqsIndex = s->sourceLabels[i].sourceSeqsIndex;
}
for ( ; p < s->textEnd; ++p)
s->textSources[p - s->textStart] = sourceSeqsIndex;
}
+ /* Process command-line arguments. */
i = 1;
if (argc > 1 and (0 == strcmp (argv [1], "@MLton"))) {
bool done;
@@ -3469,6 +3574,7 @@
newWorld (s);
else
loadWorld (s, worldFile);
+ s->amInGC = FALSE;
assert (mutatorInvariant (s));
return i;
}
1.49 +109 -27 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- gc.h 20 Dec 2002 17:17:20 -0000 1.48
+++ gc.h 2 Jan 2003 17:45:22 -0000 1.49
@@ -63,6 +63,8 @@
/* Sizes are (almost) always measured in bytes. */
enum {
+ DEBUG_PROFILE_ALLOC = FALSE,
+ DEBUG_PROFILE_TIME = FALSE,
WORD_SIZE = 4,
COUNTER_MASK = 0x7FF00000,
COUNTER_SHIFT = 20,
@@ -73,6 +75,8 @@
LIMIT_SLOP = 512,
MARK_MASK = 0x80000000,
POINTER_SIZE = WORD_SIZE,
+ SOURCES_INDEX_UNKNOWN = 0,
+ SOURCES_INDEX_GC = 1,
SOURCE_SEQ_UNKNOWN = 0,
STACK_TYPE_INDEX = 0,
STRING_TYPE_INDEX = 1,
@@ -83,6 +87,11 @@
#define TWOPOWER(n) (1 << (n))
+typedef enum {
+ PROFILE_CURRENT,
+ PROFILE_CUMULATIVE,
+} ProfileStyle;
+
/* ------------------------------------------------- */
/* object type */
/* ------------------------------------------------- */
@@ -103,7 +112,6 @@
/* initialization */
/* ------------------------------------------------- */
-
/*
* GC_init uses the array of struct intInfInits in s at program start to
* allocate intInfs.
@@ -129,11 +137,6 @@
uint size;
};
-typedef struct GC_profileLabel {
- pointer label;
- uint sourceSeqsIndex;
-} *GC_profileLabel;
-
/* ------------------------------------------------- */
/* GC_frameLayout */
/* ------------------------------------------------- */
@@ -197,6 +200,52 @@
} *GC_thread;
/* ------------------------------------------------- */
+/* Profiling */
+/* ------------------------------------------------- */
+
+typedef struct GC_sourceLabel {
+ pointer label;
+ uint sourceSeqsIndex;
+} *GC_profileLabel;
+
+typedef struct GC_profileAlloc {
+ /* bytesAllocated is an array of length sourcesSize that counts for
+ * each function the number of bytes that have been allocated.
+ * If profileStyle == PROFILE_CURRENT, then it is the number while
+ * that function was current. If profileStyle == PROFILE_CUMULATIVE,
+ * then it is the number while the function was on the stack.
+ */
+ ullong *bytesAllocated;
+ /* lastTotal is an array of length sourcesSize that for each function,
+ * f, stores the value of totalBytesAllocated when the oldest occurrence
+ * of f on the stack was pushed, i.e., the most recent time that
+ * stackCount[f] was changed from 0 to 1. lastTotal is used to compute
+ * the number of bytes to attribute to f when the oldest occurrence is
+ * finally popped. lastTotal is only used if
+ * profileStyle == PROFILE_CUMULATIVE.
+ */
+ ullong *lastTotal;
+ /* stackCount is an array of length sourcesSize that counts the number
+ * of times each function is on the stack. It is only used if
+ * profileStyle == PROFILE_CUMULATIVE.
+ */
+ uint *stackCount;
+ ullong totalBytesAllocated;
+} *GC_profileAlloc;
+
+typedef struct GC_profileTime {
+ /* ticks is an array of length sourcesSize that counts for each function
+ * the number of clock ticks that have happened while the function was
+ * on top of the stack (if profileStyle == PROFILE_CURRENT) or anywhere
+ * on the stack (if profileStyle == PROFILE_CUMULATIVE).
+ * With a 32 bits, a counter cannot overflow for 2^32 / 100 seconds,
+ * or a bit over 1 CPU year.
+ */
+ uint *ticks;
+ uint totalTicks;
+} *GC_profileTime;
+
+/* ------------------------------------------------- */
/* GC_heap */
/* ------------------------------------------------- */
@@ -257,10 +306,23 @@
GC_heap crossMapHeap; /* only used during GC. */
pointer crossMap;
uint crossMapSize;
+ /* currentSource is the index in sources of the currently executing
+ * function. This is only used when allocation profiling with
+ * profileStyle = PROFILE_CURRENT;
+ */
+ uint currentSource;
GC_thread currentThread; /* This points to a thread in the heap. */
uint fixedHeapSize; /* Only meaningful if useFixedHeap. */
GC_frameLayout *frameLayouts;
- pointer *globals; /* An array of size numGlobals. */
+ uint frameLayoutsSize;
+ /* frameSources is an array of length frameLayoutsSize that for each
+ * stack frame, gives an index into sourceSeqs of the sequence of
+ * source functions corresponding to the frame.
+ */
+ uint *frameSources;
+ uint frameSourcesSize;
+ pointer *globals;
+ uint globalsSize;
float growRatio;
struct GC_heap heap;
struct GC_heap heap2; /* Used for major copying collection. */
@@ -299,13 +361,10 @@
*/
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.
*/
@@ -313,30 +372,17 @@
pointer nursery;
uint nurserySize;
GC_ObjectType *objectTypes; /* Array of object types. */
+ uint objectTypesSize;
/* Arrays larger than oldGenArraySize are allocated in the old generation
* instead of the nursery, if possible.
*/
W32 oldGenArraySize;
uint oldGenSize;
uint pageSize; /* bytes */
- ullong *profileAllocCounts; /* allocation profiling */
- uint profileAllocIndex;
+ GC_profileAlloc profileAlloc;
bool profileAllocIsOn;
- /* 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;
+ ProfileStyle profileStyle;
+ GC_profileTime profileTime;
bool profileTimeIsOn;
W32 ram; /* ramSlop * totalRam */
float ramSlop;
@@ -366,6 +412,22 @@
* signal handler.
*/
sigset_t signalsPending;
+ /* sourceIsOnStack is an array of bools of length sourcesSize. It is
+ * used during stack walking (when time profiling with
+ * profileStyle == PROFILE_CUMULATIVE) to count each source function
+ * only once no matter how many times it appears on the stack.
+ */
+ char *sourceIsOnStack;
+ struct GC_sourceLabel *sourceLabels;
+ uint sourceLabelsSize;
+ /* sources is an array of strings identifying source positions. */
+ string *sources;
+ uint sourcesSize;
+ /* Each entry in sourceSeqs is a vector, whose first element is
+ * a length, and subsequent elements index into sources.
+ */
+ int **sourceSeqs;
+ uint sourceSeqsSize;
pointer stackBottom; /* The bottom of the stack in the current thread. */
uint startTime; /* The time when GC_init or GC_loadWorld was called. */
/* The inits array should be NULL terminated,
@@ -451,6 +513,11 @@
*/
void GC_finishHandler (GC_state s);
+/* GC_foreachStackFrame (s, f) applies f to the frameLayout index of each frame
+ * in the stack.
+ */
+void GC_foreachStackFrame (GC_state s, void (*f) (GC_state s, uint i));
+
/* GC_gc does a gc.
* This will also resize the stack if necessary.
* It will also switch to the signal handler thread if there is a pending signal.
@@ -517,6 +584,19 @@
and slot < s->stackBottom + s->currentThread->stack->reserved;
}
+/* 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.
+ */
+void GC_profileAllocFree (GC_state s, GC_profileAlloc pa);
+GC_profileAlloc GC_profileAllocNew (GC_state s);
+void GC_profileAllocWrite (GC_state s, GC_profileAlloc pa, int fd);
+void GC_profileTimeFree (GC_state s, GC_profileTime pt);
+GC_profileTime GC_profileTimeNew (GC_state s);
+void GC_profileTimeWrite (GC_state s, GC_profileTime pt, int fd);
+
/*
* Build the header for an object, given the index to its type info.
*/
@@ -527,6 +607,8 @@
/* Pack the heap into a small amount of RAM. */
void GC_pack (GC_state s);
+
+void GC_profile (GC_state s, uint sourceSeqsIndex);
/* Write out the current world to the file descriptor. */
void GC_saveWorld (GC_state s, int fd);
1.18 +20 -0 mlton/runtime/my-lib.c
Index: my-lib.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/my-lib.c,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- my-lib.c 2 Nov 2002 03:37:41 -0000 1.17
+++ my-lib.c 2 Jan 2003 17:45:22 -0000 1.18
@@ -50,6 +50,17 @@
return b ? "TRUE" : "FALSE";
}
+void *scalloc (size_t nmemb, size_t size) {
+ void *res;
+
+ res = calloc (nmemb, size);
+ if (NULL == res)
+ die ("calloc (%s, %s) failed.\n",
+ uintToCommaString (nmemb),
+ uintToCommaString (size));
+ return res;
+}
+
void sclose (int fd) {
unless (0 == close (fd))
diee ("unable to close %d", fd);
@@ -207,6 +218,15 @@
}
}
return buf + i + 1;
+}
+
+void *smalloc(size_t length) {
+ void *res;
+
+ res = malloc (length);
+ if (NULL == res)
+ die ("Unable to malloc %s bytes.\n", uintToCommaString (length));
+ return res;
}
/* ------------------------------------------------- */
1.9 +19 -10 mlton/runtime/my-lib.h
Index: my-lib.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/my-lib.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- my-lib.h 20 Dec 2002 17:17:20 -0000 1.8
+++ my-lib.h 2 Jan 2003 17:45:22 -0000 1.9
@@ -35,6 +35,11 @@
#define NULL 0 /* invalid pointer */
#endif
+#define NEW(x) \
+ x = (typeof(x))smalloc(sizeof(*x))
+#define ARRAY(a, s) \
+ a = (typeof(a))scalloc(s, sizeof(*a))
+
#define string char*
#define unless(p) if (not (p))
@@ -66,6 +71,8 @@
string boolToString (bool b);
+void *scalloc (size_t nmemb, size_t size);
+
/* safe version of close, mkstemp, write */
int smkstemp (char *template);
void sclose (int fd);
@@ -75,20 +82,22 @@
/* safe versions of fopen, fread, fwrite */
void sfclose (FILE *file);
-FILE *sfopen(char *fileName, char *mode);
-void sfread(void *ptr, size_t size, size_t nmemb, FILE *file);
-uint sfreadUint(FILE *file);
-void sfwrite(void *ptr, size_t size, size_t nmemb, FILE *file);
-void sfwriteUint(uint n, FILE *file);
+FILE *sfopen (char *fileName, char *mode);
+void sfread (void *ptr, size_t size, size_t nmemb, FILE *file);
+uint sfreadUint (FILE *file);
+void sfwrite (void *ptr, size_t size, size_t nmemb, FILE *file);
+void sfwriteUint (uint n, FILE *file);
+
+void *smalloc (size_t length);
/* safe mmap and munmap */
-void *smmap(size_t length);
-void smunmap(void *base, size_t length);
+void *smmap (size_t length);
+void smunmap (void *base, size_t length);
void sunlink (char *path);
/* Return a statically allocated comma separated string */
-string intToCommaString(int n);
-string uintToCommaString(uint n);
-string ullongToCommaString(ullong n);
+string intToCommaString (int n);
+string uintToCommaString (uint n);
+string ullongToCommaString (ullong n);
#endif
1.9 +135 -93 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.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- profile-alloc.c 20 Dec 2002 17:17:21 -0000 1.8
+++ profile-alloc.c 2 Jan 2003 17:45:23 -0000 1.9
@@ -1,4 +1,4 @@
-#if (defined (__linux__) || defined (__FreeBSD__))
+#if (defined (__linux__) || defined (__CYGWIN__) || defined (__FreeBSD__))
#include <string.h>
#include "gc.h"
@@ -6,15 +6,17 @@
#include "my-lib.h"
enum {
- DEBUG_PROFILE_ALLOC = FALSE,
+ PROFILE_ALLOC_GC = 0,
};
extern struct GC_state gcState;
Pointer MLton_ProfileAlloc_current (void) {
+ GC_state s;
Pointer res;
- res = (Pointer)gcState.profileAllocCounts;
+ s = &gcState;
+ res = (Pointer)s->profileAlloc;
if (DEBUG_PROFILE_ALLOC)
fprintf (stderr, "0x%0x8 = MLton_ProfileAlloc_current ()\n",
(uint)res);
@@ -22,124 +24,164 @@
}
void MLton_ProfileAlloc_setCurrent (Pointer d) {
+ GC_state s;
+
+ s = &gcState;
if (DEBUG_PROFILE_ALLOC)
fprintf (stderr, "MLton_ProfileAlloc_setCurrent (0x%08x)\n",
(uint)d);
- gcState.profileAllocCounts = (ullong*)d;
+ s->profileAlloc = (GC_profileAlloc)d;
}
-void MLton_ProfileAlloc_inc (Word amount) {
+void MLton_ProfileAlloc_done () {
+ int i;
GC_state s;
- uint *sourceSeq;
+ GC_profileAlloc pa;
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "MLton_ProfileAlloc_done ()\n");
s = &gcState;
- if (DEBUG_PROFILE_ALLOC)
- fprintf (stderr, "MLton_ProfileAlloc_inc (%u, %u)\n",
- s->profileAllocIndex,
- (uint)amount);
+ pa = s->profileAlloc;
assert (s->profileAllocIsOn);
- assert (s->profileAllocIndex < s->profileSourceSeqsSize);
- sourceSeq = s->profileSourceSeqs [s->profileAllocIndex];
- assert (sourceSeq [0] > 0);
- assert (sourceSeq [1] < s->profileSourcesSize);
- s->profileAllocCounts [sourceSeq [1]] += amount;
-}
-
-Pointer MLton_ProfileAlloc_Data_malloc (void) {
-/* Note, perhaps this code should use mmap()/munmap() instead of
- * malloc()/free() for the array of bins.
- */
- ullong *data;
-
- assert (gcState.profileAllocIsOn);
- 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;
+ s->profileAllocIsOn = FALSE;
+ switch (s->profileStyle) {
+ case PROFILE_CUMULATIVE:
+ for (i = 0; i < s->sourcesSize; ++i) {
+ if (pa->stackCount[i] > 0) {
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "leaving %s\n", s->sources[i]);
+ pa->bytesAllocated[i] +=
+ pa->totalBytesAllocated - pa->lastTotal[i];
+ }
+ }
+ break;
+ case PROFILE_CURRENT:
+ break;
+ }
}
-void MLton_ProfileAlloc_Data_free (Pointer d) {
- ullong *data;
+void MLton_ProfileAlloc_inc (Word amount) {
+ GC_state s;
+ assert (s->profileAllocIsOn);
+ s = &gcState;
if (DEBUG_PROFILE_ALLOC)
- fprintf (stderr, "MLton_ProfileAlloc_Data_free (0x%08x)\n",
- (uint)d);
- assert (gcState.profileAllocIsOn);
- data = (ullong*)d;
- assert (data != NULL);
- free (data);
-}
-
-void MLton_ProfileAlloc_Data_reset (Pointer d) {
- uint *data;
+ fprintf (stderr, "MLton_ProfileAlloc_inc (%u, %u)\n",
+ s->currentSource,
+ (uint)amount);
+ if (s->amInGC) {
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "amInGC\n");
+ s->profileAlloc->bytesAllocated [SOURCES_INDEX_GC] += amount;
+ } else {
+ s->profileAlloc->totalBytesAllocated += amount;
+ switch (s->profileStyle) {
+ case PROFILE_CUMULATIVE:
+ break;
+ case PROFILE_CURRENT:
+ s->profileAlloc->bytesAllocated [s->currentSource]
+ += amount;
+ break;
+ }
+ }
+}
+
+void MLton_ProfileAlloc_incLeaveEnter (Word amount, Word leave, Word enter) {
+ int i;
+ GC_profileAlloc pa;
+ GC_state s;
+ uint sourceIndex;
+ uint *sourceSeq;
+ s = &gcState;
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.profileSourcesSize * sizeof(*data));
+ fprintf (stderr, "MLton_ProfileAlloc_incLeaveEnter (%u, %u, %u)\n",
+ (uint)amount, (uint)leave, (uint)enter);
+ unless (s->profileAllocIsOn)
+ return;
+ MLton_ProfileAlloc_inc (amount);
+ switch (s->profileStyle) {
+ case PROFILE_CUMULATIVE:
+ pa = s->profileAlloc;
+ /* Leave. */
+ sourceSeq = s->sourceSeqs[leave];
+ for (i = 1; i <= sourceSeq[0]; ++i) {
+ sourceIndex = sourceSeq[i];
+ assert (pa->stackCount[sourceIndex] > 0);
+ pa->stackCount[sourceIndex]--;
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "leaving %s",
+ s->sources[sourceIndex]);
+ if (0 == pa->stackCount[sourceIndex]) {
+ ullong alloc;
+
+ alloc = pa->totalBytesAllocated
+ - pa->lastTotal[sourceIndex];
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, " with %llu bytes\n",
+ alloc);
+ pa->bytesAllocated[sourceIndex] += alloc;
+ } else {
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "\n");
+ }
+ }
+ /* Enter. */
+ sourceSeq = s->sourceSeqs[enter];
+ for (i = 1; i < sourceSeq[0]; ++i) {
+ sourceIndex = sourceSeq[i];
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "entering %s\n",
+ s->sources[sourceIndex]);
+ if (0 == pa->stackCount[sourceIndex]) {
+ pa->lastTotal[sourceIndex] =
+ pa->totalBytesAllocated;
+ }
+ pa->stackCount[sourceIndex]++;
+ }
+ break;
+ case PROFILE_CURRENT:
+ sourceSeq = s->sourceSeqs[enter];
+ /* The current source is the last function entered. There is
+ * a hack in profile.fun to put the right thing there even if
+ * no functions are entered.
+ */
+ s->currentSource = sourceSeq[sourceSeq[0]];
+ break;
+ }
}
-static void writeString (int fd, string s) {
- swrite (fd, s, strlen(s));
- swrite (fd, "\n", 1);
+void MLton_ProfileAlloc_setCurrentSource (Word sourceIndex) {
+ gcState.currentSource = sourceIndex;
}
-static void writeWord (int fd, word w) {
- char buf[20];
+Pointer MLton_ProfileAlloc_Data_malloc (void) {
+ Pointer res;
+ GC_state s;
- sprintf (buf, "0x%08x", w);
- writeString (fd, buf);
+ s = &gcState;
+ res = (Pointer)GC_profileAllocNew (s);
+ return res;
}
-static void writeUllong (int fd, ullong u) {
- char buf[20];
+void MLton_ProfileAlloc_Data_free (Pointer pa) {
+ GC_state s;
- sprintf (buf, "%llu", u);
- writeString (fd, buf);
+ s = &gcState;
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "MLton_ProfileAlloc_Data_free (0x%08x)",
+ (uint)pa);
+ GC_profileAllocFree (s, (GC_profileAlloc)pa);
}
-void MLton_ProfileAlloc_Data_write (Pointer d, Word fd) {
-/* Write a profile data array out to a file descriptor */
- ullong *data;
- uint i;
+void MLton_ProfileAlloc_Data_write (Pointer pa, Word fd) {
+ GC_state s;
+ s = &gcState;
if (DEBUG_PROFILE_ALLOC)
fprintf (stderr, "MLton_ProfileAlloc_Data_write (0x%08x, %u)\n",
- (uint)d, (uint)fd);
- assert (gcState.profileAllocIsOn);
- data = (ullong*)d;
- 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__))
-
-/* No profiling on Cygwin.
- * There is a check in mlton/main/main.sml to make sure that profiling is never
- * turned on on Cygwin.
- */
-
-/* We have to put some stubs here because the runtime initialization code uses
- * them.
- */
-#include "mlton-basis.h"
-
-Pointer MLton_ProfileAlloc_Data_malloc (void) {
- die ("no allocation profiling on Cygwin");
-}
-
-void MLton_ProfileAlloc_setCurrent (Pointer d) {
- die ("no allocation profiling on Cygwin");
+ (uint)pa, (uint)fd);
+ GC_profileAllocWrite (s, (GC_profileAlloc)pa, fd);
}
#else
1.10 +103 -84 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.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- profile-time.c 19 Dec 2002 23:43:37 -0000 1.9
+++ profile-time.c 2 Jan 2003 17:45:23 -0000 1.10
@@ -16,121 +16,126 @@
#define EIP 14
#endif
-enum {
- DEBUG_PROFILE = FALSE,
-};
-
extern struct GC_state gcState;
-/* 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;
-
Pointer MLton_ProfileTime_current () {
- if (DEBUG_PROFILE)
+ GC_state s;
+
+ s = &gcState;
+ if (DEBUG_PROFILE_TIME)
fprintf (stderr, "0x%08x = MLton_ProfileTime_current ()\n",
- (uint)current);
- return (Pointer)current;
+ (uint)s->profileTime);
+ return (Pointer)s->profileTime;
}
void MLton_ProfileTime_setCurrent (Pointer d) {
- uint *data;
+ GC_state s;
- if (DEBUG_PROFILE)
+ s = &gcState;
+ if (DEBUG_PROFILE_TIME)
fprintf (stderr, "MLton_ProfileTime_setCurrent (0x%08x)\n",
(uint)d);
- data = (uint*)d;
- assert (data != NULL);
- current = data;
+ s->profileTime = (typeof(s->profileTime))d;
}
Pointer MLton_ProfileTime_Data_malloc (void) {
- /* Note, perhaps this code should use mmap()/munmap() instead of
- * malloc()/free() for the array of bins.
- */
- uint *data;
-
- data = (uint *)malloc (gcState.profileSourcesSize * sizeof(*data));
- if (data == NULL)
- die ("Out of memory");
- MLton_ProfileTime_Data_reset ((Pointer)data);
- if (DEBUG_PROFILE)
+ GC_state s;
+ GC_profileTime pt;
+
+ s = &gcState;
+ pt = GC_profileTimeNew (s);
+ if (DEBUG_PROFILE_TIME)
fprintf (stderr, "0x%08x = MLton_ProfileTimeData_malloc ()\n",
- (uint)data);
- return (Pointer)data;
+ (uint)pt);
+ return (Pointer)pt;
}
void MLton_ProfileTime_Data_free (Pointer d) {
- uint *data;
+ GC_state s;
- if (DEBUG_PROFILE)
+ s = &gcState;
+ if (DEBUG_PROFILE_TIME)
fprintf (stderr, "MLton_ProfileTime_Data_free (0x%08x)",
(uint)d);
- data = (uint*)d;
- assert (data != NULL);
- free (data);
- if (DEBUG_PROFILE)
+ GC_profileTimeFree (s, (GC_profileTime)d);
+ if (DEBUG_PROFILE_TIME)
fprintf (stderr, "\n");
}
-void MLton_ProfileTime_Data_reset (Pointer d) {
- uint *data;
-
- data = (uint*)d;
- assert (data != NULL);
- memset (data, 0, gcState.profileSourcesSize * sizeof(*data));
-}
+void MLton_ProfileTime_Data_write (Pointer d, Word fd) {
+ GC_state s;
-static void writeString (int fd, string s) {
- swrite (fd, s, strlen(s));
- swrite (fd, "\n", 1);
+ s = &gcState;
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, "MLton_ProfileTime_Data_Write (0x%08x, %ld)\n",
+ (uint)d, fd);
+ GC_profileTimeWrite (s, (GC_profileTime) d, fd);
}
-static void writeWord (int fd, word w) {
- char buf[20];
-
- sprintf (buf, "0x%08x", w);
- writeString (fd, buf);
+static void incAndMark (GC_state s, uint sourceSeqsIndex) {
+ uint i;
+ uint length;
+ uint source;
+ uint *sourceSeq;
+
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, "incAndMark (%u)\n", sourceSeqsIndex);
+ assert (sourceSeqsIndex < s->sourceSeqsSize);
+ sourceSeq = s->sourceSeqs [sourceSeqsIndex];
+ length = sourceSeq[0];
+ for (i = 1; i <= length; ++i) {
+ source = sourceSeq[i];
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, "reached %s ", s->sources[source]);
+ if (s->sourceIsOnStack[source]) {
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, " already on stack\n");
+ } else {
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, "bumping\n");
+ s->sourceIsOnStack[source] = TRUE;
+ s->profileTime->ticks[source]++;
+ }
+ }
}
-static void writeUint (int fd, uint w) {
- char buf[20];
-
- sprintf (buf, "%u", w);
- writeString (fd, buf);
+static void incAndMarkFrame (GC_state s, uint frameSourcesIndex) {
+ incAndMark (s, s->frameSources[frameSourcesIndex]);
}
-void MLton_ProfileTime_Data_write (Pointer d, Word fd) {
-/* 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.
- * All values except for the initial string are unsigned integers in
- * the native machine format (4 bytes, little-endian).
- */
- uint *data;
+static void unmark (GC_state s, uint sourceSeqsIndex) {
uint i;
+ uint length;
+ uint source;
+ uint *sourceSeq;
+
+ sourceSeq = s->sourceSeqs [sourceSeqsIndex];
+ length = sourceSeq[0];
+ for (i = 1; i <= length; ++i) {
+ source = sourceSeq[i];
+ s->sourceIsOnStack [source] = FALSE;
+ }
+}
- if (DEBUG_PROFILE)
- fprintf (stderr, "MLton_ProfileTime_Data_Write (0x%08x, %ld)\n",
- (uint)d, fd);
- data = (uint*)d;
- writeString (fd, "MLton prof");
- writeString (fd, "time");
- writeWord (fd, gcState.magic);
- for (i = 0; i < gcState.profileSourcesSize; ++i)
- writeUint (fd, data[i]);
+static void unmarkFrame (GC_state s, uint frameSourcesIndex) {
+ unmark (s, s->frameSources[frameSourcesIndex]);
}
/*
* Called on each SIGPROF interrupt.
*/
static void catcher (int sig, siginfo_t *sip, ucontext_t *ucp) {
- uint i;
+ GC_state s;
pointer pc;
+ uint *sourceSeq;
+ uint sourceSeqsIndex;
+ s = &gcState;
+ s->profileTime->totalTicks++;
+ if (s->amInGC) {
+ s->profileTime->ticks [SOURCES_INDEX_GC]++;
+ return;
+ }
#if (defined (__linux__))
pc = (pointer) ucp->uc_mcontext.gregs[EIP];
#elif (defined (__FreeBSD__))
@@ -138,15 +143,29 @@
#else
#error pc not defined
#endif
- if (gcState.textStart <= pc and pc < gcState.textEnd)
- i = gcState.textSources [pc - gcState.textStart];
- else
- i = SOURCE_SEQ_UNKNOWN;
- assert (i < gcState.profileSourceSeqsSize);
-
- ++current[gcState.profileSourceSeqs[i][1]];
- unless (TRUE or gcState.amInGC)
- free (GC_stackFrameIndices (&gcState));
+ if (DEBUG_PROFILE_TIME)
+ fprintf (stderr, "pc = 0x%08x\n", (uint)pc);
+ if (s->textStart <= pc and pc < s->textEnd) {
+ sourceSeqsIndex = s->textSources [pc - s->textStart];
+ } else {
+ sourceSeqsIndex = SOURCE_SEQ_UNKNOWN;
+ }
+ assert (sourceSeqsIndex < s->sourceSeqsSize);
+ switch (s->profileStyle) {
+ case PROFILE_CUMULATIVE:
+ /* Walk all the stack frames. */
+ incAndMark (s, sourceSeqsIndex);
+ GC_foreachStackFrame (s, incAndMarkFrame);
+ unmark (s, sourceSeqsIndex);
+ GC_foreachStackFrame (s, unmarkFrame);
+ break;
+ case PROFILE_CURRENT:
+ sourceSeq = s->sourceSeqs [sourceSeqsIndex];
+ assert (sourceSeq [0] > 0);
+ assert (sourceSeq [1] < s->sourcesSize);
+ s->profileTime->ticks [sourceSeq [1]]++;
+ break;
+ }
}
void MLton_ProfileTime_init (void) {
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel