[MLton-devel] cvs commit: merge of allocation profiling branch
Stephen Weeks
sweeks@users.sourceforge.net
Fri, 01 Nov 2002 19:37:42 -0800
sweeks 02/11/01 19:37:42
Modified: basis-library build-basis
basis-library/misc primitive.sml
basis-library/mlton itimer.sml mlton.sig mlton.sml
profile.sig signal.sml
basis-library/real real.sig real.sml
doc changelog
doc/examples/profiling .cvsignore Makefile profiling2.sml
doc/user-guide basis.tex extensions.tex man-page.tex
profiling.tex
include ccodegen.h x86codegen.h
lib/mlton sources.cm
lib/mlton/basic euclidean-ring.fun hash-set.sig hash-set.sml
integer.fun merge-sort.sml outstream.sig
outstream0.sml popt.sig popt.sml real.sig real.sml
ring-with-identity.fun ring-with-identity.sig
sources.cm unique-set.fun word.sig word.sml
word8.sml
lib/mlton/pervasive sources.cm
lib/mlton-stubs sources.cm
lib/mlton-stubs-in-smlnj int-inf-sig.cm int-inf.sig
pre-int-inf-sig.sml real.sml sources.cm word.sml
lib/mlyacc sources.cm
lib/smlnj sources.cm
man mlprof.1 mlton.1
mllex mllex-stubs.cm mllex.cm
mlprof main.sml mlprof-stubs.cm mlprof.cm
mlton mlton-stubs.cm mlton.cm
mlton/atoms prim.fun prim.sig
mlton/backend backend.fun c-function.fun c-function.sig
chunkify.fun limit-check.fun machine.fun
machine.sig rssa.fun rssa.sig runtime.fun
runtime.sig signal-check.fun sources.cm
ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-codegen.fun
x86-mlton-basic.fun x86-mlton-basic.sig
x86-translate.fun x86.fun x86.sig
mlton/control control.sig control.sml
mlton/core-ml lookup-constant.fun
mlton/main compile.sml main.sml
mlyacc mlyacc-stubs.cm mlyacc.cm
runtime IntInf.h Makefile gc.c gc.h mlton-basis.h my-lib.c
my-lib.h
runtime/basis IntInf.c
Added: basis-library/mlton profile-alloc.sml profile-data.sig
profile-time.sml profile.fun
doc/examples/profiling profiling-alloc.sml
lib/mlton-stubs real.sml
mlton/backend profile-alloc.fun profile-alloc.sig
regression real.fromLargeInt.ok real.fromLargeInt.sml
real.split.ok real.split.sml real.toFromLargeInt.ok
real.toFromLargeInt.sml real.toLargeInt.ok
real.toLargeInt.sml real8.ok real8.sml
runtime/basis/MLton profile-alloc.c profile-time.c
Removed: basis-library/mlton profile.sml
lib/mlton mlton.cm
mlton/backend array-init.fun array-init.sig
runtime/basis/MLton profile.c
Log:
This is a merge of the branch I have been workng on that adds support
for allocation profiling to the compiler and mlprof.
* Replaced -profile {false|true} with -profile {no|alloc|time}
* Renamed MLton.Profile as MLton.ProfileTime
* Added MLton.ProfileAlloc for selective allocation profiling
* Cleaned up and changed most mlprof option names, mlprof.1 man page
Internally, this change involved changing the format of mlmon.out
files. They now use a sparse representation, with one entry for each
address that has a nonzero count. The file can use either 4 byte or
8 byte counts, and there is a flag in the header to indicate this.
Time profiling uses 4 byte counts and allocation profiling uses 8 byte
counts. The mlmon.out header now also includes the executable magic
number, so that mlprof can do sanity checking and make sure the
executable and mlmon.out match.
mlprof now uses IntInfs for its counters. Because I needed
conversions between IntInfs and reals, I added the missing basis
library functions Real.{fromTo}LargeInt.
Time profiling works as before, using a single array of 4 byte counts
with as many elements as there are addresses in the text segment.
Allocation profiling works by keeping two parallel arrays, one of
addresses and one of 8 byte counts. There are as many array elements
as there are basic blocks in the SSA program that allocate. In the
compiler, there is a new pass at the end of the RSSA pipeline that
inserts a call to a C function in each basic block that allocates.
The C function bumps the appropriate counter. I haven't done
benchmarking yet to see how much -profile alloc hurts in time and code
size. I will.
Along the way I got rid of some old cruft:
* inline array allocation code
* c-codegen profiling code
There are no known problems with the profiling per se. However,
running the regressions -profile alloc tickles what appears to be an
x86 codegen register allocation bug. Matthew, can you look into this?
The errors look like
chooseRegister:
...
mlton: x86AllocateRegister.allocateRegisters::toRegisterMemLoc:reSpill
Revision Changes Path
1.13 +4 -1 mlton/basis-library/build-basis
Index: build-basis
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/build-basis,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- build-basis 17 Jun 2002 06:28:56 -0000 1.12
+++ build-basis 2 Nov 2002 03:37:34 -0000 1.13
@@ -152,8 +152,11 @@
mlton/word.sig
mlton/proc-env.sig
mlton/proc-env.sml
+mlton/profile-data.sig
mlton/profile.sig
-mlton/profile.sml
+mlton/profile.fun
+mlton/profile-alloc.sml
+mlton/profile-time.sml
mlton/rlimit.sig
mlton/rlimit.sml
mlton/rusage.sig
1.38 +39 -11 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- primitive.sml 31 Oct 2002 19:30:12 -0000 1.37
+++ primitive.sml 2 Nov 2002 03:37:34 -0000 1.38
@@ -294,25 +294,53 @@
val native = _build_const "MLton_native": bool;
- structure Profile =
+ structure ProfileAlloc =
struct
- val profile = _build_const "MLton_profile": bool;
+ val isOn = _build_const "MLton_profile_alloc": bool;
structure Data =
struct
type t = word
- val dummy = 0wx0: t;
- val free = _ffi "MLton_Profile_Data_free": t -> unit;
- val malloc = _ffi "MLton_Profile_Data_malloc": unit -> t;
- val reset = _ffi "MLton_Profile_Data_reset": t -> unit;
+
+ val dummy:t = 0w0
+ val free =
+ _ffi "MLton_ProfileAlloc_Data_free": t -> unit;
+ val malloc =
+ _ffi "MLton_ProfileAlloc_Data_malloc": unit -> t;
+ val reset =
+ _ffi "MLton_ProfileAlloc_Data_reset": t -> unit;
val write =
- _ffi "MLton_Profile_Data_write"
+ _ffi "MLton_ProfileAlloc_Data_write"
: t * word (* fd *) -> unit;
end
- val init = _ffi "MLton_Profile_init": unit -> unit;
+ val current =
+ _ffi "MLton_ProfileAlloc_current": unit -> Data.t;
val setCurrent =
- _ffi "MLton_Profile_setCurrent": Data.t -> unit;
- val installHandler =
- _ffi "MLton_Profile_installHandler": unit -> unit;
+ _ffi "MLton_ProfileAlloc_setCurrent": Data.t -> unit;
+ end
+
+ structure ProfileTime =
+ struct
+ val isOn = _build_const "MLton_profile_time": bool;
+ structure Data =
+ struct
+ type t = word
+
+ val dummy:t = 0w0
+ val free =
+ _ffi "MLton_ProfileTime_Data_free": t -> unit;
+ val malloc =
+ _ffi "MLton_ProfileTime_Data_malloc": unit -> t;
+ val reset =
+ _ffi "MLton_ProfileTime_Data_reset": t -> unit;
+ val write =
+ _ffi "MLton_ProfileTime_Data_write"
+ : t * word (* fd *) -> unit;
+ end
+ val current =
+ _ffi "MLton_ProfileTime_current": unit -> Data.t;
+ val init = _ffi "MLton_ProfileTime_init": unit -> unit;
+ val setCurrent =
+ _ffi "MLton_ProfileTime_setCurrent": Data.t -> unit;
end
structure Rlimit =
1.5 +1 -1 mlton/basis-library/mlton/itimer.sml
Index: itimer.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/itimer.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- itimer.sml 31 Mar 2002 00:44:07 -0000 1.4
+++ itimer.sml 2 Nov 2002 03:37:34 -0000 1.5
@@ -19,7 +19,7 @@
Prim.set (toInt t, s1, u1, s2, u2)
fun set (z as (t, _)) =
- if Primitive.MLton.Profile.profile
+ if Primitive.MLton.ProfileTime.isOn
andalso t = Prof
then let
open PosixError
1.16 +2 -1 mlton/basis-library/mlton/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- mlton.sig 31 Oct 2002 19:30:12 -0000 1.15
+++ mlton.sig 2 Nov 2002 03:37:34 -0000 1.16
@@ -33,7 +33,8 @@
structure Itimer: MLTON_ITIMER
structure ProcEnv: MLTON_PROC_ENV
structure Process: MLTON_PROCESS
- structure Profile: MLTON_PROFILE
+ structure ProfileAlloc: MLTON_PROFILE
+ structure ProfileTime: MLTON_PROFILE
structure Ptrace: MLTON_PTRACE
structure Random: MLTON_RANDOM
structure Rlimit: MLTON_RLIMIT
1.15 +2 -2 mlton/basis-library/mlton/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sml,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- mlton.sml 31 Oct 2002 19:30:12 -0000 1.14
+++ mlton.sml 2 Nov 2002 03:37:34 -0000 1.15
@@ -58,8 +58,8 @@
structure ProcEnv = ProcEnv
structure Process = Process
structure Ptrace = Ptrace
-structure Profile = Profile (structure Cleaner = Cleaner
- structure Profile = Prim.Profile)
+structure ProfileAlloc = ProfileAlloc
+structure ProfileTime = ProfileTime
structure Random = Random
structure Rlimit = Rlimit
structure Rusage = Rusage
1.3 +2 -13 mlton/basis-library/mlton/profile.sig
Index: profile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/profile.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- profile.sig 22 Jan 2002 23:25:28 -0000 1.2
+++ profile.sig 2 Nov 2002 03:37:34 -0000 1.3
@@ -3,20 +3,9 @@
signature MLTON_PROFILE =
sig
- (* a compile-time constant *)
- val profile: bool
+ structure Data: PROFILE_DATA
- structure Data:
- sig
- type t
-
- val equals: t * t -> bool
- val free: t -> unit
- val malloc: unit -> t
- val reset: t -> unit
- val write: t * string -> unit
- end
-
val current: unit -> Data.t
+ val isOn: bool (* a compile-time constant *)
val setCurrent: Data.t -> unit
end
1.14 +1 -1 mlton/basis-library/mlton/signal.sml
Index: signal.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/signal.sml,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- signal.sml 10 Sep 2002 16:08:04 -0000 1.13
+++ signal.sml 2 Nov 2002 03:37:34 -0000 1.14
@@ -89,7 +89,7 @@
Array.modifyi (defaultOrIgnore o #1) (handlers, 0, NONE))
in
(fn s => Array.sub (handlers, s),
- fn (s, h) => if Primitive.MLton.Profile.profile andalso s = prof
+ fn (s, h) => if Primitive.MLton.ProfileTime.isOn andalso s = prof
then
let
open PosixError
1.2 +1 -0 mlton/basis-library/mlton/profile-alloc.sml
1.2 +10 -0 mlton/basis-library/mlton/profile-data.sig
1.2 +24 -0 mlton/basis-library/mlton/profile-time.sml
1.2 +141 -0 mlton/basis-library/mlton/profile.fun
1.4 +2 -2 mlton/basis-library/real/real.sig
Index: real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- real.sig 20 Jul 2002 23:14:01 -0000 1.3
+++ real.sig 2 Nov 2002 03:37:35 -0000 1.4
@@ -40,6 +40,7 @@
val fmt: StringCvt.realfmt -> real -> string
val fromInt: int -> real
val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real
+ val fromLargeInt: LargeInt.int -> real
val fromManExp: {man: real, exp: int} -> real
val fromString: string -> real option
val isFinite: real -> bool
@@ -66,13 +67,12 @@
val split: real -> {whole: real, frac: real}
val toInt: IEEEReal.rounding_mode -> real -> int
val toLarge: real -> LargeReal.real
+ val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int
val toManExp: real -> {man: real, exp: int}
val toString: real -> string
val unordered: real * real -> bool
val ~ : real -> real
(* val nextAfter: real * real -> real *)
-(* val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int *)
-(* val fromLargeInt: LargeInt.int -> real *)
(* val toDecimal: real -> IEEEReal.decimal_approx *)
(* val fromDecimal: IEEEReal.decimal_approx -> real *)
end
1.14 +178 -50 mlton/basis-library/real/real.sml
Index: real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sml,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- real.sml 20 Jul 2002 23:14:01 -0000 1.13
+++ real.sml 2 Nov 2002 03:37:35 -0000 1.14
@@ -89,14 +89,19 @@
| 5 => SUBNORMAL
| _ => raise Fail "Primitive.Real.class returned bogus integer"
- local
- val r: int ref = ref 0
- in
- fun toManExp x =
- let val man = frexp (x, r)
- in {man = man, exp = !r}
- end
- end
+ val toManExp =
+ let
+ val r: int ref = ref 0
+ in
+ fn x => if x == 0.0
+ then {exp = 0, man = 0.0}
+ else
+ let
+ val man = frexp (x, r)
+ in
+ {man = man * 2.0, exp = Int.- (!r, 1)}
+ end
+ end
fun fromManExp {man, exp} = ldexp (man, exp)
@@ -104,8 +109,10 @@
val int = ref 0.0
in
fun split x =
- let val frac = modf (x, int)
- in {frac = frac,
+ let
+ val frac = modf (x, int)
+ in
+ {frac = frac,
whole = ! int}
end
end
@@ -120,54 +127,56 @@
else raise Overflow
fun withRoundingMode (m, th) =
- let val m' = getRoundingMode ()
- in setRoundingMode m ;
- th () before setRoundingMode m'
+ let
+ val m' = getRoundingMode ()
+ val _ = setRoundingMode m
+ val res = th ()
+ val _ = setRoundingMode m'
+ in
+ res
end
val maxInt = fromInt Int.maxInt'
val minInt = fromInt Int.minInt'
fun toInt mode x =
- let fun doit () = withRoundingMode (mode, fn () =>
- Real.toInt (Real.round x))
- in case class x of
- NAN _ => raise Domain
- | INF => raise Overflow
- | ZERO => 0
- | NORMAL =>
- if minInt <= x
- then if x <= maxInt
- then doit ()
- else if x < maxInt + 1.0
- then (case mode of
- TO_NEGINF => Int.maxInt'
- | TO_POSINF => raise Overflow
- | TO_ZERO => Int.maxInt'
- | TO_NEAREST =>
- (* Depends on maxInt being odd. *)
- if x - maxInt >= 0.5
- then raise Overflow
- else Int.maxInt')
- else raise Overflow
- else if x > minInt - 1.0
- then (case mode of
- TO_NEGINF => raise Overflow
- | TO_POSINF => Int.minInt'
- | TO_ZERO => Int.minInt'
- | TO_NEAREST =>
- (* Depends on minInt being even. *)
- if x - minInt < ~0.5
- then raise Overflow
- else Int.minInt')
- else raise Overflow
- | SUBNORMAL => doit ()
+ let
+ fun doit () = withRoundingMode (mode, fn () =>
+ Real.toInt (Real.round x))
+ in
+ case class x of
+ NAN _ => raise Domain
+ | INF => raise Overflow
+ | ZERO => 0
+ | NORMAL =>
+ if minInt <= x
+ then if x <= maxInt
+ then doit ()
+ else if x < maxInt + 1.0
+ then (case mode of
+ TO_NEGINF => Int.maxInt'
+ | TO_POSINF => raise Overflow
+ | TO_ZERO => Int.maxInt'
+ | TO_NEAREST =>
+ (* Depends on maxInt being odd. *)
+ if x - maxInt >= 0.5
+ then raise Overflow
+ else Int.maxInt')
+ else raise Overflow
+ else if x > minInt - 1.0
+ then (case mode of
+ TO_NEGINF => raise Overflow
+ | TO_POSINF => Int.minInt'
+ | TO_ZERO => Int.minInt'
+ | TO_NEAREST =>
+ (* Depends on minInt being even. *)
+ if x - minInt < ~0.5
+ then raise Overflow
+ else Int.minInt')
+ else raise Overflow
+ | SUBNORMAL => doit ()
end
-(* val toLargeInt = toInt
- * val fromLargeInt = fromInt
- *)
-
fun toLarge x = x
fun fromLarge _ x = x
@@ -353,6 +362,125 @@
end
fun fromString s = StringCvt.scanString scan s
+
+ local
+ fun negateMode m =
+ case m of
+ TO_NEAREST => TO_NEAREST
+ | TO_NEGINF => TO_POSINF
+ | TO_POSINF => TO_NEGINF
+ | TO_ZERO => TO_ZERO
+
+ val m: int = 52 (* The number of mantissa bits in 64 bit IEEE 854. *)
+ val half = Int.quot (m, 2)
+ val two = IntInf.fromInt 2
+ val twoPowHalf = IntInf.pow (two, half)
+ in
+ fun fromLargeInt (i: IntInf.int): real =
+ let
+ fun pos (i: IntInf.int, mode): real =
+ case SOME (IntInf.log2 i) handle Overflow => NONE of
+ NONE => posInf
+ | SOME exp =>
+ if Int.< (exp, Int.- (valOf Int.precision, 1))
+ then fromInt (IntInf.toInt i)
+ else if Int.>= (exp, 1024)
+ then posInf
+ else
+ let
+ val shift = Int.- (exp, m)
+ val (man: IntInf.int, extra: IntInf.int) =
+ if Int.>= (shift, 0)
+ then
+ let
+ val (q, r) =
+ IntInf.quotRem
+ (i, IntInf.pow (two, shift))
+ val extra =
+ case mode of
+ TO_NEAREST =>
+ if IntInf.> (r, 0)
+ andalso IntInf.log2 r =
+ Int.- (shift, 1)
+ then 1
+ else 0
+ | TO_NEGINF => 0
+ | TO_POSINF =>
+ if IntInf.> (r, 0)
+ then 1
+ else 0
+ | TO_ZERO => 0
+ in
+ (q, extra)
+ end
+ else
+ (IntInf.* (i, IntInf.pow (two, Int.~ shift)),
+ 0)
+ (* 2^m <= man < 2^(m+1) *)
+ val (q, r) = IntInf.quotRem (man, twoPowHalf)
+ fun conv (man, exp) =
+ fromManExp {man = fromInt (IntInf.toInt man),
+ exp = exp}
+ in
+ conv (q, Int.+ (half, shift))
+ + conv (IntInf.+ (r, extra), shift)
+ end
+ val mode = getRoundingMode ()
+ in
+ case IntInf.compare (i, IntInf.fromInt 0) of
+ General.LESS => ~ (pos (IntInf.~ i, negateMode mode))
+ | General.EQUAL => 0.0
+ | General.GREATER => pos (i, mode)
+ end
+
+ val toLargeInt: IEEEReal.rounding_mode -> real -> IntInf.int =
+ fn mode => fn x =>
+ (IntInf.fromInt (toInt mode x)
+ handle Overflow =>
+ case class x of
+ INF => raise Overflow
+ | _ =>
+ let
+ fun pos (x, mode) =
+ let
+ val {frac, whole} = split x
+ val extra =
+ if mode = TO_NEAREST
+ andalso Real.== (frac, 0.5)
+ then
+ if Real.== (0.5, realMod (whole / 2.0))
+ then 1
+ else 0
+ else IntInf.fromInt (toInt mode frac)
+ val {man, exp} = toManExp whole
+ (* 1 <= man < 2 *)
+ val man = fromManExp {man = man, exp = half}
+ (* 2^half <= man < 2^(half+1) *)
+ val {frac = lower, whole = upper} = split man
+ val upper = IntInf.* (IntInf.fromInt (floor upper),
+ twoPowHalf)
+ (* 2^m <= upper < 2^(m+1) *)
+ val {whole = lower, ...} =
+ split (fromManExp {man = lower, exp = half})
+ (* 0 <= lower < 2^half *)
+ val lower = IntInf.fromInt (floor lower)
+ val int = IntInf.+ (upper, lower)
+ (* 2^m <= int < 2^(m+1) *)
+ val shift = Int.- (exp, m)
+ val int =
+ if Int.>= (shift, 0)
+ then IntInf.* (int, IntInf.pow (2, shift))
+ else IntInf.quot (int,
+ IntInf.pow (2, Int.~ shift))
+ in
+ IntInf.+ (int, extra)
+ end
+ in
+ if x > 0.0
+ then pos (x, mode)
+ else IntInf.~ (pos (~ x, negateMode mode))
+ end)
+ end
end
structure RealGlobal: REAL_GLOBAL = Real
1.5 +13 -1 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- changelog 1 Nov 2002 01:25:31 -0000 1.4
+++ changelog 2 Nov 2002 03:37:35 -0000 1.5
@@ -1,17 +1,29 @@
Here are the changes from version 20020923.
+* 2002-11-01
+ - Added allocation profiling. Now, can compile with either -profile alloc
+ or -profile time. Renamed MLton.Profile as MLton.ProfileTime. Added
+ MLton.ProfileAlloc. Cleaned up and changed most mlprof option names.
+
* 2002-10-31
- Eliminated MLton.debug.
- Fixed bug in the optimizer that affected IntInf.fmt. The optimizer
had been always using base 10, instead of the passed in radix.
+* 2002-10-22
+ - Fixed Real.toManExp so that the mantissa is in [1, 2), not [0.5, 1).
+ - Added Real.fromLargeInt, Real.toLargeInt.
+ - Fixed Real.split, which would return an incorrect whole part due to
+ the underlying primitive, Real_modf, being treated as functional instead
+ of side-effecting.
+
* 2002-09-30
- Fixed rpath problem with packaging. All executables in packages previously
made had included a setting for RPATH.
--------------------------------------------------------------------------------
-Here are the changes from version 20020410.
+Here are the changes from version 20020410 to 20020923.
Summary:
+ MLton now runs on FreeBSD.
1.4 +5 -3 mlton/doc/examples/profiling/.cvsignore
Index: .cvsignore
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/profiling/.cvsignore,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- .cvsignore 18 Jan 2002 21:29:20 -0000 1.3
+++ .cvsignore 2 Nov 2002 03:37:35 -0000 1.4
@@ -1,12 +1,14 @@
-mlmon.init.out
mlmon.fib.out
-mlmon.tak.out
+mlmon.init.out
mlmon.out
+mlmon.tak.out
profiling
+profiling-alloc
+profiling-alloc.ssa
profiling.0.S
profiling.c
profiling.ssa
profiling2
profiling2.0.S
profiling2.c
-profiling2.ssa
\ No newline at end of file
+profiling2.ssa
1.8 +15 -17 mlton/doc/examples/profiling/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/profiling/Makefile,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- Makefile 26 Aug 2002 00:59:41 -0000 1.7
+++ Makefile 2 Nov 2002 03:37:35 -0000 1.8
@@ -1,32 +1,30 @@
mlton = mlton
mlprof = mlprof
+mlton = $(HOME)/mlton/bin/mlton
+mlprof = $(HOME)/mlton/src/mlprof/mlprof
.PHONY: all
-all: profile profile2
+all: profile profile2 alloc
-.PHONY: profile
-profile: profiling mlmon.out
- $(mlprof) profiling mlmon.out
+.PHONY: alloc
+alloc:
+ $(mlton) -profile alloc profiling-alloc.sml
+ ./profiling-alloc
+ $(mlprof) profiling-alloc mlmon.out
-mlmon.out: profiling
+.PHONY: profile
+profile:
+ $(mlton) -profile time -keep g profiling.sml
./profiling
-
-profiling: profiling.sml
- $(mlton) -profile true -keep g profiling.sml
+ $(mlprof) profiling mlmon.out
.PHONE: profile2
-profile2: profiling2 mlmon.fib.out mlmon.tak.out
+profile2:
+ $(mlton) -profile time -keep g profiling2.sml
+ ./profiling2
$(mlprof) profiling2 mlmon.fib.out
$(mlprof) profiling2 mlmon.tak.out
$(mlprof) profiling2 mlmon.fib.out mlmon.tak.out mlmon.out
-
-mlmon.fib.out:
- ./profiling2
-mlmon.tak.out:
- ./profiling2
-
-profiling2: profiling2.sml
- $(mlton) -profile true -keep g profiling2.sml
.PHONY: clean
clean:
1.3 +19 -23 mlton/doc/examples/profiling/profiling2.sml
Index: profiling2.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/profiling/profiling2.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- profiling2.sml 5 Feb 2002 16:36:56 -0000 1.2
+++ profiling2.sml 2 Nov 2002 03:37:35 -0000 1.3
@@ -1,22 +1,18 @@
-
-local
- open MLton.Profile
- open Data
-in
- val topData = MLton.Profile.current ()
- val fibData = MLton.Profile.Data.malloc ()
- val takData = MLton.Profile.Data.malloc ()
-
- fun wrap (f, d) x =
- let
- val d' = MLton.Profile.current ()
- val _ = MLton.Profile.setCurrent d
- val res = f x
- val _ = MLton.Profile.setCurrent d'
- in
- res
- end
-end
+structure Profile = MLton.ProfileTime
+
+val topData = Profile.current ()
+val fibData = Profile.Data.malloc ()
+val takData = Profile.Data.malloc ()
+
+fun wrap (f, d) x =
+ let
+ val d' = Profile.current ()
+ val _ = Profile.setCurrent d
+ val res = f x
+ val _ = Profile.setCurrent d'
+ in
+ res
+ end
val rec fib =
fn 0 => 0
@@ -42,8 +38,8 @@
| n => (tak (18,12,6); g (n-1))
val _ = g 500
-val _ = MLton.Profile.Data.write (fibData, "mlmon.fib.out")
-val _ = MLton.Profile.Data.free fibData
-val _ = MLton.Profile.Data.write (takData, "mlmon.tak.out")
-val _ = MLton.Profile.Data.free takData
+val _ = Profile.Data.write (fibData, "mlmon.fib.out")
+val _ = Profile.Data.free fibData
+val _ = Profile.Data.write (takData, "mlmon.tak.out")
+val _ = Profile.Data.free takData
(* topData written to mlmon.out at program exit. *)
1.2 +7 -0 mlton/doc/examples/profiling/profiling-alloc.sml
1.10 +1 -4 mlton/doc/user-guide/basis.tex
Index: basis.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/basis.tex,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- basis.tex 26 Aug 2002 00:59:41 -0000 1.9
+++ basis.tex 2 Nov 2002 03:37:35 -0000 1.10
@@ -93,10 +93,7 @@
\fullmodule{Position}{INTEGER}
\fullmodule{Posix}{POSIX}
\module{Real}{REAL}
- {Missing: {\tt toLargeInt},
- {\tt fromLargeInt},
- {\tt nextAfter},}
-\extra{{\tt toDecimal}, {\tt fromDecimal}.}
+ {Missing: {\tt nextAfter}, {\tt toDecimal}, {\tt fromDecimal}.}
\extra{Do not match spec: {\tt scan}, {\tt fmt}, {\tt toString}, {\tt
fromString}.}
\fullmodule{Real64Array}{MONO\_ARRAY}
1.28 +10 -8 mlton/doc/user-guide/extensions.tex
Index: extensions.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/extensions.tex,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- extensions.tex 31 Oct 2002 19:30:12 -0000 1.27
+++ extensions.tex 2 Nov 2002 03:37:35 -0000 1.28
@@ -39,7 +39,8 @@
structure Itimer: MLTON_ITIMER
structure ProcEnv: MLTON_PROC_ENV
structure Process: MLTON_PROCESS
- structure Profile: MLTON_PROFILE
+ structure ProfileAlloc: MLTON_PROFILE
+ structure ProfileTime: MLTON_PROFILE
structure Random: MLTON_RANDOM
structure Rlimit: MLTON_RLIMIT
structure Rusage: MLTON_RUSAGE
@@ -373,12 +374,14 @@
Like {\tt Posix.Process.execp}.
\end{description}
-\subsubsec{{\tt MLton.Profile}}{profile}
+\subsubsec{{\tt MLton.ProfileAlloc}, {\tt MLton.ProfileTime}}{profile-structures}
This structure provides profiling control from within the program.
-For more on profiling as well as an example, see \secref{profiling}
-and {\tt examples/profiling}. In order to most efficiently execute
-non-profiled programs, all of the operations in {\tt MLton.Profile}
-are no-ops when compiling {\tt -profile false}.
+For more on profiling, see \secref{profiling} and {\tt
+examples/profiling}. In order to most efficiently execute
+non-profiled programs, all of the operations in {\tt
+MLton.ProfileAlloc} are no-ops except when compiling {\tt -profile
+alloc} and all the operations in {\tt MLton.ProfileTime} are no-ops
+except when compiling {\tt -profile time}.
\begin{verbatim}
signature MLTON_PROFILE =
@@ -401,8 +404,7 @@
\begin{description}
\entry{profile}
-a compile-time constant that reflects the value of the {\tt -profile} switch.
-The default is false.
+a compile-time constant that is true when compiling {\tt -profile time}.
\entry{type Data.t} the type of a unit of profiling data.
1.22 +5 -3 mlton/doc/user-guide/man-page.tex
Index: man-page.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/man-page.tex,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- man-page.tex 23 Sep 2002 22:51:20 -0000 1.21
+++ man-page.tex 2 Nov 2002 03:37:35 -0000 1.22
@@ -107,9 +107,11 @@
The default name is the input file name with its
suffix removed and an appropriate suffix added.
-\option{-profile \{false|true\}}
-Produce an executable that will gather profiling information. {\tt -profile
-true} implies {\tt -keep ssa}. See \secref{profiling} for details.
+\option{-profile \{no|space|time\}}
+Produce an executable that will gather space or time profiling information.
+{\tt -profile space} and {\tt -profile time} imply {\tt -keep ssa}.
+When such an executable is run, it will produce an {\tt mlmon.out} file.
+See \secref{profiling} for details.
\option{-safe \{true|false\}}
This switch determines the value of the SML variable {\tt MLton.safe}, which
1.15 +133 -53 mlton/doc/user-guide/profiling.tex
Index: profiling.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/profiling.tex,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- profiling.tex 26 Aug 2002 00:59:41 -0000 1.14
+++ profiling.tex 2 Nov 2002 03:37:35 -0000 1.15
@@ -1,41 +1,66 @@
\sec{Profiling}{profiling}
-{\mlton} has a profiling facility, {\tt mlprof}, that is similar in
-usage to {\tt gprof}. Here is an example run from within the {\tt
- examples/profiling} directory showing how to generate profiling
-information.
+{\mlton} has facility, {\tt mlprof}, for doing both allocation and
+time profiling. Allocation profiling allows you to determine which
+functions and basic blocks are allocating the most in your program.
+Time profiling allows you to determine which functions and basic
+blocks time are spending the most time.
+
+To use {\tt mlprof}, you first compile the program with either {\tt
+-profile alloc} or {\tt -profile time}. Then, you run the program,
+which produces an {\tt mlmon.out} file. Finally, you run {\tt mlprof}
+on the executable and the {\tt mlmon.out} file to see the percentage
+of the total (allocation or time) spent in various functions.
+You can not do both allocation profiling and time profiling
+simultaneously on a program.
+
+Here is an example of allocation profiling, run from within the {\tt
+examples/profiling} directory.
+
+\begin{verbatim}
+% mlton -profile alloc profiling-alloc.sml
+% ./profiling-alloc
+% mlprof profiling-alloc mlmon.out
+124,440 bytes allocated
+rev_0 96.43%
+main_0 1.95%
+<runtime> 1.49%
+F_0 0.11%
+exit_0 0.02%
+\end{verbatim}
+
+Here is an example of time profiling, run from within the {\tt
+examples/profiling} directory.
\begin{verbatim}
-% mlton -profile true -keep g profiling.sml
+% mlton -profile time -keep g profiling.sml
% ./profiling
% mlprof profiling mlmon.out
0.12 seconds of CPU time
tak_0 91.67%
IntInf_smallMul (C) 8.33%
\end{verbatim}
-In summary, generating profiling information takes three steps.
-\begin{enumerate}
-
-\item Compile with {\tt -profile true}. This saves a {\tt .ssa} file
- (see below). You can also use {\tt -keep g} to save the generated
- assembly ({\tt .S}) files.
-
-\item Run the executable. This produces a file called {\tt
- mlmon.out}.
-
-\item Run {\tt mlprof} on the executable and the {\tt mlmon.out} file.
-
-\end{enumerate}
-Unfortunately, the profiling output of {\tt mlprof} {\em
-does not refer to the source program}. Instead, {\tt mlprof} reports the
-percentage of time spent in each C and SSA function. C functions are
+
+\subsection{Understand profiling output}
+
+Conceptually, both allocation profiling and time profiling work in the
+same way. While the program is running, they associate counts (either
+clock ticks or byte counts) with addresses in the executable. Then,
+when the program finishes, it writes the counts out to the {\tt
+mlmon.out} file. Then, {\tt mlprof} uses debugging information in the
+executable to correlate the counts in the {\tt mlmon.out} file with
+human readable labels.
+
+Unfortunately, the profiling output of {\tt mlprof} {\em does not
+refer to the source program}. Instead, {\tt mlprof} reports the
+percentages of counts spent in C and SSA functions. C functions are
used for the FFI and garbage collector. SSA is an intermediate
language used by MLton that has traditional first-order function
definitions and calls and is similar to static-single assignment form.
In the above example, {\tt tak\_0} is an SSA function (see {\tt
- profiling.ssa}) corresponding to the source SML {\tt tak} function.
+profiling.ssa}) corresponding to the source SML {\tt tak} function.
The C function {\tt IntInf\_smallMul} is used to implement {\tt
- IntInf.*}.
+IntInf.*}.
In translating from SML to SSA, {\mlton} attempts to preserve source
names, but due to anonymous functions, inlining, monomorphisation,
@@ -47,11 +72,18 @@
within main) or new names may appear from the SML basis library code
that is prefixed to your program.
-You can display profiling information at the SSA basic block level
-with {\tt mlprof -d 1}.
+When you compile with with {\tt -profile alloc} or {\tt -profile
+time}, {\mlton} automatically saves the {\tt .ssa} file to which the
+profiling data refers.
+
+\subsection{Getting more detail}
+
+By default, {\tt mlprof} only displays information about functions.
+If you want more detail, you can use {\tt -depth 1}, which causes {\tt
+mlprof} to display profiling information at the SSA basic block level.
\begin{verbatim}
-% mlprof -d 1 profiling mlmon.out
+% mlprof -depth 1 profiling mlmon.out
0.40 seconds of CPU time
tak_0 90.00%
loop_0 19.44%
@@ -66,23 +98,50 @@
L_15 2.78%
IntInf_smallMul (C) 10.00%
\end{verbatim}
+
Each of the indented labels refers to a basic block in {\tt
- profiling.ssa}, within the {\tt tak\_0} function.
+profiling.ssa}, within the {\tt tak\_0} function.
You can display profiling information at the assembly basic block
-level with {\tt mlprof -d 2}. Other {\tt mlprof} options are {\tt
- -s}, which will print information about static C functions, {\tt
- -t}, which will limit {\tt mlprof} to only print information about
-functions (or blocks) whose percentage of time is above a certain
-threshold, and {\tt -x}, which will annotate each percentage of time
-with its absolute time.
+level with {\tt mlprof -depth 2}. This only makes sense for time
+profiling. To use {\tt -depth 2}, you will want to compile the
+program {\tt -keep g} to save the generated assembly ({\tt .S}) files.
+
+With {\tt mlprof}, you can also use {\tt -raw true} to get raw counts
+(either seconds or bytes). For example, here is detailed allocation
+profiling with raw counts.
+\begin{verbatim}
+% mlprof -depth 1 -raw true profiling-alloc mlmon.out
+124,440 bytes allocated
+rev_0 96.43% (120,000)
+ L_101 49.50% (59,400)
+ L_103 49.50% (59,400)
+ L_108 1.00% (1,200)
+main_0 1.95% (2,428)
+ L_127 49.42% (1,200)
+ L_124 49.42% (1,200)
+ L_111 1.15% (28)
+<runtime> 1.49% (1,852)
+F_0 0.11% (136)
+ L_137 100.00% (136)
+exit_0 0.02% (24)
+ L_91 100.00% (24)
+\end{verbatim}
+
+Other {\tt mlprof} options are {\tt -static}, which will print
+information about static C functions, {\tt -thresh}, which will limit
+{\tt mlprof} to only print information about functions (or blocks)
+whose percentage of time is above a certain threshold, and {\tt -busy},
+which for each label will show the percentages at all levels of
+detail.
\subsection{Creating colored control-flow graphs}
You may find it useful to use the {\tt -keep dot} switch when
-compiling {\tt -profile true}, since this saves several dot files that
-can help you understand the structure of the program. You can create
-nice postscript graphs from the dot files using the
+compiling {\tt -profile alloc} or {\tt -profile time}, since this
+saves several dot files that can help you understand the structure of
+the program. You can create nice postscript graphs from the dot files
+using the
\htmladdnormallink{{\tt graphviz}}
{http://www.research.att.com/sw/tools/graphviz/}
software package.
@@ -96,19 +155,25 @@
from the callee, and dotted edges indicate a return from the callee.
To visualize the profiling data in the graphs, you can execute the
-{\tt mlprof} with the {\tt -color} option in the presence of the {\tt
-.call-graph.dot} file. This will color the nodes of the call graph
-red, orange, yellow, or black according to the percentage of time
-spent in the corresponding SSA functions (where red indicates the
-hottest code). Likewise, executing {\tt mlprof} with the {\tt -color
--d 1} options in the presence of the {\tt .cfg.dot} files will color
-the nodes of the control-flow graphs. Note that the effect of the
-{\tt -color} option is dependent upon the {\tt -t n} option; functions
+{\tt mlprof} with {\tt -color true} in the directory containing the
+{\tt .call-graph.dot} file. This will color the nodes of the call
+graph red, orange, yellow, or black according to the percentage of
+time spent in the corresponding SSA functions (where red indicates the
+hottest code). Likewise, executing {\tt mlprof} with {\tt -color true
+-depth 1} in the presence of the {\tt .cfg.dot} files will color the
+nodes of the control-flow graphs. Note that the effect of the {\tt
+-color} option is dependent upon the {\tt -thresh} option; functions
and blocks below the threshold are always colored black.
-\subsection{Using {\tt mlprof} and {\tt MLton.Profile}}
-To profile individual portions of your program, use the {\tt
-MLton.Profile} structure (see \secref{profile}).
+\subsection{Using {\tt MLton.ProfileAlloc} and {\tt MLton.ProfileTime}}
+
+To profile individual portions of your program, you can use the {\tt
+MLton.ProfileAlloc} and {\tt MLton.ProfileTime} structures (see
+\secref{profile-structures}). These allow you to create many units of
+profiling data (essentially, mappings from addresses to counts) during
+a run of a program, to switch between them while the program is
+running, and to output multiple {\tt mlmon.out} files.
+
Here is an example run from within the {\tt examples/profiling}
directory showing how to profile the executions of the {\tt fib} and
{\tt tak} functions separately.
@@ -134,15 +199,30 @@
\subsection{How profiling works}
-The profiler works by catching the {\tt SIGPROF} signal 100 times per
-second and recording where in the executable the program counter is.
-Thus, if you compile {\tt -profile true}, use of the following in your
-program will cause a run-time error, since they would interfere with
-profiling.
+Allocation profiling works in cooperation with the compiler, which
+inserts code in each basic block that allocates to call a C function,
+passing the location and the amount allocated. The C function
+increments the counter in the profiling array.
+
+Time profiling works by catching the {\tt SIGPROF} signal 100 times
+per second and recording where in the executable the program counter
+is. Thus, if you compile {\tt -profile time}, use of the following in
+your program will cause a run-time error, since they would interfere
+with profiling.
\begin{tabular}{l}
\tt MLton.Itimer.set (MLton.Itimer.Prof, ...)\}\\
\tt MLton.Signal.setHandler (MLton.Signal.prof, ...)
\end{tabular}\\
It is best to have a long running program (at least tens of seconds)
-in order to get reasonable data.
+in order to get reasonable time data.
+
+For both forms of profiling, SML code in the basis library is
+responsible for writing out the profiling data. So, if you call {\tt
+Posix.Process.exit}, you will bypass this and get no {\tt mlmon.out}
+file. Also, there may be a few missed clock ticks or bytes allocated
+at the very end of the program.
+
+{\tt mlprof} has checks to make sure that the {\tt mlmon.out} file
+corresponds to the executable and to make sure that either all the
+files contain allocation data or all the files contain time data.
1.38 +2 -1 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- ccodegen.h 26 Aug 2002 00:21:43 -0000 1.37
+++ ccodegen.h 2 Nov 2002 03:37:36 -0000 1.38
@@ -118,10 +118,11 @@
/* main */
/* ------------------------------------------------- */
-#define Main(cs, mmc, mfs, mfi, mot, mg, mc, ml) \
+#define Main(cs, mmc, mfs, mfi, mot, mg, mc, ml) \
int main (int argc, char **argv) { \
struct cont cont; \
int l_nextFun; \
+ gcState.profileAllocIsOn = FALSE; \
gcState.cardSizeLog2 = cs; \
gcState.frameLayouts = frameLayouts; \
gcState.globals = globalpointer; \
1.18 +4 -1 mlton/include/x86codegen.h
Index: x86codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86codegen.h,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- x86codegen.h 26 Aug 2002 00:21:43 -0000 1.17
+++ x86codegen.h 2 Nov 2002 03:37:36 -0000 1.18
@@ -64,10 +64,13 @@
#define Float(c, f) globaldouble[c] = f;
#define EndFloats }
-#define Main(cs, mmc, mfs, mfi, mot, mg, ml, reserveEsp) \
+#define Main(cs, mmc, mfs, mfi, mot, mg, ml, reserveEsp, a1, a2, a3) \
extern pointer ml; \
int main (int argc, char **argv) { \
pointer jump; \
+ gcState.profileAllocIsOn = a1; \
+ gcState.profileAllocLabels = a2; \
+ gcState.profileAllocNumLabels = a3; \
gcState.cardSizeLog2 = cs; \
gcState.frameLayouts = frameLayouts; \
gcState.globals = globalpointer; \
1.13 +0 -3 mlton/lib/mlton/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/sources.cm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- sources.cm 30 Mar 2002 02:41:08 -0000 1.12
+++ sources.cm 2 Nov 2002 03:37:36 -0000 1.13
@@ -177,9 +177,6 @@
is
-(* These must be first, since the SML/NJ code expects to be in the Standard
- * Basis.
- *)
../mlyacc/sources.cm
../smlnj/sources.cm
1.3 +1 -1 mlton/lib/mlton/basic/euclidean-ring.fun
Index: euclidean-ring.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/euclidean-ring.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- euclidean-ring.fun 10 Apr 2002 07:50:31 -0000 1.2
+++ euclidean-ring.fun 2 Nov 2002 03:37:36 -0000 1.3
@@ -163,7 +163,7 @@
("factor", layout, List.layout (Layout.tuple2(layout, Int.layout)),
fn n => (not(isZero n), fn factors =>
equals(n, List.fold(factors, one, fn ((p, k), prod) =>
- prod * (p ^ k)))))
+ prod * pow (p, k)))))
factor
fun existsPrimeOfSmallerMetric(m: IntInf.int, f: t -> bool): bool =
1.7 +6 -4 mlton/lib/mlton/basic/hash-set.sig
Index: hash-set.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/hash-set.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- hash-set.sig 29 Jun 2002 22:08:48 -0000 1.6
+++ hash-set.sig 2 Nov 2002 03:37:36 -0000 1.7
@@ -14,12 +14,14 @@
val fold: 'a t * 'b * ('a * 'b -> 'b) -> 'b
val forall: 'a t * ('a -> bool) -> bool
val foreach: 'a t * ('a -> unit) -> unit
+ val fromList: 'a list * {hash: 'a -> word, equals: 'a * 'a -> bool} -> 'a t
(* insertIfNew (s, h, p, f, g) looks in the set s for an entry with hash h
- * satisfying predicate p. If the entry is there, it is returned after being
- * applied to g. Otherwise, the function f is called to create a new entry,
- * which is inserted and returned.
+ * satisfying predicate p. If the entry is there, it is returned after
+ * being applied to g. Otherwise, the function f is called to create a
+ * new entry, which is inserted and returned.
*)
- val insertIfNew: 'a t * word * ('a -> bool) * (unit -> 'a) * ('a -> unit) -> 'a
+ val insertIfNew:
+ 'a t * word * ('a -> bool) * (unit -> 'a) * ('a -> unit) -> 'a
val layout: ('a -> Layout.t) -> 'a t -> Layout.t
(* lookupOrInsert (s, h, p, f) looks in the set s for an entry with hash h
* satisfying predicate p. If the entry is there, it is returned.
1.7 +14 -1 mlton/lib/mlton/basic/hash-set.sml
Index: hash-set.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/hash-set.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- hash-set.sml 29 Jun 2002 22:08:48 -0000 1.6
+++ hash-set.sml 2 Nov 2002 03:37:36 -0000 1.7
@@ -23,7 +23,7 @@
mask = ref mask}
end
-val initialSize: int = Int.^ (2, 6)
+val initialSize: int = Int.pow (2, 6)
fun new {hash} = newWithBuckets {hash = hash,
numBuckets = Word.fromInt initialSize}
@@ -196,5 +196,18 @@
fun toList t = fold (t, [], fn (a, l) => a :: l)
fun layout lay t = List.layout lay (toList t)
+
+fun fromList (l, {hash, equals}) =
+ let
+ val s = new {hash = hash}
+ val _ =
+ List.foreach (l, fn a =>
+ (lookupOrInsert (s, hash a,
+ fn b => equals (a, b),
+ fn _ => a)
+ ; ()))
+ in
+ s
+ end
end
1.3 +1 -1 mlton/lib/mlton/basic/integer.fun
Index: integer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/integer.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- integer.fun 10 Apr 2002 07:50:31 -0000 1.2
+++ integer.fun 2 Nov 2002 03:37:36 -0000 1.3
@@ -69,7 +69,7 @@
end
fun output (n, out) = Out.output (out, toString n)
-
+
fun powerMod {base, exp, modulus} =
Power.power {layout = layout,
one = one,
1.3 +3 -3 mlton/lib/mlton/basic/merge-sort.sml
Index: merge-sort.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/merge-sort.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- merge-sort.sml 10 Apr 2002 07:50:31 -0000 1.2
+++ merge-sort.sml 2 Nov 2002 03:37:36 -0000 1.3
@@ -36,16 +36,16 @@
fun sort l =
let
val numBuckets = 25
- val _ = assert (fn () => length l < Int.^ (2, numBuckets) - 1)
+ val _ = assert (fn () => length l < Int.pow (2, numBuckets) - 1)
val a: 'a list array = Array.new (numBuckets, [])
fun invariant () =
assert (fn () => Array.foralli (a, fn (i, l) =>
case l of
[] => true
- | _ => (length l = Int.^ (2, i)
+ | _ => (length l = Int.pow (2, i)
andalso isSorted l)))
fun mergeIn (i: int, l: 'a list): unit =
- (assert (fn () => length l = Int.^ (2, i))
+ (assert (fn () => length l = Int.pow (2, i))
; (case Array.sub (a, i) of
[] => Array.update (a, i, l)
| l' => (Array.update (a, i, [])
1.5 +1 -0 mlton/lib/mlton/basic/outstream.sig
Index: outstream.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/outstream.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- outstream.sig 10 Apr 2002 07:50:31 -0000 1.4
+++ outstream.sig 2 Nov 2002 03:37:36 -0000 1.5
@@ -20,6 +20,7 @@
val output: t * string -> unit
val output1: t * char -> unit
val outputc: t -> string -> unit
+ val outputl: t * string -> unit
val outputSubstr: t * Substring.t -> unit
val print: string -> unit
val set: t * t -> unit
1.5 +3 -1 mlton/lib/mlton/basic/outstream0.sml
Index: outstream0.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/outstream0.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- outstream0.sml 10 Apr 2002 07:50:31 -0000 1.4
+++ outstream0.sml 2 Nov 2002 03:37:36 -0000 1.5
@@ -11,7 +11,7 @@
open TextIO
(*val output = fn (out, s) => (output (out, s); flushOut out) *)
-
+
type t = outstream
val standard = stdOut
@@ -21,6 +21,8 @@
val flush = flushOut
fun newline s = output (s, "\n")
+
+fun outputl (s, x) = (output (s, x); newline s)
fun print s = output (standard, s)
1.4 +23 -11 mlton/lib/mlton/basic/popt.sig
Index: popt.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/popt.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- popt.sig 14 Sep 2002 01:27:56 -0000 1.3
+++ popt.sig 2 Nov 2002 03:37:36 -0000 1.4
@@ -13,7 +13,7 @@
(* This type specifies what kind of arguments a switch expects
* and provides the function to be applied to the argument.
*)
- datatype opt =
+ datatype t =
(* no args *)
None of unit -> unit
(* one arg: an integer, after a space *)
@@ -22,7 +22,7 @@
| Bool of bool -> unit
(* one arg: a single digit, no space. *)
| Digit of int -> unit
- (* one arg: an integer followed by optional k or m. *)
+ (* one arg: an integer followed by tional k or m. *)
| Mem of int -> unit
(* Any string immediately follows the switch. *)
| String of string -> unit
@@ -30,18 +30,18 @@
| SpaceString of string -> unit
| SpaceString2 of string * string -> unit
- val boolRef: bool ref -> opt
- val falseRef: bool ref -> opt
- val intRef: int ref -> opt
- val stringRef: string ref -> opt
- val trueRef: bool ref -> opt
+ val boolRef: bool ref -> t
+ val falseRef: bool ref -> t
+ val intRef: int ref -> t
+ val stringRef: string ref -> t
+ val trueRef: bool ref -> t
- val trace: string * opt
+ val trace: string * t
- (* Parse the switches, applying the first matching opt to each switch,
+ (* Parse the switches, applying the first matching t to each switch,
* and return any remaining args.
* Returns NONE if it encounters an error.
- * For example, if opts is:
+ * For example, if ts is:
* [("foo", None f)]
* and the switches are:
* ["-foo", "bar"]
@@ -50,7 +50,19 @@
val parse:
{
switches: string list,
- opts: (string * opt) list
+ opts: (string * t) list
}
-> string list Result.t
+
+ datatype optionStyle = Normal | Expert
+ val makeUsage: {mainUsage: string,
+ makeOptions: ({usage: string -> unit}
+ -> {style: optionStyle,
+ name: string,
+ arg: string,
+ desc: string,
+ opt: t} list),
+ showExpert: unit -> bool
+ } -> {parse: string list -> string list Result.t,
+ usage: string -> unit}
end
1.4 +56 -6 mlton/lib/mlton/basic/popt.sml
Index: popt.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/popt.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- popt.sml 14 Sep 2002 01:27:56 -0000 1.3
+++ popt.sml 2 Nov 2002 03:37:36 -0000 1.4
@@ -10,7 +10,7 @@
structure Popt: POPT =
struct
-datatype opt =
+datatype t =
None of unit -> unit
| Int of int -> unit
| Bool of bool -> unit
@@ -21,17 +21,17 @@
| SpaceString2 of string * string -> unit
local
- fun make b (r: bool ref): opt = None (fn () => r := b)
+ fun make b (r: bool ref): t = None (fn () => r := b)
in
val trueRef = make true
val falseRef = make false
end
-fun boolRef (r: bool ref): opt = Bool (fn b => r := b)
+fun boolRef (r: bool ref): t = Bool (fn b => r := b)
-fun intRef (r: int ref): opt = Int (fn n => r := n)
+fun intRef (r: int ref): t = Int (fn n => r := n)
-fun stringRef (r: string ref): opt = String (fn s => r := s)
+fun stringRef (r: string ref): t = String (fn s => r := s)
val trace = ("trace", SpaceString (fn s =>
let open Trace.Immediate
@@ -64,7 +64,7 @@
(* Parse the command line opts and return any remaining args. *)
fun parse {switches: string list,
- opts: (string * opt) list}: string list Result.t =
+ opts: (string * t) list}: string list Result.t =
let
exception Error of string
val rec loop =
@@ -134,4 +134,54 @@
in
Result.Yes (loop switches) handle Error s => Result.No s
end
+
+datatype optionStyle = Normal | Expert
+
+fun makeUsage {mainUsage, makeOptions, showExpert} =
+ let
+ val usageRef: (string -> unit) option ref = ref NONE
+ fun usage (s: string): unit = valOf (!usageRef) s
+ fun options () = makeOptions {usage = usage}
+ val _ =
+ usageRef :=
+ SOME
+ (fn s =>
+ let
+ val out = Out.error
+ fun message s = Out.outputl (out, s)
+ val opts =
+ List.fold
+ (rev (options ()), [],
+ fn ({arg, desc, name, opt, style}, rest) =>
+ if style = Normal orelse showExpert ()
+ then [concat [" -", name, arg, " "], desc] :: rest
+ else rest)
+ val table =
+ let
+ open Justify
+ in
+ table {justs = [Left, Left],
+ rows = opts}
+ end
+ in
+ message s
+ ; message mainUsage
+ ; List.foreach (table, fn ss =>
+ message (String.removeTrailing
+ (concat ss, Char.isSpace)))
+ ; let open OS.Process
+ in if MLton.isMLton
+ then exit failure
+ else raise Fail "failure"
+ end
+ end)
+ val parse =
+ fn switches =>
+ parse {opts = List.map (options (), fn {name, opt, ...} => (name, opt)),
+ switches = switches}
+ in
+ {parse = parse,
+ usage = usage}
+ end
+
end
1.3 +32 -7 mlton/lib/mlton/basic/real.sig
Index: real.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/real.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- real.sig 10 Apr 2002 07:50:31 -0000 1.2
+++ real.sig 2 Nov 2002 03:37:36 -0000 1.3
@@ -4,12 +4,10 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+type int = Int.t
+
signature REAL =
sig
- type int = Int.t
-
- include ORDERED_FIELD
-
structure Format:
sig
type t
@@ -19,31 +17,58 @@
val gen: int option -> t
end
+ type t
+ exception Input
+ val * : t * t -> t
+ val + : t * t -> t
+ val / : t * t -> t
+ val < : t * t -> bool
+ val <= : t * t -> bool
+ val > : t * t -> bool
+ val >= : t * t -> bool
val acos: t -> t
+ val add1: t -> t
val asin: t -> t
- val atan: t -> t
val atan2: t * t -> t
+ val atan: t -> t
val ceiling: t -> int
val choose: t * t -> t
+ val compare: t * t -> Relation.t
val cos: real -> real
+ val dec: t ref -> unit
+ val equals: t * t -> bool
val exp: t -> t
val floor: t -> int
val format: t * Format.t -> string
+ val fromInt: Pervasive.Int.int -> t (* fromInt n = 1 + ... + 1, n times. *)
+ val fromIntInf: Pervasive.IntInf.int -> t
val fromString: string -> t option
- exception Input
+ val inc: t ref -> unit
val input: In0.t -> t
+ val inverse: t -> t
val isFinite: t -> bool
+ val layout: t -> Layout.t
val ln: t -> t
- val log: t * t -> t
val log2: t -> t
+ val log: t * t -> t
val maxFinite: t
+ val negOne: t
+ val one: t
val pi: t
+ val pow: t * t -> t
+ val prod: t list -> t
val realMod: t -> t
val realPower: t * t -> t
val round: t -> int
val sin: real -> real
val sqrt: t -> t
+ val sub1: t -> t
val tan: t -> t
+ val three: t
+ val toIntInf: t -> IntInf.t
val toString: t -> string
val trunc: t -> int
+ val two: t
+ val zero: t
+ val ~ : t -> t
end
1.3 +10 -4 mlton/lib/mlton/basic/real.sml
Index: real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/real.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- real.sml 10 Apr 2002 07:50:31 -0000 1.2
+++ real.sml 2 Nov 2002 03:37:36 -0000 1.3
@@ -32,11 +32,17 @@
exception Input
fun input i =
- case fromString(In.inputToSpace i) of
+ case fromString (In.inputToSpace i) of
SOME x => x
| NONE => raise Input
-
-val fromInt = Pervasive.Real.fromInt
+
+local
+ open Pervasive.Real
+in
+ val fromInt = fromInt
+ val fromIntInf = fromLargeInt
+ val toIntInf = toLargeInt IEEEReal.TO_NEAREST
+end
structure Format =
struct
@@ -63,5 +69,5 @@
fun realPower(m, n) = exp(n * ln m)
val ceiling = ceil
-
+
end
1.3 +12 -12 mlton/lib/mlton/basic/ring-with-identity.fun
Index: ring-with-identity.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/ring-with-identity.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ring-with-identity.fun 10 Apr 2002 07:50:31 -0000 1.2
+++ ring-with-identity.fun 2 Nov 2002 03:37:36 -0000 1.3
@@ -13,10 +13,10 @@
structure IntInf = Pervasive.IntInf
val base = {one = one, layout = layout, times = op *}
-val op ^ = Power.power base
-val ^^ = Power.powerInf base
-val power = Power.simultaneous base
-val powerInf = Power.simultaneousInf base
+val pow = Power.power base
+val powInf = Power.powerInf base
+val pows = Power.simultaneous base
+val powsInf = Power.simultaneousInf base
local
fun 'a
@@ -65,22 +65,22 @@
val three = add1 two
-val power =
+val pows =
Trace.traceAssert
- ("power",
+ ("pows",
List.layout (Layout.tuple2 (layout, Layout.str o Pervasive.Int.toString)),
layout,
fn l => (true, fn r => equals (r, List.fold (l, one, fn ((b, e), ac) =>
- ac * (b ^ e)))))
- power
+ ac * pow (b, e)))))
+ pows
-val powerInf =
+val powsInf =
Trace.traceAssert
- ("powerInf",
+ ("powsInf",
List.layout (Layout.tuple2 (layout, Layout.str o Pervasive.IntInf.toString)),
layout,
fn l => (true, fn r => equals (r, List.fold (l, one, fn ((b, e), ac) =>
- ac * (^^ (b, e))))))
- powerInf
+ ac * powInf (b, e)))))
+ powsInf
end
1.3 +4 -5 mlton/lib/mlton/basic/ring-with-identity.sig
Index: ring-with-identity.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/ring-with-identity.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- ring-with-identity.sig 10 Apr 2002 07:50:31 -0000 1.2
+++ ring-with-identity.sig 2 Nov 2002 03:37:36 -0000 1.3
@@ -15,9 +15,6 @@
sig
include RING_WITH_IDENTITY_STRUCTS
- val ^ : t * Pervasive.Int.int -> t
- val ^^ : t * Pervasive.IntInf.int -> t
-
val add1: t -> t
val dec: t ref -> unit
(* fromInt n = 1 + ... + 1, n times. *)
@@ -25,8 +22,10 @@
val fromIntInf: Pervasive.IntInf.int -> t
val inc: t ref -> unit
val negOne: t
- val power: (t * Pervasive.Int.int) list -> t (* simultaneous exponentiation *)
- val powerInf: (t * Pervasive.IntInf.int) list -> t
+ val pow: t * Pervasive.Int.int -> t
+ val powInf : t * Pervasive.IntInf.int -> t
+ val pows: (t * Pervasive.Int.int) list -> t (* simultaneous exponentiation *)
+ val powsInf: (t * Pervasive.IntInf.int) list -> t
val prod: t list -> t
val sub1: t -> t
val three: t
1.14 +0 -1 mlton/lib/mlton/basic/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/sources.cm,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- sources.cm 30 Mar 2002 02:41:08 -0000 1.13
+++ sources.cm 2 Nov 2002 03:37:36 -0000 1.14
@@ -140,7 +140,6 @@
is
-../../mlton-stubs-in-smlnj/sources.cm
../../mlton-stubs/sources.cm
../pervasive/sources.cm
1.3 +1 -1 mlton/lib/mlton/basic/unique-set.fun
Index: unique-set.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/unique-set.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- unique-set.fun 10 Apr 2002 07:50:31 -0000 1.2
+++ unique-set.fun 2 Nov 2002 03:37:36 -0000 1.3
@@ -122,7 +122,7 @@
open Tree.Set
-val tableSize = Int.^(2, bits)
+val tableSize = Int.pow (2, bits)
val maxIndex = tableSize - 1
1.6 +2 -0 mlton/lib/mlton/basic/word.sig
Index: word.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/word.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- word.sig 10 Apr 2002 07:50:31 -0000 1.5
+++ word.sig 2 Nov 2002 03:37:36 -0000 1.6
@@ -40,6 +40,8 @@
val toChar: t -> char
val toInt: t -> int
val toIntX: t -> int
+ val toIntInf: t -> Pervasive.IntInf.int
+ val toIntInfX: t -> Pervasive.IntInf.int
val toWord: t -> Pervasive.Word.word
val toWordX: t -> Pervasive.Word.word
val toString: t -> string
1.7 +3 -0 mlton/lib/mlton/basic/word.sml
Index: word.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/word.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- word.sml 29 Jun 2002 22:08:13 -0000 1.6
+++ word.sml 2 Nov 2002 03:37:36 -0000 1.7
@@ -44,6 +44,9 @@
val toWord = fn x => x
val toWordX = fn x => x
+ val toIntInf = toLargeInt
+ val toIntInfX = toLargeIntX
+
val fromWord8 = Word8.toWord
val toWord8 = Word8.fromWord
1.5 +2 -0 mlton/lib/mlton/basic/word8.sml
Index: word8.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/word8.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- word8.sml 10 Apr 2002 07:50:31 -0000 1.4
+++ word8.sml 2 Nov 2002 03:37:36 -0000 1.5
@@ -15,6 +15,8 @@
val fromWord = fromLargeWord
val toWord = toLargeWord
val toWordX = toLargeWordX
+ val toIntInf = toLargeInt
+ val toIntInfX = toLargeIntX
val layout = Layout.str o toString
1.4 +0 -1 mlton/lib/mlton/pervasive/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/pervasive/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm 23 Mar 2002 00:42:37 -0000 1.3
+++ sources.cm 2 Nov 2002 03:37:36 -0000 1.4
@@ -4,7 +4,6 @@
is
-../../mlton-stubs-in-smlnj/sources.cm
../../mlton-stubs/sources.cm
pervasive.sml
1.3 +53 -0 mlton/lib/mlton-stubs/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/sources.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.cm 6 Aug 2002 03:19:19 -0000 1.2
+++ sources.cm 2 Nov 2002 03:37:37 -0000 1.3
@@ -2,7 +2,59 @@
signature MLTON_THREAD
+signature INT_INF
+#if (SMLNJ_VERSION == 110) && (SMLNJ_MINOR_VERSION >= 20)
+signature POSIX_SIGNAL
+#endif
+structure Array
+structure Array2
+structure BinIO
+structure Bool
+structure Byte
+structure Char
+structure CharArray
+structure CharVector
+structure CommandLine
+structure Date
+structure General
+structure IEEEReal
+structure Int
+structure Int32
+structure IntInf
+structure IO
+structure LargeInt
+structure LargeReal
+structure LargeWord
+structure List
+structure ListPair
+structure Math
structure MLton
+structure OS
+structure Option
+structure Pack32Big
+structure Pack32Little
+structure Position
+structure Posix
+structure Real
+structure Real64Array
+structure RealArray
+structure RealVector
+structure SML90
+structure SMLofNJ
+structure String
+structure StringCvt
+structure Substring
+structure SysWord
+structure TextIO
+structure Time
+structure Unix
+structure Unsafe
+structure Vector
+structure Word
+structure Word32
+structure Word8
+structure Word8Array
+structure Word8Vector
is
@@ -24,6 +76,7 @@
ptrace.sig
random.sig
random.sml
+real.sml
rlimit.sig
rusage.sig
signal.sig
1.2 +9 -0 mlton/lib/mlton-stubs/real.sml
1.3 +1 -0 mlton/lib/mlton-stubs-in-smlnj/int-inf-sig.cm
Index: int-inf-sig.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/int-inf-sig.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- int-inf-sig.cm 23 Mar 2002 00:42:38 -0000 1.2
+++ int-inf-sig.cm 2 Nov 2002 03:37:37 -0000 1.3
@@ -8,6 +8,7 @@
$/basis.cm
#endif
import.cm
+
pre-int-inf-sig.sml
int-inf.sig
1.3 +17 -2 mlton/lib/mlton-stubs-in-smlnj/int-inf.sig
Index: int-inf.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/int-inf.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- int-inf.sig 23 Mar 2002 00:42:38 -0000 1.2
+++ int-inf.sig 2 Nov 2002 03:37:37 -0000 1.3
@@ -17,6 +17,7 @@
val fromInt: Int.int -> int
val fromLarge: LargeInt.int -> int
val fromString: string -> int option
+ val log2: int -> Int.int
val max: int * int -> int
val maxInt: int option
val min: int * int -> int
@@ -37,12 +38,26 @@
val toLarge: int -> LargeInt.int
val toString: int -> string
val ~ : int -> int
-(* val log2: int -> Int.int
- * val orb: int * int -> int
+(* val orb: int * int -> int
* val xorb: int * int -> int
* val andb: int * int -> int
* val notb: int -> int
* val << : int * Word.word -> int
* val ~>> : int * Word.word -> int
*)
+ end
+
+signature INT_INF_EXTRA =
+ sig
+ include INT_INF
+
+ val areSmall: int * int -> bool
+ val bigIntConstant: Int.int -> int
+ val gcd: int * int -> int
+ val isSmall: int -> bool
+ datatype rep =
+ Small of Word.word
+ | Big of Word.word Vector.vector
+ val rep: int -> rep
+ val size: int -> Int.int
end
1.2 +1 -1 mlton/lib/mlton-stubs-in-smlnj/pre-int-inf-sig.sml
Index: pre-int-inf-sig.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/pre-int-inf-sig.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- pre-int-inf-sig.sml 3 Feb 2002 20:43:34 -0000 1.1
+++ pre-int-inf-sig.sml 2 Nov 2002 03:37:37 -0000 1.2
@@ -8,5 +8,5 @@
end
structure Word =
struct
- type word = Pervasive.Word32.word
+ type word = Word32.word
end
1.2 +5 -0 mlton/lib/mlton-stubs-in-smlnj/real.sml
Index: real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/real.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- real.sml 18 Jul 2001 05:51:03 -0000 1.1
+++ real.sml 2 Nov 2002 03:37:37 -0000 1.2
@@ -20,4 +20,9 @@
fun toInt m x = fromInt(Real.toInt m x)
val fromInt = Real.fromLargeInt
end
+
+ val fromLargeInt: IntInf.int -> real =
+ fn _ => raise Fail "Real.fromLargeInt"
+ val toLargeInt: IEEEReal.rounding_mode -> real -> IntInf.int =
+ fn _ => fn _ => raise Fail "Real.toLargeInt"
end
1.9 +1 -1 mlton/lib/mlton-stubs-in-smlnj/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/sources.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- sources.cm 6 Aug 2002 03:19:19 -0000 1.8
+++ sources.cm 2 Nov 2002 03:37:37 -0000 1.9
@@ -57,7 +57,7 @@
#if (SMLNJ_VERSION == 110) && (SMLNJ_MINOR_VERSION >= 20)
$/basis.cm
-#endif
+#endif
import.cm
array.sml
1.4 +4 -0 mlton/lib/mlton-stubs-in-smlnj/word.sml
Index: word.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs-in-smlnj/word.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- word.sml 20 Feb 2002 11:38:05 -0000 1.3
+++ word.sml 2 Nov 2002 03:37:37 -0000 1.4
@@ -15,6 +15,10 @@
val toInt = toLargeInt
val toIntX = toLargeIntX
val fromInt = fromLargeInt
+ val toLargeInt: word -> LargeInt.int =
+ fn _ => raise Fail "Word.toLargeInt"
+ val toLargeIntX: word -> LargeInt.int =
+ fn _ => raise Fail "Word.toLargeIntX"
(* Bug in SML/NJ -- they use lower instead of upper case. *)
val toUpper = Pervasive.String.translate (Char.toString o Char.toUpper)
1.2 +1 -1 mlton/lib/mlyacc/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlyacc/sources.cm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- sources.cm 18 Jul 2001 05:51:03 -0000 1.1
+++ sources.cm 2 Nov 2002 03:37:37 -0000 1.2
@@ -22,7 +22,7 @@
is
-../mlton-stubs-in-smlnj/sources.cm
+../mlton-stubs/sources.cm
base.sig
join.sml
1.3 +1 -1 mlton/lib/smlnj/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/smlnj/sources.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.cm 10 Aug 2001 00:11:58 -0000 1.2
+++ sources.cm 2 Nov 2002 03:37:37 -0000 1.3
@@ -18,7 +18,7 @@
is
-../mlton-stubs-in-smlnj/sources.cm
+../mlton-stubs/sources.cm
splaytree-sig.sml
splaytree.sml
1.5 +30 -17 mlton/man/mlprof.1
Index: mlprof.1
===================================================================
RCS file: /cvsroot/mlton/mlton/man/mlprof.1,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- mlprof.1 18 Oct 2002 00:26:21 -0000 1.4
+++ mlprof.1 2 Nov 2002 03:37:37 -0000 1.5
@@ -1,28 +1,38 @@
-.TH mlprof 1 "September 23, 2002"
+.TH mlprof 1 "November 1, 2002"
.SH NAME
\fBmlprof\fP \- display profile information from MLton executable
.SH SYNOPSIS
-\fBmlprof \fI[\fB-d \fI{\fB0\fP|\fB1\fP|\fB2\fP}] [\fB-s\fP] [\fB-t\fP n] a.out mlmon.out\fR
+\fBmlprof \fI[option ...] a.out mlmon.out\fR
.SH DESCRIPTION
.PP
\fBmlprof\fP extracts information from an mlmon.out file produced
-by running a program compiled by \fBMLton\fP with the \fB-p\fP option.
+by running a program compiled by \fBMLton\fP with \fB-profile alloc\fP or
+\fB-profile time\fP option.
In order to do this, it needs the executable (a.out) file produced by
\fBMLton\fP and the mlmon.out file produced by running the executable.
In addition, the results printed by \fBmlprof\fP relate most
closely to the SSA intermediate language of compilation, so having the
\fI*\fB.ssa\fR file is useful.
-The output of mlprof consists of an initial line indicating how much CPU time
-the program used. After this the various routines will be listed along with the
-percentage of this time that they used, in decreasing order.
+The output of mlprof consists of an initial line indicating the total amount of
+CPU time or bytes allocated. After this the various routines will be listed
+along with the percentage of this total that they used, in decreasing order.
-The fact that the relation between CPU time use and the original ML program is
+The fact that the relation between the counts and the original ML program is
only done as far as the output of the SSA pass is quite unfortunate, but
hopefully still useful.
.SH OPTIONS
.TP
-\fB-d \fI{\fB0\fP|\fB1\fP|\fB2\fP}\fP
+\fB-busy \fI{\fBfalse\fP|\fBtrue\fP}\fP
+Show the information for each laebl at all levels of detail. This is only
+meaningful if depth is greater than 0.
+.TP
+\fB-color \fI{\fBfalse\fP|\fBtrue\fP}\fP
+Color the dot graphs, using red for the most active blocks or functions, orange,
+for the next group, yellow for the next, and black for the least active. This
+is only useful if the program was compiled \fB-keep dot\fP.
+.TP
+ \fB-depth \fI{\fB0\fP|\fB1\fP|\fB2\fP}\fP
Control the level of detail of profiling. The default is 0.
.br
.in +.5i
@@ -30,21 +40,24 @@
.br
\fB1\fP SSA basic blocks.
.br
-\fB2\fP Assembly basic blocks.
+\fB2\fP Assembly basic blocks. This is only meaningful for time profiling.
.in -.5i
.TP
-\fB-s\fP
+\fB-raw \fI{\fBfalse\fP|\fBtrue\fP}\fP
+Show the raw counts in addition to the percentages.
+.TP
+\fB-static \fI{\fBfalse\fP|\fBtrue\fP}\fP
Provide information on static C functions.
-Without this flag, all compute time in C code which was \fInot\fP
+With \fB-static false\fP, all compute time in C code which was \fInot\fP
generated by \fBMLton\fP is charged to the nearest non-static symbol
occurring before that location.
-With this flag it is charged to the nearest symbol before the location,
-static or non-static.
-Note, because static symbol names are not necessarily unique, the name
+With \fB-static true\fP, it is charged to the nearest symbol before the
+location, static or non-static.
+Because static symbol names are not necessarily unique, the name
of the symbol will be followed by its location.
.TP
-\fB-t \fIn\fR
-Only print information about functions (or blocks) whose percentage of time is
-above \fIn\fP.
+\fB-thresh \fI{\fB0\fP|\fB1\fP|...|\fB100\fP}\fP
+Only print information about functions (or blocks) whose percentage is
+above the specified integer.
.SH "SEE ALSO"
.BR mlton (1)
1.21 +6 -5 mlton/man/mlton.1
Index: mlton.1
===================================================================
RCS file: /cvsroot/mlton/mlton/man/mlton.1,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- mlton.1 18 Oct 2002 00:26:21 -0000 1.20
+++ mlton.1 2 Nov 2002 03:37:37 -0000 1.21
@@ -1,4 +1,4 @@
-.TH mlton 1 "September 23, 2002"
+.TH mlton 1 "October 18, 2002"
.SH NAME
\fBmlton\fP \- whole-program compiler for the Standard ML (SML) programming
language
@@ -122,11 +122,12 @@
appropriate suffix added.
.TP
-\fB-profile \fI{\fBfalse\fP|\fBtrue\fP}\fR
-Produce an executable that will gather profiling information.
-When such an executable is run, it will produce a \fBmlmon.out\fP file.
+\fB-profile \fI{\fBno\fP|\fBspace\fP|\fBtime\fP}\fR
+Produce an executable that will gather space or time profiling information.
+\fB-profile space\fP and \fB-profile time\fP imply \fB-keep ssa\fP.
+When such an executable is run, it will produce an \fBmlmon.out\fP file.
The man page on \fBmlprof\fP describes how to extract information from this
-file. \fB-profile true\fP implies \fB-keep ssa\fP.
+file.
.TP
\fB-safe \fI{\fBtrue\fP|\fBfalse\fP}\fR
1.2 +9 -3 mlton/mllex/mllex-stubs.cm
Index: mllex-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex-stubs.cm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- mllex-stubs.cm 16 Apr 2002 13:17:40 -0000 1.1
+++ mllex-stubs.cm 2 Nov 2002 03:37:37 -0000 1.2
@@ -1,4 +1,5 @@
Group is
+../lib/mlton-stubs/real.sml
../lib/mlton/pervasive/pervasive.sml
../lib/mlton/basic/error.sig
../lib/mlton/basic/error.sml
@@ -15,22 +16,25 @@
../lib/mlton/basic/option.sml
../lib/mlton/basic/fold.fun
../lib/mlton-stubs/thread.sml
+../lib/mlton-stubs/random.sig
+../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
+../lib/mlton-stubs/io.sig
../lib/mlton-stubs/text-io.sig
../lib/mlton-stubs/syslog.sig
../lib/mlton-stubs/socket.sig
../lib/mlton-stubs/signal.sig
../lib/mlton-stubs/rusage.sig
../lib/mlton-stubs/rlimit.sig
-../lib/mlton-stubs/random.sig
../lib/mlton-stubs/ptrace.sig
../lib/mlton-stubs/profile.sig
../lib/mlton-stubs/process.sig
../lib/mlton-stubs/proc-env.sig
../lib/mlton-stubs/array.sig
+../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
../lib/mlton-stubs/gc.sig
@@ -94,6 +98,8 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/char.sig
../lib/mlton/basic/char.sml
../lib/mlton/basic/vector.sig
@@ -125,12 +131,12 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
../lib/mlton/basic/process.sml
+../lib/mlton/basic/justify.sig
+../lib/mlton/basic/justify.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
lexgen.sml
1.4 +4 -2 mlton/mllex/mllex.cm
Index: mllex.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mllex/mllex.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- mllex.cm 16 Apr 2002 13:17:40 -0000 1.3
+++ mllex.cm 2 Nov 2002 03:37:37 -0000 1.4
@@ -70,6 +70,8 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/char.sig
../lib/mlton/basic/char.sml
../lib/mlton/basic/vector.sig
@@ -101,12 +103,12 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
../lib/mlton/basic/process.sml
+../lib/mlton/basic/justify.sig
+../lib/mlton/basic/justify.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
lexgen.sml
1.12 +357 -211 mlton/mlprof/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- main.sml 20 Sep 2002 15:53:17 -0000 1.11
+++ main.sml 2 Nov 2002 03:37:37 -0000 1.12
@@ -13,13 +13,19 @@
val busy = ref false : bool ref
val color = ref false
+val depth: int ref = ref 0
+val raw = ref false
val static = ref false (* include static C functions *)
-val thresh = ref 0 : int ref
-val extra = ref false
+val thresh: int ref = ref 0
val die = Process.fail
val warn = fn s => Out.output (Out.error, concat ["Warning: ", s, "\n"])
+fun die s =
+ (Out.output (Out.error, s)
+ ; Out.newline Out.error
+ ; Process.fail "die")
+
structure Regexp =
struct
open Regexp
@@ -31,7 +37,6 @@
star (isChar (fn #"_" => true
| #"'" => true
| c => Char.isAlphaNum c))]
-
end
structure StringMap:
@@ -111,10 +116,12 @@
structure AFile =
struct
- datatype t = T of {addr: word,
- profileInfo: {name: string} ProfileInfo.t} list
+ datatype t = T of {etext: word,
+ start: word,
+ data: {addr: word,
+ profileInfo: {name: string} ProfileInfo.t} list}
- fun layout (T l) =
+ fun layout (T {data, ...}) =
let
open Layout
in
@@ -123,7 +130,7 @@
=> seq [Word.layout addr,
str " ",
ProfileInfo.layout (fn {name} => str name) profileInfo])
- l
+ data
end
structure Match = Regexp.Match
@@ -153,11 +160,19 @@
val addr = Save.new ()
val kind = Save.new ()
val label = Save.new ()
+ val start = Save.new ()
+ val etext = Save.new ()
val symbolC =
compileDFA
- (or [seq [save (hexDigits, addr),
+ (or [seq [save (hexDigits, start),
+ string " T _start",
+ eol],
+ seq [save (hexDigits, etext),
+ string " A etext",
+ eol],
+ seq [save (hexDigits, addr),
char #" ",
- save (char #"t", kind),
+ save (char #"T", kind),
char #" ",
profileLabelRegexp,
eol],
@@ -173,6 +188,8 @@
else (Layout.outputl (Compiled.layout symbolC, Out.standard)
; Compiled.layoutDotToFile (symbolC, "symbol.dot"))
end
+ val startRef = ref NONE
+ val etextRef = ref NONE
val l
= Process.callWithIn
("nm", ["-n", afile], fn ins =>
@@ -183,45 +200,61 @@
| SOME m =>
let
val {lookup, peek, ...} = Regexp.Match.stringFuns m
- val addr = valOf (Word.fromString (lookup addr))
- val profileInfo =
- case peek label of
- SOME label =>
- let
- val kind = lookup kind
- val level = if kind = "T" then ~1 else ~2
- in [{profileLevel = level,
- profileName = label}]
- end
- | NONE =>
- let
- val profileInfo = lookup profileInfo
- val length = String.size profileInfo
- fun loop pos =
- case (Regexp.Compiled.matchShort
- (profileInfoC,
- profileInfo, pos)) of
- NONE => []
- | SOME m =>
- let
- val {lookup, ...} =
- Match.stringFuns m
- val level =
- valOf (Int.fromString
- (lookup level))
- val name = lookup name
- in
- {profileLevel = level,
- profileName = name}
- :: loop (pos + Match.length m)
- end
- in loop 0
- end
+ fun normal () =
+ let
+ val addr = valOf (Word.fromString (lookup addr))
+ val profileInfo =
+ case peek label of
+ SOME label =>
+ let
+ val kind = lookup kind
+ val level =
+ if kind = "T" then ~1 else ~2
+ in [{profileLevel = level,
+ profileName = label}]
+ end
+ | NONE =>
+ let
+ val profileInfo = lookup profileInfo
+ val length = String.size profileInfo
+ fun loop pos =
+ case (Regexp.Compiled.matchShort
+ (profileInfoC,
+ profileInfo, pos)) of
+ NONE => []
+ | SOME m =>
+ let
+ val {lookup, ...} =
+ Match.stringFuns m
+ val level =
+ valOf (Int.fromString
+ (lookup level))
+ val name = lookup name
+ in
+ {profileLevel = level,
+ profileName = name}
+ :: loop (pos + Match.length m)
+ end
+ in loop 0
+ end
+ in
+ {addr = addr, profileInfo = profileInfo} :: ac
+ end
in
- {addr = addr, profileInfo = profileInfo} :: ac
+ case peek start of
+ SOME s =>
+ (startRef := SOME (valOf (Word.fromString s))
+ ; ac)
+ | NONE =>
+ case peek etext of
+ SOME s =>
+ (etextRef :=
+ SOME (valOf (Word.fromString s))
+ ; ac)
+ | NONE => normal ()
end))
- fun shrink {addr, profileInfo : {profileLevel: int,
+ fun shrink {addr, profileInfo : {profileLevel: int,
profileName: string} list}
= let
val profileInfo
@@ -309,23 +342,52 @@
else (shrink v1):: (compress (v2::l))
val l = List.rev (compress l)
+ val start =
+ case !startRef of
+ NONE => die "couldn't find _start label"
+ | SOME w => w
+ val etext =
+ case !etextRef of
+ NONE => die "couldn't find _etext label"
+ | SOME w => w
in
- T l
+ T {data = l,
+ etext = etext,
+ start = start}
end
val new = Trace.trace ("AFile.new", File.layout o #afile, layout) new
end
+structure Kind =
+ struct
+ datatype t = Alloc | Time
+ end
+
structure ProfFile =
struct
- datatype t = T of {buckets: {addr: word, count: int} list}
+ (* Profile information is a list of buckets, sorted in increasing order of
+ * address, with count always greater than 0.
+ *)
+ datatype t = T of {buckets: {addr: word,
+ count: IntInf.t} list,
+ etext: word,
+ kind: Kind.t,
+ magic: word,
+ start: word}
+
+ local
+ fun make f (T r) = f r
+ in
+ val kind = make #kind
+ end
fun layout (T {buckets, ...})
= let
open Layout
in
List.layout
- (fn {addr, count} => seq [Word.layout addr, str " ", Int.layout count])
+ (fn {addr, count} => seq [Word.layout addr, str " ", IntInf.layout count])
buckets
end
@@ -342,7 +404,6 @@
then die "Unexpected EOF"
else res
end
-
fun getString size = read size
fun getChar ():char
= let val s = read 1
@@ -352,9 +413,9 @@
= let val s = read 4
fun c i = Word.fromInt (Char.toInt (String.sub (s, i)))
in Word.orb (Word.orb (Word.<< (c 3, 0w24),
- Word.<< (c 2, 0w16)),
- Word.orb (Word.<< (c 1, 0w8),
- Word.<< (c 0, 0w0)))
+ Word.<< (c 2, 0w16)),
+ Word.orb (Word.<< (c 1, 0w8),
+ Word.<< (c 0, 0w0)))
end
fun getHWord (): word
= let val s = read 2
@@ -367,111 +428,147 @@
fun c i = Word.fromInt (Char.toInt (String.sub (s, i)))
in Word.<< (c 0, 0w0)
end
+ val _ =
+ if "MLton prof\n\000" <> getString 12
+ then
+ die (concat [mlmonfile,
+ " does not appear to be a mlmon.out file"])
+ else ()
val getAddr = getWord
- val _
- = if "MLton prof\n\000" <> getString 12
- then die
- (concat
- [mlmonfile, " does not appear to be a mlmon.out file"])
- else ()
- val low = getAddr ()
- val high = getAddr ()
-
- val unknowns = getWord ()
-
- fun doit (addr, ac)
- = if In.endOf ins
- then (addr, ac)
- else let
- val count = getWord ()
- val count = Word.toInt count
-
- val ac = if count <> 0
- then {addr = addr, count = count} :: ac
- else ac
- in
- doit (Word.+ (addr, 0wx1), ac)
- end
-
- val ac = if unknowns <> 0wx0
- then [{addr = 0wx0, count = Word.toInt unknowns}]
- else []
- val (addr, ac) = doit (low, ac)
-
- val _ = if addr <> high
- then die (concat [mlmonfile, " truncated:",
- " low: ", Word.toString low,
- " high: ", Word.toString high,
- " addr: ", Word.toString addr])
- else ()
+ val magic = getWord ()
+ val start = getAddr ()
+ val etext = getAddr ()
+ val countSize = getWord ()
+ val kind =
+ case getWord () of
+ 0w0 => Kind.Alloc
+ | 0w1 => Kind.Time
+ | _ => die "invalid mlmon.out kind"
+ fun getCount4 () = Word.toIntInf (getWord ())
+ fun getCount8 () =
+ let
+ val low = getCount4 ()
+ val high = getCount4 ()
+ open IntInf
+ in
+ low + high * pow (fromInt 2, Word.wordSize)
+ end
+ fun getCount (): IntInf.t =
+ case countSize of
+ 0w4 => getCount4 ()
+ | 0w8 => getCount8 ()
+ | _ => die "invalid count size"
+ fun loop ac =
+ if In.endOf ins
+ then rev ac
+ else let
+ val addr = getAddr ()
+ val _ =
+ if addr > 0w0
+ andalso (addr < start orelse addr >= etext)
+ then die "bad addr"
+ else ()
+ val count = getCount ()
+ val _ =
+ if count = IntInf.fromInt 0
+ then die "zero count"
+ else ()
+ in
+ loop ({addr = addr, count = count} :: ac)
+ end
+ val buckets = loop []
+ val buckets =
+ MergeSort.sort
+ (buckets, fn ({addr = a, ...}, {addr = a', ...}) => a <= a')
in
- T {buckets = rev ac}
+ T {buckets = buckets,
+ etext = etext,
+ kind = kind,
+ magic = magic,
+ start = start}
end)
val new = Trace.trace ("ProfFile.new", File.layout o #mlmonfile, layout) new
- fun addNew {profInfo as T {buckets},
- mlmonfile: File.t}: t
- = let
- val profInfo' as T {buckets = buckets'} = new {mlmonfile = mlmonfile}
-
- fun loop (buckets, buckets', ac)
- = case (buckets, buckets')
- of ([], buckets') => List.appendRev (ac, buckets')
+ fun merge (T {buckets = b, etext = e, kind = k, magic = m, start = s},
+ T {buckets = b', etext = e', kind = k', magic = m', start = s'}) =
+ if m <> m' orelse e <> e' orelse k <> k' orelse s <> s'
+ then die "incompatible mlmon files"
+ else
+ let
+ fun loop (buckets, buckets', ac) =
+ case (buckets, buckets') of
+ ([], buckets') => List.appendRev (ac, buckets')
| (buckets, []) => List.appendRev (ac, buckets)
| (buckets as {addr, count}::bs,
- buckets' as {addr = addr', count = count'}::bs')
- => (case Word.compare (addr, addr')
+ buckets' as {addr = addr', count = count'}::bs') =>
+ (case Word.compare (addr, addr')
of LESS => loop (bs, buckets',
{addr = addr, count = count}::ac)
- | EQUAL => loop (bs, bs',
- {addr = addr, count = count + count'}::ac)
- | GREATER => loop (buckets, bs',
- {addr = addr', count = count'}::ac))
- in
- T {buckets = loop (buckets, buckets', [])}
- end
+ | EQUAL => loop (bs, bs',
+ {addr = addr,
+ count = IntInf.+ (count, count')}
+ :: ac)
+ | GREATER => loop (buckets, bs',
+ {addr = addr', count = count'}::ac))
+ in
+ T {buckets = loop (b, b', []),
+ etext = e,
+ kind = k,
+ magic = m,
+ start = s}
+ end
+
+ fun addNew (pi, mlmonfile: File.t): t =
+ merge (pi, new {mlmonfile = mlmonfile})
- val addNew = Trace.trace ("ProfFile.addNew", File.layout o #mlmonfile, layout) addNew
+ val addNew = Trace.trace ("ProfFile.addNew", File.layout o #2, layout) addNew
end
-fun attribute (AFile.T l,
- ProfFile.T {buckets}) :
+fun attribute (AFile.T {data, etext = e, start = s},
+ ProfFile.T {buckets, etext = e', kind, start = s', ...}) :
{profileInfo: {name: string} ProfileInfo.t,
- ticks: int} list
+ ticks: IntInf.t} list
= let
+ val _ =
+ if e <> e' orelse s <> s'
+ then die "incompatible a.out and mlmon.out"
+ else ()
fun loop (profileInfoCurrent, ticks, l, buckets)
= let
fun done (ticks, rest)
- = if ticks <> 0
- then {profileInfo = profileInfoCurrent,
- ticks = ticks}::rest
- else rest
+ = if IntInf.equals (IntInf.fromInt 0, ticks)
+ then rest
+ else {profileInfo = profileInfoCurrent,
+ ticks = ticks} :: rest
in
case (l, buckets)
of (_, []) => done (ticks, [])
- | ([], _) => done (List.fold (buckets,
- ticks,
- fn ({count, ...}, ticks)
- => count + ticks),
+ | ([], _) => done (List.fold (buckets, ticks,
+ fn ({count, ...}, ticks) =>
+ IntInf.+ (count, ticks)),
[])
| ({addr = profileAddr, profileInfo}::l',
{addr = bucketAddr, count}::buckets')
=> if profileAddr <= bucketAddr
- then done (ticks, loop (profileInfo, 0, l', buckets))
- else loop (profileInfoCurrent, ticks + count, l, buckets')
+ then done (ticks,
+ loop (profileInfo, IntInf.fromInt 0, l', buckets))
+ else loop (profileInfoCurrent,
+ IntInf.+ (ticks, count), l, buckets')
end
in
- loop (ProfileInfo.T ([{data = {name = "<unknown>"},
+ loop (ProfileInfo.T ([{data = {name = (case kind of
+ Kind.Alloc => "<runtime>"
+ | Kind.Time => "<unknown>")},
minor = ProfileInfo.T []}]),
- 0, l, buckets)
+ IntInf.fromInt 0, data, buckets)
end
fun coalesce (counts: {profileInfo: {name: string} ProfileInfo.t,
- ticks: int} list) :
- {name: string, ticks: int} ProfileInfo.t
- = let
- datatype t = T of {ticks': int ref, map': t StringMap.t ref}
+ ticks: IntInf.t} list)
+ : {name: string, ticks: IntInf.t} ProfileInfo.t =
+ let
+ datatype t = T of {ticks': IntInf.t ref, map': t StringMap.t ref}
val map = StringMap.new ()
val _
= List.foreach
@@ -487,10 +584,10 @@
= StringMap.lookupOrInsert
(map,
name,
- fn () => T {ticks' = ref 0,
+ fn () => T {ticks' = ref (IntInf.fromInt 0),
map' = ref (StringMap.new ())})
in
- ticks' := !ticks' + ticks;
+ ticks' := IntInf.+ (!ticks', ticks);
doit (minor, !map')
end)
in
@@ -546,39 +643,50 @@
end
end)
-fun display (counts: {name: string, ticks: int} ProfileInfo.t,
+fun display (kind: Kind.t,
+ counts: {name: string, ticks: IntInf.t} ProfileInfo.t,
baseName: string,
depth: int) =
let
val ticksPerSecond = 100.0
val thresh = Real.fromInt (!thresh)
datatype t = T of {name: string,
- ticks: int,
+ ticks: IntInf.t,
row: string list,
minor: t} array
+ val mult = if !raw then 2 else 1
fun doit (info as ProfileInfo.T profileInfo,
n: int,
dotFile: File.t,
stuffing: string list,
totals: real list) =
let
- val total =
+ val totalInt =
List.fold
- (profileInfo, 0,
- fn ({data = {ticks, ...}, ...}, total) => total + ticks)
- val total = Real.fromInt total
+ (profileInfo, IntInf.fromInt 0,
+ fn ({data = {ticks, ...}, ...}, total) =>
+ IntInf.+ (total, ticks))
+ val total = Real.fromIntInf totalInt
val _ =
if n = 0
- then print (concat ([Real.format (total / ticksPerSecond,
- Real.Format.fix (SOME 2)),
- " seconds of CPU time\n"]))
+ then
+ print
+ (concat
+ (case kind of
+ Kind.Alloc =>
+ [IntInf.toCommaString totalInt,
+ " bytes allocated\n"]
+ | Kind.Time =>
+ [Real.format (total / ticksPerSecond,
+ Real.Format.fix (SOME 2)),
+ " seconds of CPU time\n"]))
else ()
val space = String.make (5 * n, #" ")
val profileInfo =
List.fold
(profileInfo, [], fn ({data = {name, ticks}, minor}, ac) =>
let
- val rticks = Real.fromInt ticks
+ val rticks = Real.fromIntInf ticks
fun per total = 100.0 * rticks / total
in
if per total < thresh
@@ -587,32 +695,49 @@
let
val per =
fn total =>
- concat [Real.format (per total,
- Real.Format.fix (SOME 2)),
- "%",
- if !extra
- then concat [" (",
- Real.format
- (rticks / ticksPerSecond,
- Real.Format.fix (SOME 2)),
- "s)"]
- else ""]
+ let
+ val a =
+ concat [Real.format (per total,
+ Real.Format.fix (SOME 2)),
+ "%"]
+ in
+ if !raw
+ then
+ [a,
+ concat
+ (case kind of
+ Kind.Alloc =>
+ ["(",
+ IntInf.toCommaString ticks,
+ ")"]
+ | Kind.Time =>
+ ["(",
+ Real.format
+ (rticks / ticksPerSecond,
+ Real.Format.fix (SOME 2)),
+ "s)"])]
+ else [a]
+ end
in
{name = name,
ticks = ticks,
row = (List.concat
[[concat [space, name]],
stuffing,
- [per total],
+ per total,
if !busy
- then List.map (totals, per)
+ then List.concatMap (totals, per)
else (List.duplicate
- (List.length totals, fn () => ""))]),
+ (List.length totals * mult,
+ fn () => ""))]),
minor = if n < depth
then doit (minor, n + 1,
concat [baseName, ".",
name, ".cfg.dot"],
- tl stuffing, total :: totals)
+ if !raw
+ then tl (tl stuffing)
+ else tl stuffing,
+ total :: totals)
else T (Array.new0 ())}
:: ac
end
@@ -620,15 +745,17 @@
val a = Array.fromList profileInfo
val _ =
QuickSort.sort
- (a, fn ({ticks = t1, ...}, {ticks = t2, ...}) => t1 >= t2)
+ (a, fn ({ticks = t1, ...}, {ticks = t2, ...}) =>
+ IntInf.>= (t1, t2))
(* Colorize. *)
val _ =
if n > 1 orelse not(!color) orelse 0 = Array.length a
then ()
else
let
- val ticks = Int.toReal (#ticks (Array.sub (a, 0)))
- fun thresh r = Real.floor (ticks * r)
+ val ticks: real =
+ Real.fromIntInf (#ticks (Array.sub (a, 0)))
+ fun thresh r = Real.toIntInf (Real.* (ticks, r))
val thresh1 = thresh (2.0 / 3.0)
val thresh2 = thresh (1.0 / 3.0)
datatype z = datatype DotColor.t
@@ -638,9 +765,9 @@
String.equals (l, name)) of
NONE => Black
| SOME {ticks, ...} =>
- if ticks >= thresh1
+ if IntInf.>= (ticks, thresh1)
then Red1
- else if ticks >= thresh2
+ else if IntInf.>= (ticks, thresh2)
then Orange2
else Yellow3)
in
@@ -663,74 +790,93 @@
fun toList (T a, ac) =
Array.foldr (a, ac, fn ({row, minor, ...}, ac) =>
row :: toList (minor, ac))
- val rows = toList (doit (counts, 0, concat [baseName, ".call-graph.dot"],
- List.duplicate (depth, fn () => ""),
- []), [])
+ val rows = toList (doit (counts, 0,
+ concat [baseName, ".call-graph.dot"],
+ List.duplicate (depth * mult, fn () => ""),
+ []),
+ [])
val _ =
let
open Justify
- in outputTable
- (table {justs = Left :: (List.duplicate (depth + 1, fn () => Right)),
+ in
+ outputTable
+ (table {justs = (Left
+ :: (List.duplicate ((depth + 1) * mult,
+ fn () => Right))),
rows = rows},
Out.standard)
end
in
()
end
+
+fun makeOptions {usage} =
+ let
+ open Popt
+ in
+ List.map
+ ([(Normal, "busy", "{false|true}", "show all percentages",
+ boolRef busy),
+ (Normal, "color", " {false|true}", "color .dot files",
+ boolRef color),
+ (Normal, "depth", " {0|1|2}", "depth of detail",
+ Int (fn i => if i < 0 orelse i > 2
+ then usage "invalid depth"
+ else depth := i)),
+ (Normal, "raw", " {false|true}", "show raw counts",
+ boolRef raw),
+ (Normal, "static", " {false|true}", "show static C functions",
+ boolRef static),
+ (Normal, "thresh", " {0|1|...|100}", "only show counts above threshold",
+ Int (fn i => if i < 0 orelse i > 100
+ then usage "invalid -thresh"
+ else thresh := i))],
+ fn (style, name, arg, desc, opt) =>
+ {arg = arg, desc = desc, name = name, opt = opt, style = style})
+ end
-fun usage s
- = Process.usage
- {usage = "[-color] [-d {0|1|2}] [-s] [-t n] [-x] a.out mlmon.out [mlmon.out ...]",
- msg = s}
+val mainUsage = "mlprof [option ...] a.out mlmon.out [mlmon.out ...]"
+val {parse, usage} =
+ Popt.makeUsage {mainUsage = mainUsage,
+ makeOptions = makeOptions,
+ showExpert = fn () => false}
fun main args =
let
- val depth = ref 0
- val rest
- = let
- open Popt
- in
- parse
- {switches = args,
- opts = [("b", trueRef busy),
- ("color", trueRef color),
- ("d", Int (fn i => if i < 0 orelse i > 2
- then die "invalid depth"
- else depth := i)),
- ("s", trueRef static),
- ("t", Int (fn i => if i < 0 orelse i > 100
- then die "invalid threshold"
- else thresh := i)),
- ("x", trueRef extra)]}
- end
+ val rest = parse args
in
- case rest
- of Result.No s => usage (concat ["invalid switch: ", s])
- | Result.Yes (afile::mlmonfile::mlmonfiles)
- => let
- val aInfo = AFile.new {afile = afile}
- val _ =
- if true
- then ()
- else (print "AFile:\n"
- ; Layout.outputl (AFile.layout aInfo, Out.standard))
- val profInfo = ProfFile.new {mlmonfile = mlmonfile}
- val profInfo =
- List.fold
- (mlmonfiles, profInfo, fn (mlmonfile, profInfo) =>
- ProfFile.addNew {profInfo = profInfo, mlmonfile = mlmonfile})
- val _ =
- if true
- then ()
- else (print "ProfFile:\n"
- ; Layout.outputl (ProfFile.layout profInfo, Out.standard))
- val info = coalesce (attribute (aInfo, profInfo))
- val _ = display (info, afile, !depth)
- in
- ()
- end
- | Result.Yes _ => usage "wrong number of args"
- end
+ case rest of
+ Result.No s => usage (concat ["invalid switch: ", s])
+ | Result.Yes (afile::mlmonfile::mlmonfiles) =>
+ let
+ val aInfo = AFile.new {afile = afile}
+ val _ =
+ if true
+ then ()
+ else (print "AFile:\n"
+ ; Layout.outputl (AFile.layout aInfo, Out.standard))
+ val profFile =
+ List.fold
+ (mlmonfiles, ProfFile.new {mlmonfile = mlmonfile},
+ fn (mlmonfile, profFile) =>
+ ProfFile.addNew (profFile, mlmonfile))
+ val _ =
+ if true
+ then ()
+ else (print "ProfFile:\n"
+ ; Layout.outputl (ProfFile.layout profFile, Out.standard))
+ val _ =
+ if !depth = 2
+ andalso ProfFile.kind profFile = Kind.Alloc
+ then usage "-depth 2 is meaningless with allocation profiling"
+ else ()
+ val info = coalesce (attribute (aInfo, profFile))
+ val _ = display (ProfFile.kind profFile, info, afile, !depth)
+ in
+ ()
+ end
+ | Result.Yes _ => usage "wrong number of args"
+ end
val main = Process.makeMain main
1.2 +9 -3 mlton/mlprof/mlprof-stubs.cm
Index: mlprof-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof-stubs.cm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- mlprof-stubs.cm 16 Apr 2002 13:17:40 -0000 1.1
+++ mlprof-stubs.cm 2 Nov 2002 03:37:37 -0000 1.2
@@ -1,4 +1,5 @@
Group is
+../lib/mlton-stubs/real.sml
../lib/mlton/pervasive/pervasive.sml
../lib/mlton/basic/dynamic-wind.sig
../lib/mlton/basic/dynamic-wind.sml
@@ -15,22 +16,25 @@
../lib/mlton/basic/fold.sig
../lib/mlton/basic/fold.fun
../lib/mlton-stubs/thread.sml
+../lib/mlton-stubs/random.sig
+../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
+../lib/mlton-stubs/io.sig
../lib/mlton-stubs/text-io.sig
../lib/mlton-stubs/syslog.sig
../lib/mlton-stubs/socket.sig
../lib/mlton-stubs/signal.sig
../lib/mlton-stubs/rusage.sig
../lib/mlton-stubs/rlimit.sig
-../lib/mlton-stubs/random.sig
../lib/mlton-stubs/ptrace.sig
../lib/mlton-stubs/profile.sig
../lib/mlton-stubs/process.sig
../lib/mlton-stubs/proc-env.sig
../lib/mlton-stubs/array.sig
+../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
../lib/mlton-stubs/gc.sig
@@ -92,6 +96,8 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/ordered-field.sig
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
@@ -149,8 +155,6 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
@@ -161,6 +165,8 @@
../lib/mlton/basic/quick-sort.sml
../lib/mlton/basic/justify.sig
../lib/mlton/basic/justify.sml
+../lib/mlton/basic/merge-sort.sig
+../lib/mlton/basic/merge-sort.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
main.sml
1.9 +4 -2 mlton/mlprof/mlprof.cm
Index: mlprof.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/mlprof.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mlprof.cm 16 Apr 2002 13:17:40 -0000 1.8
+++ mlprof.cm 2 Nov 2002 03:37:37 -0000 1.9
@@ -68,6 +68,8 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/ordered-field.sig
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
@@ -125,8 +127,6 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
@@ -137,6 +137,8 @@
../lib/mlton/basic/quick-sort.sml
../lib/mlton/basic/justify.sig
../lib/mlton/basic/justify.sml
+../lib/mlton/basic/merge-sort.sig
+../lib/mlton/basic/merge-sort.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
main.sml
1.5 +5 -4 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- mlton-stubs.cm 7 Aug 2002 01:02:42 -0000 1.4
+++ mlton-stubs.cm 2 Nov 2002 03:37:38 -0000 1.5
@@ -35,6 +35,7 @@
../lib/mlton/basic/dynamic-wind.sml
../lib/mlton/basic/error.sig
../lib/mlton/basic/error.sml
+../lib/mlton-stubs/real.sml
../lib/mlton/pervasive/pervasive.sml
../lib/mlton/basic/outstream0.sml
../lib/mlton/basic/relation0.sml
@@ -109,6 +110,8 @@
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
../lib/mlton/basic/ordered-field.fun
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/real.sig
../lib/mlton/basic/real.sml
../lib/mlton/basic/random.sig
@@ -158,8 +161,6 @@
../lib/mlton/basic/justify.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/file-desc.sig
../lib/mlton/basic/file-desc.sml
../lib/mlton/basic/function.sig
@@ -336,6 +337,8 @@
backend/signal-check.sig
backend/signal-check.fun
backend/rssa.fun
+backend/profile-alloc.sig
+backend/profile-alloc.fun
backend/parallel-move.sig
backend/parallel-move.fun
backend/limit-check.sig
@@ -353,8 +356,6 @@
backend/live.fun
backend/allocate-registers.sig
backend/allocate-registers.fun
-backend/array-init.sig
-backend/array-init.fun
backend/backend.fun
xml/xml-type.sig
xml/xml-tree.sig
1.54 +4 -4 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- mlton.cm 6 Jul 2002 17:22:05 -0000 1.53
+++ mlton.cm 2 Nov 2002 03:37:38 -0000 1.54
@@ -82,6 +82,8 @@
../lib/mlton/basic/field.sig
../lib/mlton/basic/field.fun
../lib/mlton/basic/ordered-field.fun
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/real.sig
../lib/mlton/basic/real.sml
../lib/mlton/basic/random.sig
@@ -131,8 +133,6 @@
../lib/mlton/basic/justify.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/file-desc.sig
../lib/mlton/basic/file-desc.sml
../lib/mlton/basic/function.sig
@@ -309,6 +309,8 @@
backend/signal-check.sig
backend/signal-check.fun
backend/rssa.fun
+backend/profile-alloc.sig
+backend/profile-alloc.fun
backend/parallel-move.sig
backend/parallel-move.fun
backend/limit-check.sig
@@ -326,8 +328,6 @@
backend/live.fun
backend/allocate-registers.sig
backend/allocate-registers.fun
-backend/array-init.sig
-backend/array-init.fun
backend/backend.fun
xml/xml-type.sig
xml/xml-tree.sig
1.38 +2 -7 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- prim.fun 1 Nov 2002 01:25:34 -0000 1.37
+++ prim.fun 2 Nov 2002 03:37:38 -0000 1.38
@@ -33,8 +33,7 @@
structure Name =
struct
datatype t =
- Array_allocate
- | Array_array
+ Array_array
| Array_array0
| Array_array0Const
| Array_length
@@ -256,7 +255,6 @@
*)
val strings =
[
- (Array_allocate, Moveable, "Array_allocate"),
(Array_array, Moveable, "Array_array"),
(Array_array0, Moveable, "Array_array0"),
(Array_array0Const, Moveable, "Array_array0Const"),
@@ -351,7 +349,7 @@
(Real_ldexp, Functional, "Real_ldexp"),
(Real_le, Functional, "Real_le"),
(Real_lt, Functional, "Real_lt"),
- (Real_modf, Functional, "Real_modf"),
+ (Real_modf, SideEffect, "Real_modf"),
(Real_mul, Functional, "Real_mul"),
(Real_muladd, Functional, "Real_muladd"),
(Real_mulsub, Functional, "Real_mulsub"),
@@ -529,9 +527,6 @@
end
val tuple = tuple o Vector.fromList
in
- val arrayAllocate =
- new (Name.Array_allocate,
- make1 (fn a => tuple [int, word, word] --> array a))
val array0 = new (Name.Array_array0, make1 (fn a => unit --> array a))
val array = new (Name.Array_array, make1 (fn a => int --> array a))
val assign = new (Name.Ref_assign, make1 (fn a => tuple [reff a, a] --> unit))
1.31 +1 -3 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- prim.sig 25 Aug 2002 22:23:57 -0000 1.30
+++ prim.sig 2 Nov 2002 03:37:38 -0000 1.31
@@ -23,8 +23,7 @@
structure Name:
sig
datatype t =
- Array_allocate (* created and implemented in backend *)
- | Array_array (* implemented in backend *)
+ Array_array (* implemented in backend *)
| Array_array0 (* implemented in backend *)
| Array_array0Const (* implemented in constant-propagation.fun *)
| Array_length
@@ -251,7 +250,6 @@
val allocTooLarge: t
val apply: t * 'a ApplyArg.t list * ('a * 'a -> bool) -> 'a ApplyResult.t
val array0: t
- val arrayAllocate: t
val array: t
val assign: t
val bogus: t
1.35 +17 -7 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- backend.fun 30 Jul 2002 16:53:43 -0000 1.34
+++ backend.fun 2 Nov 2002 03:37:38 -0000 1.35
@@ -46,9 +46,9 @@
structure Var = Var
end
+structure ProfileAlloc = ProfileAlloc (structure Rssa = Rssa)
structure AllocateRegisters = AllocateRegisters (structure Machine = Machine
structure Rssa = Rssa)
-structure ArrayInit = ArrayInit (structure Rssa = Rssa)
structure Chunkify = Chunkify (Rssa)
structure LimitCheck = LimitCheck (structure Rssa = Rssa)
structure ParallelMove = ParallelMove ()
@@ -158,8 +158,11 @@
val program = pass ("ssaToRssa", SsaToRssa.convert, program)
val program = pass ("insertLimitChecks", LimitCheck.insert, program)
val program = pass ("insertSignalChecks", SignalCheck.insert, program)
- val program = pass ("insertArrayInits", ArrayInit.insert, program)
- val program as R.Program.T {functions, main} = program
+ val program =
+ if !Control.profile = Control.ProfileAlloc
+ then pass ("profileAlloc", ProfileAlloc.doit, program)
+ else program
+ val program as R.Program.T {functions, main, profileAllocLabels} = program
val handlesSignals = Rssa.Program.handlesSignals program
(* Chunk information *)
val {get = labelChunk, set = setLabelChunk, ...} =
@@ -361,6 +364,10 @@
temp = temp
})
end
+ val array0Header =
+ M.Operand.Uint (Runtime.typeIndexToHeader
+ (arrayTypeIndex {numBytesNonPointers = 0,
+ numPointers = 0}))
fun translateOperand (oper: R.Operand.t): M.Operand.t =
let
datatype z = datatype R.Operand.t
@@ -432,12 +439,13 @@
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
- Array_allocate =>
+ Array_array0 =>
let
val frontier =
M.Operand.Runtime GCField.Frontier
fun arg i =
translateOperand (Vector.sub (args, i))
+ val numElts = arg 0
in Vector.new5
(M.Statement.Move
{dst = M.Operand.Contents {oper = frontier,
@@ -447,12 +455,12 @@
{dst = M.Operand.Offset {base = frontier,
offset = wordSize,
ty = Type.int},
- src = translateOperand (Vector.sub (args, 0))},
+ src = numElts},
M.Statement.Move
{dst = M.Operand.Offset {base = frontier,
offset = 2 * wordSize,
ty = Type.uint},
- src = translateOperand (Vector.sub (args, 2))},
+ src = array0Header},
M.Statement.PrimApp
{args = Vector.new2 (frontier,
M.Operand.Uint
@@ -461,7 +469,8 @@
dst = SOME (varOperand (#1 (valOf dst))),
prim = Prim.word32Add},
M.Statement.PrimApp
- {args = Vector.new2 (frontier, arg 1),
+ {args = Vector.new2 (frontier,
+ M.Operand.Uint (Word.fromInt Runtime.array0Size)),
dst = SOME frontier,
prim = Prim.word32Add})
end
@@ -1005,6 +1014,7 @@
main = main,
maxFrameSize = maxFrameSize,
objectTypes = objectTypes (),
+ profileAllocLabels = profileAllocLabels,
strings = allStrings ()}
end
1.3 +11 -17 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- c-function.fun 11 Jul 2002 02:16:49 -0000 1.2
+++ c-function.fun 2 Nov 2002 03:37:38 -0000 1.3
@@ -16,12 +16,12 @@
modifiesFrontier: bool,
modifiesStackTop: bool,
name: string,
- needsArrayInit: bool,
+ needsProfileAllocIndex: bool,
returnTy: Type.t option}
fun layout (T {bytesNeeded, ensuresBytesFree, mayGC, maySwitchThreads,
- modifiesFrontier, modifiesStackTop, name, needsArrayInit,
- returnTy}) =
+ modifiesFrontier, modifiesStackTop, name,
+ needsProfileAllocIndex, returnTy}) =
Layout.record
[("bytesNeeded", Option.layout Int.layout bytesNeeded),
("ensuresBytesFree", Bool.layout ensuresBytesFree),
@@ -30,7 +30,7 @@
("modifiesFrontier", Bool.layout modifiesFrontier),
("modifiesStackTop", Bool.layout modifiesStackTop),
("name", String.layout name),
- ("needsArrayInit", Bool.layout needsArrayInit),
+ ("needsProfileAllocIndex", Bool.layout needsProfileAllocIndex),
("returnTy", Option.layout Type.layout returnTy)]
local
@@ -43,12 +43,12 @@
val modifiesFrontier = make #modifiesFrontier
val modifiesStackTop = make #modifiesStackTop
val name = make #name
- val needsArrayInit = make #needsArrayInit
+ val needsProfileAllocIndex = make #needsProfileAllocIndex
val returnTy = make #returnTy
end
fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
- modifiesStackTop, needsArrayInit, returnTy, ...}): bool =
+ modifiesStackTop, returnTy, ...}): bool =
(if maySwitchThreads
then (case returnTy of
NONE => true
@@ -62,12 +62,6 @@
(if mayGC
then modifiesFrontier andalso modifiesStackTop
else true)
- andalso
- (if needsArrayInit
- then (case returnTy of
- NONE => false
- | SOME t => Type.equals (t, Type.pointer))
- else true)
val isOk = Trace.trace ("CFunction.isOk", layout, Bool.layout) isOk
@@ -78,7 +72,7 @@
modifiesFrontier = f,
modifiesStackTop = t,
name = n,
- needsArrayInit = nai,
+ needsProfileAllocIndex = np,
returnTy = r},
T {bytesNeeded = b',
ensuresBytesFree = e',
@@ -87,10 +81,10 @@
modifiesFrontier = f',
modifiesStackTop = t',
name = n',
- needsArrayInit = nai',
+ needsProfileAllocIndex = np',
returnTy = r'}) =
b = b' andalso e = e' andalso g = g' andalso s = s' andalso f = f'
- andalso t = t' andalso n = n' andalso nai = nai'
+ andalso t = t' andalso n = n' andalso np = np'
andalso Option.equals (r, r', Type.equals)
val equals =
@@ -105,7 +99,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_gc",
- needsArrayInit = false,
+ needsProfileAllocIndex = false,
returnTy = NONE}
val t = make true
val f = make false
@@ -121,7 +115,7 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = name,
- needsArrayInit = false,
+ needsProfileAllocIndex = false,
returnTy = returnTy}
val bug = vanilla {name = "MLton_bug",
1.2 +2 -2 mlton/mlton/backend/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- c-function.sig 6 Jul 2002 17:22:05 -0000 1.1
+++ c-function.sig 2 Nov 2002 03:37:38 -0000 1.2
@@ -31,7 +31,7 @@
mayGC: bool,
maySwitchThreads: bool,
name: string,
- needsArrayInit: bool,
+ needsProfileAllocIndex: bool,
returnTy: Type.t option}
val bug: t
@@ -46,7 +46,7 @@
val modifiesFrontier: t -> bool
val modifiesStackTop: t -> bool
val name: t -> string
- val needsArrayInit: t -> bool
+ val needsProfileAllocIndex: t -> bool
val returnTy: t -> Type.t option
val size: t
val stringEqual: t
1.12 +1 -1 mlton/mlton/backend/chunkify.fun
Index: chunkify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/chunkify.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- chunkify.fun 6 Jul 2002 17:22:05 -0000 1.11
+++ chunkify.fun 2 Nov 2002 03:37:38 -0000 1.12
@@ -12,7 +12,7 @@
datatype z = datatype Transfer.t
(* A chunkifier that puts each function in its own chunk. *)
-fun chunkPerFunc (Program.T {functions, main}) =
+fun chunkPerFunc (Program.T {functions, main, ...}) =
Vector.fromListMap
(main :: functions, fn f =>
let
1.26 +5 -6 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- limit-check.fun 6 Jul 2002 17:22:05 -0000 1.25
+++ limit-check.fun 2 Nov 2002 03:37:38 -0000 1.26
@@ -81,10 +81,8 @@
numWordsNonPointers = nwnp}))
| PrimApp {args, prim, ...} =>
(case Prim.name prim of
- Prim.Name.Array_allocate =>
- Operand.caseBytes (Vector.sub (args, 1),
- {big = big,
- small = small})
+ Prim.Name.Array_array0 =>
+ small (Word.fromInt Runtime.array0Size)
| _ => small 0w0)
| _ => small 0w0
end
@@ -679,7 +677,7 @@
f
end
-fun insert (p as Program.T {functions, main}) =
+fun insert (p as Program.T {functions, main, profileAllocLabels}) =
let
val _ = Control.diagnostic (fn () => Layout.str "Limit Check maxPaths")
datatype z = datatype Control.limitCheck
@@ -710,7 +708,8 @@
start = newStart}
in
Program.T {functions = functions,
- main = main}
+ main = main,
+ profileAllocLabels = profileAllocLabels}
end
end
1.28 +5 -2 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- machine.fun 30 Jul 2002 19:15:53 -0000 1.27
+++ machine.fun 2 Nov 2002 03:37:38 -0000 1.28
@@ -500,11 +500,12 @@
label: Label.t},
maxFrameSize: int,
objectTypes: Runtime.ObjectType.t vector,
+ profileAllocLabels: string vector,
strings: (Global.t * string) list}
fun layouts (p as T {chunks, frameOffsets, globals, globalsNonRoot,
handlesSignals, main = {label, ...}, maxFrameSize,
- objectTypes, ...},
+ objectTypes, profileAllocLabels, ...},
output': Layout.t -> unit) =
let
open Layout
@@ -522,6 +523,8 @@
("maxFrameSize", Int.layout maxFrameSize),
("objectTypes",
Vector.layout Runtime.ObjectType.layout objectTypes),
+ ("profileAllocLabels",
+ Vector.layout String.layout profileAllocLabels),
("frameOffsets",
Vector.layout (Vector.layout Int.layout) frameOffsets)])
; List.foreach (chunks, fn chunk => Chunk.layouts (chunk, output))
@@ -727,7 +730,7 @@
CFunction.equals (func, f)
andalso
(case (dst, CFunction.returnTy f) of
- (NONE, NONE) => true
+ (NONE, _) => true
| (SOME x, SOME ty) =>
Type.equals
(ty, Operand.ty x)
1.21 +2 -1 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- machine.sig 6 Jul 2002 17:22:05 -0000 1.20
+++ machine.sig 2 Nov 2002 03:37:38 -0000 1.21
@@ -217,7 +217,7 @@
datatype t =
T of {chunks: Chunk.t list,
floats: (Global.t * string) list,
- (* Each vector in frame Offsets is a specifies the offsets
+ (* Each vector in frame Offsets specifies the offsets
* of live pointers in a stack frame. A vector is referred
* to by index as the frameOffsetsIndex in a block kind.
*)
@@ -230,6 +230,7 @@
label: Label.t},
maxFrameSize: int,
objectTypes: Runtime.ObjectType.t vector,
+ profileAllocLabels: string vector,
strings: (Global.t * string) list}
val layouts: t * (Layout.t -> unit) -> unit
1.18 +7 -6 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- rssa.fun 30 Jul 2002 19:15:54 -0000 1.17
+++ rssa.fun 2 Nov 2002 03:37:38 -0000 1.18
@@ -495,7 +495,7 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = "MLton_allocTooLarge",
- needsArrayInit = false,
+ needsProfileAllocIndex = false,
returnTy = NONE}
val _ =
newBlocks :=
@@ -631,13 +631,14 @@
structure Program =
struct
datatype t = T of {functions: Function.t list,
- main: Function.t}
+ main: Function.t,
+ profileAllocLabels: string vector}
fun clear (T {functions, main, ...}) =
(List.foreach (functions, Function.clear)
; Function.clear main)
- fun hasPrim (T {functions, main}, pred) =
+ fun hasPrim (T {functions, main, ...}, pred) =
let
fun has f = Function.hasPrim (f, pred)
in
@@ -647,7 +648,7 @@
fun handlesSignals p =
hasPrim (p, fn p => Prim.name p = Prim.Name.MLton_installSignalHandler)
- fun layouts (T {functions, main}, output': Layout.t -> unit): unit =
+ fun layouts (T {functions, main, ...}, output': Layout.t -> unit): unit =
let
open Layout
val output = output'
@@ -658,7 +659,7 @@
; List.foreach (functions, output o Function.layout)
end
- fun checkScopes (program as T {functions, main}): unit =
+ fun checkScopes (program as T {functions, main, ...}): unit =
let
datatype status =
Defined
@@ -752,7 +753,7 @@
in ()
end
- fun typeCheck (p as T {functions, main}) =
+ fun typeCheck (p as T {functions, main, ...}) =
let
val _ = checkScopes p
val {get = labelBlock: Label.t -> Block.t,
1.16 +2 -1 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- rssa.sig 30 Jul 2002 16:53:44 -0000 1.15
+++ rssa.sig 2 Nov 2002 03:37:38 -0000 1.16
@@ -237,7 +237,8 @@
* functions. It defines global variables that are in scope
* for the rest of the program.
*)
- main: Function.t}
+ main: Function.t,
+ profileAllocLabels: string vector}
val clear: t -> unit
val handlesSignals: t -> bool
1.6 +10 -4 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- runtime.fun 7 Aug 2002 01:02:42 -0000 1.5
+++ runtime.fun 2 Nov 2002 03:37:39 -0000 1.6
@@ -23,6 +23,7 @@
| Limit
| LimitPlusSlop
| MaxFrameSize
+ | ProfileAllocIndex
| SignalIsPending
| StackBottom
| StackLimit
@@ -36,6 +37,7 @@
| Limit => Type.pointer
| LimitPlusSlop => Type.pointer
| MaxFrameSize => Type.word
+ | ProfileAllocIndex => Type.word
| SignalIsPending => Type.int
| StackBottom => Type.pointer
| StackLimit => Type.pointer
@@ -48,14 +50,15 @@
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, signalIsPending, stackBottom,
- stackLimit, stackTop} =
+ limitPlusSlop, maxFrameSize, profileAllocIndex,
+ signalIsPending, stackBottom, stackLimit, stackTop} =
(canHandleOffset := canHandle
; cardMapOffset := cardMap
; currentThreadOffset := currentThread
@@ -63,6 +66,7 @@
; limitOffset := limit
; limitPlusSlopOffset := limitPlusSlop
; maxFrameSizeOffset := maxFrameSize
+ ; profileAllocIndexOffset := profileAllocIndex
; signalIsPendingOffset := signalIsPending
; stackBottomOffset := stackBottom
; stackLimitOffset := stackLimit
@@ -76,6 +80,7 @@
| Limit => !limitOffset
| LimitPlusSlop => !limitPlusSlopOffset
| MaxFrameSize => !maxFrameSizeOffset
+ | ProfileAllocIndex => !profileAllocIndexOffset
| SignalIsPending => !signalIsPendingOffset
| StackBottom => !stackBottomOffset
| StackLimit => !stackLimitOffset
@@ -89,6 +94,7 @@
| Limit => "Limit"
| LimitPlusSlop => "LimitPlusSlop"
| MaxFrameSize => "MaxFrameSize"
+ | ProfileAllocIndex => "ProfileAllocIndex"
| SignalIsPending => "SignalIsPending"
| StackBottom => "StackBottom"
| StackLimit => "StackLimit"
@@ -125,7 +131,7 @@
end
end
-val maxTypeIndex = Int.^ (2, 19)
+val maxTypeIndex = Int.pow (2, 19)
fun typeIndexToHeader typeIndex =
(Assert.assert ("Runtime.header", fn () =>
@@ -163,6 +169,6 @@
fun isValidObjectSize (n: int): bool =
n > 0 andalso isWordAligned n
-val maxFrameSize = Int.^ (2, 16)
+val maxFrameSize = Int.pow (2, 16)
end
1.15 +2 -0 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- runtime.sig 7 Aug 2002 01:02:42 -0000 1.14
+++ runtime.sig 2 Nov 2002 03:37:39 -0000 1.15
@@ -29,6 +29,7 @@
| Limit (* frontier + heapSize - LIMIT_SLOP *)
| LimitPlusSlop (* frontier + heapSize *)
| MaxFrameSize
+ | ProfileAllocIndex
| SignalIsPending
| StackBottom
| StackLimit (* Must have StackTop <= StackLimit *)
@@ -43,6 +44,7 @@
limit: int,
limitPlusSlop: int,
maxFrameSize: int,
+ profileAllocIndex: int,
signalIsPending: int,
stackBottom: int,
stackLimit: int,
1.10 +3 -2 mlton/mlton/backend/signal-check.fun
Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- signal-check.fun 6 Jul 2002 17:22:05 -0000 1.9
+++ signal-check.fun 2 Nov 2002 03:37:39 -0000 1.10
@@ -21,7 +21,7 @@
then p
else
let
- val Program.T {functions, main} = p
+ val Program.T {functions, main, profileAllocLabels} = p
fun insert (f: Function.t): Function.t =
let
val {args, blocks, name, start} = Function.dest f
@@ -170,7 +170,8 @@
end
in
Program.T {functions = List.revMap (functions, insert),
- main = main}
+ main = main,
+ profileAllocLabels = profileAllocLabels}
end
end
1.11 +2 -2 mlton/mlton/backend/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- sources.cm 6 Jul 2002 17:22:05 -0000 1.10
+++ sources.cm 2 Nov 2002 03:37:39 -0000 1.11
@@ -23,8 +23,6 @@
allocate-registers.fun
allocate-registers.sig
-array-init.fun
-array-init.sig
backend.fun
backend.sig
c-function.fun
@@ -48,6 +46,8 @@
mtype.sig
parallel-move.fun
parallel-move.sig
+profile-alloc.fun
+profile-alloc.sig
representation.fun
representation.sig
rssa.fun
1.24 +17 -146 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.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- ssa-to-rssa.fun 18 Aug 2002 07:17:22 -0000 1.23
+++ ssa-to-rssa.fun 2 Nov 2002 03:37:39 -0000 1.24
@@ -45,7 +45,7 @@
modifiesFrontier = true,
modifiesStackTop = false,
name = name,
- needsArrayInit = false,
+ needsProfileAllocIndex = true,
returnTy = SOME Type.pointer}
in
val intInfAdd = make ("IntInf_do_add", 2)
@@ -74,7 +74,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyCurrentThread",
- needsArrayInit = false,
+ needsProfileAllocIndex = true,
returnTy = NONE}
val copyThread =
@@ -85,7 +85,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyThread",
- needsArrayInit = false,
+ needsProfileAllocIndex = true,
returnTy = SOME Type.pointer}
val exit =
@@ -96,7 +96,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "MLton_exit",
- needsArrayInit = false,
+ needsProfileAllocIndex = false,
returnTy = NONE}
val gcArrayAllocate =
@@ -107,7 +107,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_arrayAllocate",
- needsArrayInit = false,
+ needsProfileAllocIndex = true,
returnTy = SOME Type.pointer}
local
@@ -119,7 +119,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = name,
- needsArrayInit = false,
+ needsProfileAllocIndex = false,
returnTy = NONE}
in
val pack = make "GC_pack"
@@ -134,7 +134,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "Thread_switchTo",
- needsArrayInit = false,
+ needsProfileAllocIndex = false,
returnTy = NONE}
val worldSave =
@@ -145,7 +145,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_saveWorld",
- needsArrayInit = false,
+ needsProfileAllocIndex = false,
returnTy = NONE}
end
@@ -864,16 +864,9 @@
func = f}
fun array0 (numElts: Operand.t) =
add
- (PrimApp
- {args = (Vector.new3
- (numElts,
- Operand.word
- (Word.fromInt Runtime.array0Size),
- Operand.ArrayHeader
- {numBytesNonPointers = 0,
- numPointers = 0})),
- dst = dst (),
- prim = Prim.arrayAllocate})
+ (PrimApp {args = Vector.new1 numElts,
+ dst = dst (),
+ prim = Prim.array0})
fun updateCard (addr: Operand.t, prefix, assign) =
let
val index = Var.newNoname ()
@@ -972,136 +965,13 @@
in
if 0 = np andalso 0 = nbnp
then array0 numEltsOp
- else if not (!Control.inlineArrayAllocation)
- then ccall {args = (Vector.new4
- (Operand.GCState,
- Operand.EnsuresBytesFree,
+ else ccall {args = (Vector.new4
+ (Operand.GCState,
+ Operand.EnsuresBytesFree,
numEltsOp,
ArrayHeader {numBytesNonPointers = nbnp,
numPointers = np})),
- func = CFunction.gcArrayAllocate}
- else
- let
- val (shouldSplit, numBytes, numElts, continue) =
- case varInt numElts of
- SOME n =>
- (* Compute the number of bytes in the array now,
- * since the number of elements is a known constant.
- *)
- let
- val numBytes =
- Runtime.wordAlign
- (MLton.Word.addCheck
- (Word.fromInt Runtime.arrayHeaderSize,
- (MLton.Word.mulCheck
- (Word.fromInt n,
- Word.fromInt bytesPerElt))))
- handle Overflow => Runtime.allocTooLarge
- in
- (numBytes > 0w512,
- Operand.word numBytes,
- Operand.int n,
- fn l => ([], Goto {dst = l,
- args = Vector.new0 ()}))
- end
- | NONE =>
- let
- val numBytes = Var.newNoname ()
- val numBytes' = Var.newNoname ()
- val numBytesOp' =
- Operand.Var {var = numBytes', ty = Type.word}
- val numEltsWord = Var.newNoname ()
- val numEltsWordOp =
- Operand.Var {var = numEltsWord,
- ty = Type.word}
- val conv =
- PrimApp {args = Vector.new1 numEltsOp,
- dst = SOME (numEltsWord, Type.word),
- prim = Prim.word32FromInt}
- in
- (true,
- Operand.Var {var = numBytes, ty = Type.word},
- numEltsOp,
- fn alloc =>
- if 1 = nbnp
- then
- let
- val numEltsP3 = Var.newNoname ()
- in
- ([conv,
- PrimApp
- {args = (Vector.new2
- (Operand.word 0w3,
- numEltsWordOp)),
- dst = SOME (numEltsP3, Type.word),
- prim = Prim.word32Add},
- PrimApp
- {args = (Vector.new2
- (Operand.word
- (Word.notb 0w3),
- Operand.Var
- {var = numEltsP3,
- ty = Type.word})),
- dst = SOME (numBytes', Type.word),
- prim = Prim.word32Andb},
- PrimApp
- {args = (Vector.new2
- (Operand.word
- (Word.fromInt
- Runtime.arrayHeaderSize),
- numBytesOp')),
- dst = SOME (numBytes, Type.word),
- prim = Prim.word32Add}],
- Goto {args = Vector.new0 (),
- dst = alloc})
- end
- else
- let
- val l = newBlock
- {args = Vector.new0 (),
- kind = Kind.Jump,
- profileInfo = profileInfo,
- statements = Vector.new0 (),
- transfer =
- Transfer.Arith
- {args = Vector.new2
- (Operand.word
- (Word.fromInt
- Runtime.arrayHeaderSize),
- numBytesOp'),
- dst = numBytes,
- overflow = allocTooLarge (),
- prim = Prim.word32AddCheck,
- success = alloc,
- ty = Type.word}}
- in
- ([conv],
- Transfer.Arith
- {args = (Vector.new2
- (Operand.word
- (Word.fromInt bytesPerElt),
- numEltsWordOp)),
- dst = numBytes',
- overflow = allocTooLarge (),
- prim = Prim.word32MulCheck,
- success = l,
- ty = Type.word})
- end)
- end
- val s =
- PrimApp {args = (Vector.new3
- (numElts,
- numBytes,
- Operand.ArrayHeader
- {numBytesNonPointers = nbnp,
- numPointers = np})),
- dst = dst (),
- prim = Prim.arrayAllocate}
- in
- if shouldSplit
- then split (Vector.new0 (), Kind.Jump, s :: ss, continue)
- else add s
- end
+ func = CFunction.gcArrayAllocate}
end
end
| Array_array0 => array0 (Operand.int 0)
@@ -1414,7 +1284,8 @@
end
val functions = List.revMap (functions, translateFunction)
val p = Program.T {functions = functions,
- main = main}
+ main = main,
+ profileAllocLabels = Vector.new0 ()}
val _ = Program.clear p
in
p
1.2 +137 -0 mlton/mlton/backend/profile-alloc.fun
1.2 +21 -0 mlton/mlton/backend/profile-alloc.sig
1.32 +7 -35 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.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- c-codegen.fun 26 Aug 2002 00:21:43 -0000 1.31
+++ c-codegen.fun 2 Nov 2002 03:37:39 -0000 1.32
@@ -105,24 +105,6 @@
fun bug (s: string, print) =
call ("MLton_bug", [concat ["\"", String.escapeC s, "\""]], print)
- local
- val current = ref ""
- in
- fun profile (detailed: string, nonDetailed: string,
- print: string -> unit): unit =
- if !Control.profile
- then
- if detailed <> !current
- then (print "/* PROFILE: "
- ; print detailed
- ; print " & "
- ; print nonDetailed
- ; print " */\n"
- ; current := detailed)
- else ()
- else ()
- end
-
fun push (i, print) = call ("\tPush", [int i], print)
fun move ({dst, src}, print) =
@@ -176,6 +158,7 @@
| Limit => "gcState.limit"
| LimitPlusSlop => "gcState.limitPlusSlop"
| MaxFrameSize => "gcState.maxFrameSize"
+ | ProfileAllocIndex => "gcState.profileAllocIndex"
| SignalIsPending => "gcState.signalIsPending"
| StackBottom => "gcState.stackBottom"
| StackLimit => "gcState.stackLimit"
@@ -197,9 +180,8 @@
name: string,
print: string -> unit,
program = (Machine.Program.T
- {chunks, frameOffsets, floats, globals,
- globalsNonRoot, intInfs, maxFrameSize, objectTypes, strings,
- ...}),
+ {chunks, frameOffsets, floats, globals, globalsNonRoot, intInfs,
+ maxFrameSize, objectTypes, strings, ...}),
rest: unit -> unit
}: unit =
let
@@ -563,15 +545,11 @@
end) arg
and printLabelCode arg =
tracePrintLabelCode
- (fn {block = Block.T {kind, label = l, live,
- profileInfo as
- {ssa as {func = profileInfoFunc,
- label = profileInfoLabel}, ...},
- statements, transfer, ...},
+ (fn {block = Block.T {kind, label = l, live, statements,
+ transfer, ...},
layedOut, status, ...} =>
let
val _ = layedOut := true
- val _ = C.profile (profileInfoFunc, profileInfoFunc, print)
val _ =
case !status of
Many =>
@@ -774,11 +752,8 @@
iff (concat ["IsInt (", Operand.toString test, ")"],
int, pointer)
end
- fun profChunkSwitch () =
- C.profile ("ChunkSwitch (magic)", overhead, print)
in
- C.profile ("Chunk (magic)", overhead, print)
- ; C.callNoSemi ("Chunk", [ChunkLabel.toString chunkLabel], print)
+ C.callNoSemi ("Chunk", [ChunkLabel.toString chunkLabel], print)
; print "\n"
(* Declare registers. *)
; List.foreach (Type.all, fn ty =>
@@ -786,17 +761,14 @@
fn i => C.call (concat ["D", Type.name ty],
[C.int i],
print)))
- ; profChunkSwitch ()
; print "ChunkSwitch\n"
; Vector.foreach (blocks, fn Block.T {kind, label, ...} =>
if Kind.isEntry kind
- then (profChunkSwitch ()
- ; print "case "
+ then (print "case "
; print (Label.toStringIndex label)
; print ":\n"
; gotoLabel label)
else ())
- ; C.profile ("EndChunk (magic)", overhead, print)
; print "EndChunk\n"
end
val additionalMainArgs =
1.29 +80 -40 mlton/mlton/codegen/x86-codegen/x86-codegen.fun
Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86-codegen.fun 17 Sep 2002 05:05:37 -0000 1.28
+++ x86-codegen.fun 2 Nov 2002 03:37:40 -0000 1.29
@@ -64,22 +64,8 @@
struct
val truee = "TRUE"
val falsee = "FALSE"
-
- fun args(ss: string list): string
- = concat("(" :: List.separate(ss, ", ") @ [")"])
-
- fun callNoSemi(f: string, xs: string list, print: string -> unit): unit
- = (print f
- ; print "("
- ; (case xs
- of [] => ()
- | x :: xs => (print x
- ; List.foreach(xs,
- fn x => (print ", "; print x))))
- ; print ")")
- fun call(f, xs, print) = (callNoSemi(f, xs, print)
- ; print ";\n")
+ fun bool b = if b then truee else falsee
fun int(n: int): string
= if n >= 0
@@ -88,23 +74,6 @@
then "(int)0x80000000" (* because of goofy gcc warning *)
else "-" ^ String.dropPrefix(Int.toString n, 1)
(* This overflows on Int32.minInt: Int32.toString(~ n) *)
-
- fun char(c: char)
- = concat[if Char.ord c >= 0x80 then "(uchar)" else "",
- "'", Char.escapeC c, "'"]
-
- fun word(w: Word.t) = "0x" ^ Word.toString w
-
- (* The only difference between SML floats and C floats is that
- * SML uses "~" while C uses "-".
- *)
- fun float s = String.translate(s,
- fn #"~" => "-" | c => String.fromChar c)
-
- fun string s
- = let val quote = "\""
- in concat[quote, String.escapeC s, quote]
- end
end
open x86
@@ -119,6 +88,7 @@
intInfs,
main,
maxFrameSize,
+ profileAllocLabels,
strings,
...}: Machine.Program.t,
includes: string list,
@@ -136,6 +106,68 @@
| Control.FreeBSD => false
| Control.Linux => false
+ val numProfileAllocLabels =
+ (* Add 1 for PROFILE_ALLOC_MISC *)
+ 1 + Vector.length profileAllocLabels
+ val declareProfileAllocLabels =
+ if !Control.profile <> Control.ProfileAlloc
+ then fn _ => ()
+ else
+ let
+ val profileLabels =
+ Array.tabulate (numProfileAllocLabels, fn _ => NONE)
+ val labelSet: {done: bool ref,
+ hash: word,
+ index: int,
+ name: string} HashSet.t =
+ HashSet.new {hash = #hash}
+ val _ =
+ Vector.foreachi (profileAllocLabels, fn (i, name) =>
+ let
+ val hash = String.hash name
+ in
+ HashSet.lookupOrInsert
+ (labelSet, hash, fn _ => false,
+ fn () => {done = ref false,
+ hash = hash,
+ index = i + 1,
+ name = name})
+ ; ()
+ end)
+ fun addProfileLabel (name: string, label: Label.t) =
+ case HashSet.peek (labelSet, String.hash name,
+ fn {name = n, ...} => n = name) of
+ NONE => ()
+ | SOME {done, index, ...} =>
+ if !done
+ then ()
+ else (done := true
+ ; Array.update (profileLabels, index,
+ SOME label))
+ val _ = x86.setAddProfileLabel addProfileLabel
+ fun declareLabels print =
+ let
+ val _ = print ".data\n\
+ \.p2align 4\n\
+ \.global profileAllocLabels\n\
+ \profileAllocLabels:\n"
+ val _ =
+ Array.foreach
+ (profileLabels, fn l =>
+ (print
+ (concat
+ [".long ",
+ case l of
+ NONE => "0"
+ | SOME l => Label.toString l,
+ "\n"])))
+ in
+ ()
+ end
+ in
+ declareLabels
+ end
+
val makeC = outputC
val makeS = outputS
@@ -226,12 +258,20 @@
Control.Cygwin => String.dropPrefix (mainLabel, 1)
| Control.FreeBSD => mainLabel
| Control.Linux => mainLabel
+ val (a1, a2, a3) =
+ if !Control.profile = Control.ProfileAlloc
+ then (C.bool true,
+ "&profileAllocLabels",
+ C.int numProfileAllocLabels)
+ else (C.bool false, C.int 0, C.int 0)
in
[mainLabel,
- if reserveEsp then C.truee else C.falsee]
+ if reserveEsp then C.truee else C.falsee,
+ a1, a2, a3]
end
fun rest () =
- declareFrameLayouts()
+ (declareFrameLayouts()
+ ; print "extern uint profileAllocLabels;\n")
in
CCodegen.outputDeclarations
{additionalMainArgs = additionalMainArgs,
@@ -303,9 +343,7 @@
reserveEsp = reserveEsp})
handle exn
=> (Error.bug ("x86GenerateTransfers.generateTransfers::" ^
- (case exn
- of Fail s => s
- | _ => "?")))
+ Layout.toString (Exn.layout exn)))
val allocated_assembly : Assembly.t list list
= x86AllocateRegisters.allocateRegisters
@@ -362,7 +400,9 @@
print "\n"))
fun loop' (chunks, size)
= case chunks
- of [] => done ()
+ of [] =>
+ (declareProfileAllocLabels print
+ ; done ())
| chunk::chunks
=> if (case split
of NONE => false
@@ -385,7 +425,7 @@
val outputAssembly =
Control.trace (Control.Pass, "outputAssembly") outputAssembly
in
- outputC();
- outputAssembly()
+ outputC()
+ ; outputAssembly()
end
end
1.7 +3 -0 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.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- x86-mlton-basic.fun 17 Sep 2002 05:05:37 -0000 1.6
+++ x86-mlton-basic.fun 2 Nov 2002 03:37:40 -0000 1.7
@@ -358,6 +358,9 @@
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.16 +1 -0 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.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- x86-mlton-basic.sig 30 Jul 2002 02:48:33 -0000 1.15
+++ x86-mlton-basic.sig 2 Nov 2002 03:37:40 -0000 1.16
@@ -116,6 +116,7 @@
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.29 +6 -3 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.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86-translate.fun 30 Jul 2002 02:48:33 -0000 1.28
+++ x86-translate.fun 2 Nov 2002 03:37:40 -0000 1.29
@@ -140,6 +140,8 @@
| Limit => gcState_limitContentsOperand ()
| LimitPlusSlop => gcState_limitPlusSlopContentsOperand ()
| MaxFrameSize => gcState_maxFrameSizeContentsOperand ()
+ | ProfileAllocIndex =>
+ gcState_profileAllocIndexContentsOperand ()
| SignalIsPending => gcState_signalIsPendingContentsOperand ()
| StackBottom => gcState_stackBottomContentsOperand ()
| StackLimit => gcState_stackLimitContentsOperand ()
@@ -1018,8 +1020,10 @@
end
val blocks
- = if !Control.profile
- then List.map
+ = if !Control.profile = Control.ProfileNone
+ then blocks
+ else
+ List.map
(blocks,
fn (x86.Block.T {entry, profileInfo,
statements, transfer})
@@ -1036,7 +1040,6 @@
statements = statements,
transfer = transfer}
end)
- else blocks
in
blocks
end
1.32 +23 -19 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.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- x86.fun 17 Sep 2002 05:05:37 -0000 1.31
+++ x86.fun 2 Nov 2002 03:37:40 -0000 1.32
@@ -3712,6 +3712,11 @@
| _ => false
end
+ val addProfileLabel: (string * Label.t -> unit) ref =
+ ref (fn _ => ())
+
+ fun setAddProfileLabel x = addProfileLabel := x
+
structure ProfileInfo =
struct
datatype t
@@ -3739,25 +3744,24 @@
val profileHeader = "MLtonProfile"
val unique = Counter.new 0
fun profile_assembly (T {zero, one, two})
- = if !Control.profile
- then let
- val profileHeader
- = profileHeader ^ (Int.toString (Counter.next unique))
-
- val profileString
- = concat
- [profileHeader,
- "$$0.", zero,
- "$$1.", one,
- "$$2.", two]
-
- val profileBegin = profileString ^ "$$Begin"
- val profileBeginLabel = Label.fromString profileBegin
- in
- [Assembly.pseudoop_local profileBeginLabel,
- Assembly.label profileBeginLabel]
- end
- else []
+ = if !Control.profile = Control.ProfileNone
+ then []
+ else
+ let
+ val profileHeader =
+ profileHeader ^ (Int.toString (Counter.next unique))
+ val profileString =
+ concat [profileHeader,
+ "$$0.", zero,
+ "$$1.", one,
+ "$$2.", two]
+ val profileBegin = profileString ^ "$$Begin"
+ val profileBeginLabel = Label.fromString profileBegin
+ val _ = !addProfileLabel (one, profileBeginLabel)
+ in
+ [Assembly.pseudoop_global profileBeginLabel,
+ Assembly.label profileBeginLabel]
+ end
fun combine (T {zero = zero1,
one = one1,
1.21 +2 -0 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.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- x86.sig 12 Jul 2002 18:53:17 -0000 1.20
+++ x86.sig 2 Nov 2002 03:37:40 -0000 1.21
@@ -18,6 +18,8 @@
sig
include X86_STRUCTS
+ val setAddProfileLabel: (string * Label.t -> unit) -> unit
+
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
val tracerTop : string -> ('a -> 'b) ->
1.54 +2 -3 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- control.sig 23 Sep 2002 22:51:20 -0000 1.53
+++ control.sig 2 Nov 2002 03:37:40 -0000 1.54
@@ -75,8 +75,6 @@
val layoutInline: inline -> Layout.t
val setInlineSize: int -> unit
- val inlineArrayAllocation: bool ref
-
(* The input file on the command line, minus path and extension *)
val inputFile: File.t ref
@@ -182,7 +180,8 @@
val printAtFunEntry: bool ref
(* Insert profiling information. *)
- val profile: bool ref
+ datatype profile = ProfileNone | ProfileAlloc | ProfileTime
+ val profile: profile ref
(* Array bounds checking. *)
val safe: bool ref
1.68 +14 -7 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -r1.67 -r1.68
--- control.sml 29 Oct 2002 21:03:22 -0000 1.67
+++ control.sml 2 Nov 2002 03:37:40 -0000 1.68
@@ -160,11 +160,6 @@
| Leaf _ => Leaf {size = SOME size}
| LeafNoLoop _ => LeafNoLoop {size = SOME size})
-val inlineArrayAllocation =
- control {name = "inline array allocation",
- default = false,
- toString = Bool.toString}
-
val inputFile = control {name = "input file",
default = "<bogus>",
toString = File.toString}
@@ -313,9 +308,21 @@
default = false,
toString = Bool.toString}
+structure Profile =
+ struct
+ datatype t = ProfileNone | ProfileAlloc | ProfileTime
+
+ val toString =
+ fn ProfileNone => "None"
+ | ProfileAlloc => "Alloc"
+ | ProfileTime => "Time"
+ end
+
+datatype profile = datatype Profile.t
+
val profile = control {name = "profile",
- default = false,
- toString = Bool.toString}
+ default = ProfileNone,
+ toString = Profile.toString}
val safe = control {name = "safe",
default = true,
1.14 +1 -0 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.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- lookup-constant.fun 24 Aug 2002 21:41:17 -0000 1.13
+++ lookup-constant.fun 2 Nov 2002 03:37:40 -0000 1.14
@@ -126,6 +126,7 @@
"limit",
"limitPlusSlop",
"maxFrameSize",
+ "profileAllocIndex",
"signalIsPending",
"stackBottom",
"stackLimit",
1.37 +3 -1 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- compile.sml 31 Oct 2002 19:30:12 -0000 1.36
+++ compile.sml 2 Nov 2002 03:37:40 -0000 1.37
@@ -306,7 +306,8 @@
[("Exn_keepHistory", Bool (!exnHistory)),
("MLton_detectOverflow", Bool (!detectOverflow)),
("MLton_native", Bool (!Native.native)),
- ("MLton_profile", Bool (!profile)),
+ ("MLton_profile_alloc", Bool (!profile = ProfileAlloc)),
+ ("MLton_profile_time", Bool (!profile = ProfileTime)),
("MLton_safe", Bool (!safe)),
("TextIO_bufSize", Int (!textIOBufSize))]
end
@@ -335,6 +336,7 @@
limit = get "limit",
limitPlusSlop = get "limitPlusSlop",
maxFrameSize = get "maxFrameSize",
+ profileAllocIndex = get "profileAllocIndex",
signalIsPending = get "signalIsPending",
stackBottom = get "stackBottom",
stackLimit = get "stackLimit",
1.87 +34 -51 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.86
retrieving revision 1.87
diff -u -r1.86 -r1.87
--- main.sml 31 Oct 2002 22:50:50 -0000 1.86
+++ main.sml 2 Nov 2002 03:37:40 -0000 1.87
@@ -48,18 +48,6 @@
val showBasis: bool ref = ref false
val stop = ref Place.OUT
-val usageRef: (string -> unit) option ref = ref NONE
-
-fun usage (s: string): 'a =
- (valOf (!usageRef) s
- ; let open OS.Process
- in if MLton.isMLton
- then exit failure
- else raise Fail "failure"
- end)
-
-datatype optionStyle = Normal | Expert
-
val libRef: Dir.t option ref = ref NONE
fun getLib (): Dir.t =
case !libRef of
@@ -82,11 +70,14 @@
| _ => Error.bug (concat ["strange hostType: ", hostType]))}
| _ => Error.bug (concat ["strange host mapping: ", line])))
-fun options () =
+fun makeOptions {usage} =
let
+ val usage = fn s => (usage s; raise Fail "unreachable")
open Control Popt
fun push r = String (fn s => List.push (r, s))
- in [
+ in List.map
+ (
+ [
(Expert, "build-constants", "",
"output C file that prints basis constants",
trueRef buildConstants),
@@ -228,9 +219,15 @@
SpaceString (fn s => output := SOME s)),
(Expert, "O", "digit", "gcc optimization level",
Digit (fn d => optimization := d)),
- (Normal, "profile", " {false|true}",
+ (Normal, "profile", " {no|alloc|time}",
"produce executable suitable for profiling",
- Bool (fn b => if b then (profile := true; keepSSA := true) else ())),
+ SpaceString
+ (fn s =>
+ case s of
+ "no" => profile := ProfileNone
+ | "alloc" => (profile := ProfileAlloc; keepSSA := true)
+ | "time" => (profile := ProfileTime; keepSSA := true)
+ | _ => usage (concat ["invalid -profile arg: ", s]))),
(Expert, "print-at-fun-entry", " {false|true}",
"print debugging message at every call",
boolRef printAtFunEntry),
@@ -276,39 +273,24 @@
| "2" => Pass
| "3" => Detail
| _ => usage (concat ["invalid -v arg: ", s]))))
- ]
+ ],
+ fn (style, name, arg, desc, opt) =>
+ {arg = arg, desc = desc, name = name, opt = opt, style = style})
end
-val _ =
- usageRef :=
- SOME
- (fn s =>
- let
- fun message s = Out.output (Out.error, s)
- val opts =
- List.fold
- (rev (options ()), [], fn ((style, opt, arg, desc, _), rest) =>
- if style = Normal
- orelse let open Control
- in !verbosity <> Silent
- end
- then [concat [" -", opt, arg, " "], desc] :: rest
- else rest)
- val table =
- let open Justify
- in table {justs = [Left, Left],
- rows = opts}
- end
- in
- message s
- ; (message
- "\nusage: mlton [option ...] file.{cm|sml|c|o} [file.{S|o} ...] [library ...]\n")
- ; List.foreach (table, fn ss =>
- message (concat [String.removeTrailing
- (concat ss, Char.isSpace),
- "\n"]))
- end)
+fun showExpert () = let open Control
+ in !verbosity <> Silent
+ end
+val mainUsage =
+ "mlton [option ...] file.{cm|sml|c|o} [file.{S|o} ...] [library ...]"
+
+val {parse, usage} =
+ Popt.makeUsage {mainUsage = mainUsage,
+ makeOptions = makeOptions,
+ showExpert = showExpert}
+val usage = fn s => (usage s; raise Fail "unreachable")
+
fun commandLine (args: string list): unit =
let
open Control
@@ -330,9 +312,7 @@
end
| _ => error ()
val _ = libRef := SOME lib
- val result =
- Popt.parse {switches = args,
- opts = List.map (options (), fn (_, a, _, _, c) => (a, c))}
+ val result = parse args
val host = !host
val hostString =
case host of
@@ -358,14 +338,17 @@
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"
+ else ()
val _ =
if !keepDot andalso List.isEmpty (!keepPasses)
then keepSSA := true
else ()
val _ =
case !hostType of
- Cygwin => if !profile
- then usage "-profile true not allowed on Cygwin"
+ Cygwin => if !profile = ProfileTime
+ then usage "-profile time not allowed on Cygwin"
else ()
| FreeBSD => ()
| Linux => ()
1.2 +9 -3 mlton/mlyacc/mlyacc-stubs.cm
Index: mlyacc-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc-stubs.cm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- mlyacc-stubs.cm 16 Apr 2002 13:17:40 -0000 1.1
+++ mlyacc-stubs.cm 2 Nov 2002 03:37:40 -0000 1.2
@@ -26,6 +26,7 @@
src/yacc.sml
src/absyn.sml
src/link.sml
+../lib/mlton-stubs/real.sml
../lib/mlton/pervasive/pervasive.sml
../lib/mlton/basic/dynamic-wind.sig
../lib/mlton/basic/dynamic-wind.sml
@@ -40,22 +41,25 @@
../lib/mlton/basic/result.sig
../lib/mlton/basic/result.sml
../lib/mlton-stubs/thread.sml
+../lib/mlton-stubs/random.sig
+../lib/mlton-stubs/random.sml
../lib/mlton-stubs/world.sig
../lib/mlton-stubs/word.sig
../lib/mlton-stubs/vector.sig
../lib/mlton-stubs/thread.sig
+../lib/mlton-stubs/io.sig
../lib/mlton-stubs/text-io.sig
../lib/mlton-stubs/syslog.sig
../lib/mlton-stubs/socket.sig
../lib/mlton-stubs/signal.sig
../lib/mlton-stubs/rusage.sig
../lib/mlton-stubs/rlimit.sig
-../lib/mlton-stubs/random.sig
../lib/mlton-stubs/ptrace.sig
../lib/mlton-stubs/profile.sig
../lib/mlton-stubs/process.sig
../lib/mlton-stubs/proc-env.sig
../lib/mlton-stubs/array.sig
+../lib/mlton-stubs/bin-io.sig
../lib/mlton-stubs/cont.sig
../lib/mlton-stubs/exn.sig
../lib/mlton-stubs/gc.sig
@@ -121,6 +125,8 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/char.sig
../lib/mlton/basic/char.sml
../lib/mlton/basic/vector.sig
@@ -152,12 +158,12 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
../lib/mlton/basic/process.sml
+../lib/mlton/basic/justify.sig
+../lib/mlton/basic/justify.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
main.sml
1.4 +4 -2 mlton/mlyacc/mlyacc.cm
Index: mlyacc.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlyacc/mlyacc.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- mlyacc.cm 18 Feb 2002 01:11:32 -0000 1.3
+++ mlyacc.cm 2 Nov 2002 03:37:40 -0000 1.4
@@ -97,6 +97,8 @@
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/char.sig
../lib/mlton/basic/char.sml
../lib/mlton/basic/vector.sig
@@ -128,12 +130,12 @@
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/dir.sig
../lib/mlton/basic/dir.sml
../lib/mlton/basic/process.sig
../lib/mlton/basic/process.sml
+../lib/mlton/basic/justify.sig
+../lib/mlton/basic/justify.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
main.sml
1.2 +310 -0 mlton/regression/real.fromLargeInt.ok
1.2 +15 -0 mlton/regression/real.fromLargeInt.sml
1.2 +2 -0 mlton/regression/real.split.ok
1.2 +5 -0 mlton/regression/real.split.sml
1.2 +32 -0 mlton/regression/real.toFromLargeInt.ok
1.2 +44 -0 mlton/regression/real.toFromLargeInt.sml
1.2 +176 -0 mlton/regression/real.toLargeInt.ok
1.2 +26 -0 mlton/regression/real.toLargeInt.sml
1.2 +18 -0 mlton/regression/real8.ok
1.2 +17 -0 mlton/regression/real8.sml
1.8 +29 -26 mlton/runtime/IntInf.h
Index: IntInf.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/IntInf.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- IntInf.h 1 Oct 2002 22:35:06 -0000 1.7
+++ IntInf.h 2 Nov 2002 03:37:41 -0000 1.8
@@ -51,34 +51,37 @@
/* All of these routines modify the frontier in gcState. They assume that
* there are bytes bytes free, and allocate an array to store the result
* at the current frontier position.
+ * Immediately after the bytesArg, they take a labelIndex arg. This is an index
+ * into the array used for allocation profiling, and the appropriate element
+ * is incremented by the amount that the function moves the frontier.
*/
-extern pointer IntInf_do_add(pointer lhs,
- pointer rhs,
- uint bytes),
- IntInf_do_sub(pointer lhs,
- pointer rhs,
- uint bytes),
- IntInf_do_mul(pointer lhs,
- pointer rhs,
- uint bytes),
- IntInf_do_toString(pointer arg,
- int base,
- uint bytes),
- IntInf_do_neg(pointer arg,
- uint bytes),
- IntInf_do_quot(pointer num,
- pointer den,
- uint bytes),
- IntInf_do_rem(pointer num,
- pointer den,
- uint bytes),
- IntInf_do_gcd(pointer lhs,
- pointer rhs,
- uint bytes);
+extern pointer IntInf_do_add (pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_sub (pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_mul (pointer lhs,
+ pointer rhs,
+ uint bytes),
+ IntInf_do_toString (pointer arg,
+ int base,
+ uint bytes),
+ IntInf_do_neg (pointer arg,
+ uint bytes),
+ IntInf_do_quot (pointer num,
+ pointer den,
+ uint bytes),
+ IntInf_do_rem (pointer num,
+ pointer den,
+ uint bytes),
+ IntInf_do_gcd (pointer lhs,
+ pointer rhs,
+ uint bytes);
-extern Word IntInf_smallMul(Word lhs, Word rhs, pointer carry);
-extern int IntInf_compare(pointer lhs, pointer rhs),
- IntInf_equal(pointer lhs, pointer rhs);
+extern Word IntInf_smallMul (Word lhs, Word rhs, pointer carry);
+extern int IntInf_compare (pointer lhs, pointer rhs),
+ IntInf_equal (pointer lhs, pointer rhs);
#endif /* #ifndef _MLTON_INT_INF_H */
1.36 +4 -2 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- Makefile 31 Oct 2002 16:32:46 -0000 1.35
+++ Makefile 2 Nov 2002 03:37:41 -0000 1.36
@@ -32,7 +32,8 @@
basis/MLton/bug.o \
basis/MLton/errno.o \
basis/MLton/exit.o \
- basis/MLton/profile.o \
+ basis/MLton/profile-alloc.o \
+ basis/MLton/profile-time.o \
basis/MLton/rlimit.o \
basis/MLton/rusage.o \
basis/MLton/spawne.o \
@@ -180,7 +181,8 @@
basis/MLton/bug-gdb.o \
basis/MLton/errno-gdb.o \
basis/MLton/exit-gdb.o \
- basis/MLton/profile-gdb.o \
+ basis/MLton/profile-alloc.o \
+ basis/MLton/profile-time-gdb.o \
basis/MLton/rlimit-gdb.o \
basis/MLton/rusage-gdb.o \
basis/MLton/spawne-gdb.o \
1.100 +50 -5 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.99
retrieving revision 1.100
diff -u -r1.99 -r1.100
--- gc.c 1 Oct 2002 22:35:06 -0000 1.99
+++ gc.c 2 Nov 2002 03:37:41 -0000 1.100
@@ -62,12 +62,14 @@
DEBUG_GENERATIONAL = FALSE,
DEBUG_MARK_COMPACT = FALSE,
DEBUG_MEM = FALSE,
+ DEBUG_PROFILE_ALLOC = FALSE,
DEBUG_RESIZING = FALSE,
DEBUG_SIGNALS = FALSE,
DEBUG_STACKS = FALSE,
DEBUG_THREADS = FALSE,
FORWARDED = 0xFFFFFFFF,
HEADER_SIZE = WORD_SIZE,
+ PROFILE_ALLOC_MISC = 0,
STACK_HEADER_SIZE = WORD_SIZE,
};
@@ -629,6 +631,22 @@
}
#endif
+static inline void setFrontier (GC_state s, pointer p) {
+ s->frontier = p;
+}
+
+/* Pre: s->profileAllocIndex is set. */
+void GC_incProfileAlloc (GC_state s, W32 amount) {
+ if (s->profileAllocIsOn) {
+ if (DEBUG_PROFILE_ALLOC)
+ fprintf (stderr, "GC_IncProfileAlloc (%u, %u)\n",
+ s->profileAllocIndex,
+ (uint)amount);
+ s->profileAllocCounts[s->profileAllocIndex] += amount;
+ }
+}
+
+/* Pre: s->profileAllocIndex is set. */
static pointer object (GC_state s, uint header, W32 bytesRequested,
bool allocInOldGen) {
pointer frontier;
@@ -646,6 +664,7 @@
if (allocInOldGen) {
frontier = s->heap.start + s->oldGenSize;
s->oldGenSize += bytesRequested;
+ s->bytesAllocated += bytesRequested;
} else {
if (DEBUG_DETAILED)
fprintf (stderr, "frontier changed from 0x%08x to 0x%08x\n",
@@ -654,11 +673,13 @@
frontier = s->frontier;
s->frontier += bytesRequested;
}
+ GC_incProfileAlloc (s, bytesRequested);
*(uint*)(frontier) = header;
result = frontier + HEADER_SIZE;
return result;
}
+/* Pre: s->profileAllocIndex is set. */
static GC_stack newStack (GC_state s, uint size, bool allocInOldGen) {
GC_stack stack;
@@ -1190,7 +1211,7 @@
}
}
-static void setLimit (GC_state s) {
+static inline void setLimit (GC_state s) {
s->limitPlusSlop = s->nursery + s->nurserySize;
s->limit = s->limitPlusSlop - LIMIT_SLOP;
}
@@ -1236,7 +1257,7 @@
s->canMinor = FALSE;
}
s->nursery = h->start + h->size - s->nurserySize;
- s->frontier = s->nursery;
+ setFrontier (s, s->nursery);
setLimit (s);
assert (isAligned (s->nurserySize, WORD_SIZE));
assert (isAligned ((uint)s->nursery, WORD_SIZE));
@@ -2395,6 +2416,7 @@
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;
@@ -2596,6 +2618,7 @@
return ((w + 3) & ~ 3);
}
+/* Pre: s->profileAllocIndex is set. */
pointer GC_arrayAllocate (GC_state s, W32 ensureBytesFree, W32 numElts,
W32 header) {
uint numPointers;
@@ -2631,6 +2654,7 @@
frontier = (W32*)(s->heap.start + s->oldGenSize);
last = (W32*)((pointer)frontier + arraySize);
s->oldGenSize += arraySize;
+ s->bytesAllocated += arraySize;
} else {
W32 require;
@@ -2651,6 +2675,7 @@
if (1 == numPointers)
for ( ; frontier < last; frontier++)
*frontier = BOGUS_POINTER;
+ GC_incProfileAlloc (s, arraySize);
if (DEBUG_ARRAY) {
fprintf (stderr, "GC_arrayAllocate done. res = 0x%x frontier = 0x%x\n",
(uint)res, (uint)s->frontier);
@@ -2676,6 +2701,7 @@
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;
@@ -2692,6 +2718,7 @@
return t;
}
+/* Pre: s->profileAllocIndex is set. */
static GC_thread copyThread (GC_state s, GC_thread from, uint size) {
GC_thread to;
@@ -2715,6 +2742,7 @@
return to;
}
+/* Pre: s->profileAllocIndex is set. */
void GC_copyCurrentThread (GC_state s) {
GC_thread t;
GC_thread res;
@@ -2731,6 +2759,7 @@
s->savedThread = res;
}
+/* Pre: s->profileAllocIndex is set. */
pointer GC_copyThread (GC_state s, pointer thread) {
GC_thread res;
GC_thread t;
@@ -3044,6 +3073,8 @@
frontier = (pointer)&bp->limbs[alen];
}
s->frontier = frontier;
+ GC_incProfileAlloc (s, frontier - s->frontier);
+ s->bytesAllocated += frontier - s->frontier;
}
static void initStrings (GC_state s) {
@@ -3083,10 +3114,12 @@
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;
}
-static void newWorld (GC_state s)
-{
+/* Pre: s->profileAllocIndex is set. */
+static void newWorld (GC_state s) {
int i;
assert (isAligned (sizeof (struct GC_thread), WORD_SIZE));
@@ -3096,7 +3129,7 @@
heapCreate (s, &s->heap, heapDesiredSize (s, s->bytesLive, 0),
s->bytesLive);
createCardMapAndCrossMap (s);
- s->frontier = s->heap.start;
+ setFrontier (s, s->heap.start);
initIntInfs (s);
initStrings (s);
assert (s->frontier - s->heap.start <= s->bytesLive);
@@ -3198,6 +3231,18 @@
worldFile = NULL;
unless (isAligned (s->pageSize, s->cardSize))
die ("page size must be a multiple of card size");
+ if (s->profileAllocIsOn) {
+ s->profileAllocIndex = PROFILE_ALLOC_MISC;
+ MLton_ProfileAlloc_setCurrent
+ (MLton_ProfileAlloc_Data_malloc ());
+ if (DEBUG_PROFILE_ALLOC) {
+ fprintf (stderr, "s->profileAllocLabels = 0x%08x\n",
+ (uint)s->profileAllocLabels);
+ for (i = 0; i < s->profileAllocNumLabels; ++i)
+ fprintf (stderr, "profileAllocLabels[%d] = 0x%08x\n",
+ i, s->profileAllocLabels[i]);
+ }
+ }
i = 1;
if (argc > 1 and (0 == strcmp (argv [1], "@MLton"))) {
bool done;
1.44 +9 -3 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- gc.h 19 Sep 2002 18:49:22 -0000 1.43
+++ gc.h 2 Nov 2002 03:37:41 -0000 1.44
@@ -268,7 +268,7 @@
float liveRatio; /* Desired ratio of heap size to live data. */
/* loadGlobals loads the globals from the stream. */
void (*loadGlobals)(FILE *file);
- uint magic; /* The magic number required for a valid world file. */
+ uint magic; /* The magic number for this executable. */
/* Minimum live ratio to us mark-compact GC. */
float markCompactRatio;
ullong markedCards; /* Number of marked cards seen during minor GCs. */
@@ -312,6 +312,11 @@
W32 oldGenArraySize;
uint oldGenSize;
uint pageSize; /* bytes */
+ ullong *profileAllocCounts; /* allocation profiling */
+ uint profileAllocIndex;
+ bool profileAllocIsOn;
+ uint *profileAllocLabels;
+ uint profileAllocNumLabels;
W32 ram; /* ramSlop * totalRam */
float ramSlop;
struct rusage ru_gc; /* total resource usage spent in gc */
@@ -381,8 +386,7 @@
/* Allocate an array with the specified header and number of elements.
* Also ensure that frontier + bytesNeeded < limit after the array is allocated.
*/
-pointer GC_arrayAllocate (GC_state s, W32 bytesNeeded, W32 numElts,
- W32 header);
+pointer GC_arrayAllocate (GC_state s, W32 bytesNeeded, W32 numElts, W32 header);
/* The array size is stored before the header */
static inline uint* GC_arrayNumElementsp (pointer a) {
@@ -444,6 +448,8 @@
* This, in turn, will cause the GC to run the SML signal handler.
*/
void GC_handler (GC_state s, int signum);
+
+void GC_incProfileAlloc (GC_state s, W32 amount);
/* GC_init must be called before doing any allocation.
* It processes command line arguments, creates the heap, initializes the global
1.17 +22 -5 mlton/runtime/mlton-basis.h
Index: mlton-basis.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-basis.h,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- mlton-basis.h 29 Sep 2002 02:23:59 -0000 1.16
+++ mlton-basis.h 2 Nov 2002 03:37:41 -0000 1.17
@@ -128,11 +128,28 @@
void MLton_exit (Int status);
Word MLton_random ();
Word MLton_size (Pointer p);
-Pointer MLton_Profile_Data_malloc (void);
-void MLton_Profile_Data_reset (Pointer data);
-void MLton_Profile_Data_write (Pointer data, Cstring name);
-void MLton_Profile_init (void);
-void MLton_Profile_installHandler (void);
+
+enum {
+ MLPROF_KIND_ALLOC = 0,
+ MLPROF_KIND_TIME = 1,
+};
+
+void MLton_ProfileAlloc_Data_free (Pointer d);
+Pointer MLton_ProfileAlloc_Data_malloc (void);
+void MLton_ProfileAlloc_Data_reset (Pointer d);
+void MLton_ProfileAlloc_Data_write (Pointer d, Word fd);
+Pointer MLton_ProfileAlloc_current (void);
+void MLton_ProfileAlloc_inc (Word amount);
+void MLton_ProfileAlloc_setCurrent (Pointer d);
+
+void MLton_ProfileTime_Data_free (Pointer d);
+Pointer MLton_ProfileTime_Data_malloc (void);
+void MLton_ProfileTime_Data_reset (Pointer data);
+void MLton_ProfileTime_Data_write (Pointer data, Cstring name);
+Pointer MLton_ProfileTime_current (void);
+void MLton_ProfileTime_init (void);
+void MLton_ProfileTime_setCurrent (Pointer d);
+
#if (defined (__CYGWIN__))
Int MLton_Process_spawne (NullString p, Pointer a, Pointer e);
Int MLton_Process_spawnp (NullString p, Pointer a);
1.17 +9 -5 mlton/runtime/my-lib.c
Index: my-lib.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/my-lib.c,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- my-lib.c 16 Sep 2002 18:46:26 -0000 1.16
+++ my-lib.c 2 Nov 2002 03:37:41 -0000 1.17
@@ -65,14 +65,18 @@
}
/* safe version of write */
-void swrite(int fd, const void *buf, size_t count) {
+void swrite (int fd, const void *buf, size_t count) {
if (0 == count) return;
- unless (count == write(fd, buf, count))
- diee("swrite failed");
+ unless (count == write (fd, buf, count))
+ diee ("swrite failed");
}
-void swriteUint(int fd, uint n) {
- swrite(fd, &n, sizeof(uint));
+void swriteUint (int fd, uint n) {
+ swrite (fd, &n, sizeof(uint));
+}
+
+void swriteUllong (int fd, ullong n) {
+ swrite (fd, &n, sizeof(ullong));
}
/* safe version of fclose */
1.7 +3 -2 mlton/runtime/my-lib.h
Index: my-lib.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/my-lib.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- my-lib.h 20 Aug 2002 04:48:08 -0000 1.6
+++ my-lib.h 2 Nov 2002 03:37:41 -0000 1.7
@@ -65,8 +65,9 @@
/* safe version of close, mkstemp, write */
int smkstemp (char *template);
void sclose (int fd);
-void swrite(int fd, const void *buf, size_t count);
-void swriteUint(int fd, uint n);
+void swrite (int fd, const void *buf, size_t count);
+void swriteUint (int fd, uint n);
+void swriteUllong (int fd, ullong n);
/* safe versions of fopen, fread, fwrite */
void sfclose (FILE *file);
1.9 +50 -82 mlton/runtime/basis/IntInf.c
Index: IntInf.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/IntInf.c,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- IntInf.c 1 Oct 2002 22:35:07 -0000 1.8
+++ IntInf.c 2 Nov 2002 03:37:42 -0000 1.9
@@ -25,23 +25,17 @@
char chars[0]; /* actual chars */
} strng;
-
/*
* Test if a intInf is a fixnum.
*/
-static inline uint
-isSmall(pointer arg)
-{
+static inline uint isSmall (pointer arg) {
return ((uint)arg & 1);
}
-
/*
* Convert a bignum intInf to a bignum pointer.
*/
-static inline bignum *
-toBignum(pointer arg)
-{
+static inline bignum * toBignum (pointer arg) {
bignum *bp;
assert(not isSmall(arg));
@@ -50,14 +44,11 @@
return (bp);
}
-
/*
* Given an intInf, a pointer to an __mpz_struct and something large enough
* to contain 2 limbs, fill in the __mpz_struct.
*/
-static inline void
-fill(pointer arg, __mpz_struct *res, mp_limb_t space[2])
-{
+static inline void fill (pointer arg, __mpz_struct *res, mp_limb_t space[2]) {
bignum *bp;
if (isSmall(arg)) {
@@ -83,12 +74,10 @@
/*
* Initialize an __mpz_struct to use the space provided by an ML array.
*/
-static inline void
-initRes(__mpz_struct *mpzp, uint bytes)
-{
+static inline void initRes (__mpz_struct *mpzp, uint bytes) {
struct bignum *bp;
- assert(bytes <= gcState.limitPlusSlop - gcState.frontier);
+ assert (bytes <= gcState.limitPlusSlop - gcState.frontier);
bp = (bignum*)gcState.frontier;
/* We have as much space for the limbs as there is to the end of the
* heap. Divide by 4 to get number of words.
@@ -102,9 +91,7 @@
* Count number of leading zeros. The argument will not be zero.
* This MUST be replaced with assembler.
*/
-static inline uint
-leadingZeros(mp_limb_t word)
-{
+static inline uint leadingZeros (mp_limb_t word) {
uint res;
assert(word != 0);
@@ -116,6 +103,11 @@
return (res);
}
+static inline void setFrontier (pointer p) {
+ GC_incProfileAlloc (&gcState, p - gcState.frontier);
+ gcState.frontier = p;
+ assert (gcState.frontier <= gcState.limitPlusSlop);
+}
/*
* Given an __mpz_struct pointer which reflects the answer, set gcState.frontier
@@ -125,9 +117,7 @@
* If the answer doesn't need all of the space allocated, we adjust
* the array size and roll the frontier slightly back.
*/
-static pointer
-answer(__mpz_struct *ans)
-{
+static pointer answer (__mpz_struct *ans) {
bignum *bp;
int size;
@@ -162,56 +152,47 @@
return (pointer)(ans<<1 | 1);
}
}
- gcState.frontier = (pointer)&bp->limbs[size];
- assert(gcState.frontier <= gcState.limitPlusSlop);
+ setFrontier ((pointer)&bp->limbs[size]);
bp->counter = 0;
bp->card = size + 1; /* +1 for isNeg word */
bp->magic = BIGMAGIC;
return (pointer)&bp->isneg;
}
-static pointer
-binary(pointer lhs, pointer rhs, uint bytes,
- void(*binop)(__mpz_struct *resmpz,
- __gmp_const __mpz_struct *lhsspace,
- __gmp_const __mpz_struct *rhsspace))
-{
+static pointer binary (pointer lhs, pointer rhs, uint bytes,
+ void(*binop)(__mpz_struct *resmpz,
+ __gmp_const __mpz_struct *lhsspace,
+ __gmp_const __mpz_struct *rhsspace)) {
__mpz_struct lhsmpz,
rhsmpz,
resmpz;
mp_limb_t lhsspace[2],
rhsspace[2];
- initRes(&resmpz, bytes);
- fill(lhs, &lhsmpz, lhsspace);
- fill(rhs, &rhsmpz, rhsspace);
- binop(&resmpz, &lhsmpz, &rhsmpz);
- return answer(&resmpz);
+ initRes (&resmpz, bytes);
+ fill (lhs, &lhsmpz, lhsspace);
+ fill (rhs, &rhsmpz, rhsspace);
+ binop (&resmpz, &lhsmpz, &rhsmpz);
+ return answer (&resmpz);
}
-pointer IntInf_do_add(pointer lhs, pointer rhs, uint bytes)
-{
- return binary(lhs, rhs, bytes, &mpz_add);
+pointer IntInf_do_add (pointer lhs, pointer rhs, uint bytes) {
+ return binary (lhs, rhs, bytes, &mpz_add);
}
-pointer IntInf_do_gcd(pointer lhs, pointer rhs, uint bytes)
-{
- return binary(lhs, rhs, bytes, &mpz_gcd);
+pointer IntInf_do_gcd (pointer lhs, pointer rhs, uint bytes) {
+ return binary (lhs, rhs, bytes, &mpz_gcd);
}
-pointer IntInf_do_mul(pointer lhs, pointer rhs, uint bytes)
-{
- return binary(lhs, rhs, bytes, &mpz_mul);
+pointer IntInf_do_mul (pointer lhs, pointer rhs, uint bytes) {
+ return binary (lhs, rhs, bytes, &mpz_mul);
}
-pointer IntInf_do_sub(pointer lhs, pointer rhs, uint bytes)
-{
- return binary(lhs, rhs, bytes, &mpz_sub);
+pointer IntInf_do_sub (pointer lhs, pointer rhs, uint bytes) {
+ return binary (lhs, rhs, bytes, &mpz_sub);
}
-Word
-IntInf_smallMul(Word lhs, Word rhs, pointer carry)
-{
+Word IntInf_smallMul (Word lhs, Word rhs, pointer carry) {
llong prod;
prod = (llong)(int)lhs * (int)rhs;
@@ -223,9 +204,7 @@
* Return an integer which compares to 0 as the two intInf args compare
* to each other.
*/
-int
-IntInf_compare(pointer lhs, pointer rhs)
-{
+int IntInf_compare (pointer lhs, pointer rhs) {
__mpz_struct lhsmpz,
rhsmpz;
mp_limb_t lhsspace[2],
@@ -236,41 +215,37 @@
return (mpz_cmp(&lhsmpz, &rhsmpz));
}
-
/*
* Check if two IntInf.int's are equal.
* (This should be partly in ML, but the compiler won't call ML code in the
* middle of polymorphic equality.)
*/
-int IntInf_equal(pointer lhs, pointer rhs) {
- if (isSmall(lhs))
- if (isSmall(rhs))
+int IntInf_equal (pointer lhs, pointer rhs) {
+ if (isSmall (lhs))
+ if (isSmall (rhs))
return (lhs == rhs);
else
return (FALSE);
- else if (isSmall(rhs))
+ else if (isSmall (rhs))
return (FALSE);
else
- return (IntInf_compare(lhs, rhs) == 0);
+ return (IntInf_compare (lhs, rhs) == 0);
}
-
/*
* Convert an intInf to a string.
* Arg is an intInf, base is the base to use (2, 8, 10 or 16) and space is a
* string (mutable) which is large enough.
*/
-pointer
-IntInf_do_toString(pointer arg, int base, uint bytes)
-{
+pointer IntInf_do_toString (pointer arg, int base, uint bytes) {
strng *sp;
__mpz_struct argmpz;
mp_limb_t argspace[2];
char *str;
uint size;
- assert(base == 2 || base == 8 || base == 10 || base == 16);
- fill(arg, &argmpz, argspace);
+ assert (base == 2 || base == 8 || base == 10 || base == 16);
+ fill (arg, &argmpz, argspace);
sp = (strng*)gcState.frontier;
str = mpz_get_str(sp->chars, base, &argmpz);
assert(str == sp->chars);
@@ -280,22 +255,19 @@
sp->counter = 0;
sp->card = size;
sp->magic = STRMAGIC;
- gcState.frontier = &sp->chars[wordAlign(size)];
- assert(gcState.frontier <= gcState.limitPlusSlop);
+ setFrontier (&sp->chars[wordAlign(size)]);
return (pointer)str;
}
-pointer
-IntInf_do_neg(pointer arg, uint bytes)
-{
+pointer IntInf_do_neg (pointer arg, uint bytes) {
__mpz_struct argmpz,
resmpz;
mp_limb_t argspace[2];
- initRes(&resmpz, bytes);
- fill(arg, &argmpz, argspace);
- mpz_neg(&resmpz, &argmpz);
- return answer(&resmpz);
+ initRes (&resmpz, bytes);
+ fill (arg, &argmpz, argspace);
+ mpz_neg (&resmpz, &argmpz);
+ return answer (&resmpz);
}
/*
@@ -311,9 +283,7 @@
* num is the numerator bignum, den is the denominator and frontier is
* the current frontier.
*/
-pointer
-IntInf_do_quot(pointer num, pointer den, uint bytes)
-{
+pointer IntInf_do_quot (pointer num, pointer den, uint bytes) {
__mpz_struct resmpz,
nmpz,
dmpz;
@@ -382,7 +352,7 @@
resmpz._mp_d[qsize++] = carry;
}
resmpz._mp_size = resIsNeg ? - qsize : qsize;
- return answer(&resmpz);
+ return answer (&resmpz);
}
@@ -399,9 +369,7 @@
* num is the numerator bignum, den is the denominator and frontier is
* the current frontier.
*/
-pointer
-IntInf_do_rem(pointer num, pointer den, uint bytes)
-{
+pointer IntInf_do_rem (pointer num, pointer den, uint bytes) {
__mpz_struct resmpz,
nmpz,
dmpz;
@@ -474,5 +442,5 @@
}
}
resmpz._mp_size = resIsNeg ? - nsize : nsize;
- return answer(&resmpz);
+ return answer (&resmpz);
}
1.1 mlton/runtime/basis/MLton/profile-alloc.c
Index: profile-alloc.c
===================================================================
#include <signal.h>
#include <errno.h>
#include <string.h>
#include <sys/time.h>
#include <signal.h>
#include <ucontext.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include "gc.h"
#include "mlton-basis.h"
#include "my-lib.h"
extern struct GC_state gcState;
#define MAGIC "MLton prof\n"
extern void _start(void),
etext(void);
#define START ((uint)&_start)
#define END (uint)&etext
Pointer MLton_ProfileAlloc_current (void) {
return (Pointer)gcState.profileAllocCounts;
}
void MLton_ProfileAlloc_setCurrent (Pointer d) {
gcState.profileAllocCounts = (ullong*)d;
}
void MLton_ProfileAlloc_inc (Word amount) {
assert (gcState.profileAllocIsOn);
if (FALSE)
fprintf (stderr, "MLton_ProfileAlloc_inc (%u, %u)\n",
gcState.profileAllocIndex,
(uint)amount);
gcState.profileAllocCounts[gcState.profileAllocIndex] += 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.profileAllocNumLabels * sizeof (*data));
if (data == NULL)
die ("Out of memory");
MLton_ProfileAlloc_Data_reset ((Pointer)data);
return (Pointer)data;
}
void MLton_ProfileAlloc_Data_free (Pointer d) {
ullong *data;
assert (gcState.profileAllocIsOn);
data = (ullong*)d;
assert (data != NULL);
free (data);
}
void MLton_ProfileAlloc_Data_reset (Pointer d) {
uint *data;
assert (gcState.profileAllocIsOn);
data = (uint*)d;
assert (data != NULL);
memset (data, 0, gcState.profileAllocNumLabels * sizeof(*data));
}
void MLton_ProfileAlloc_Data_write (Pointer d, Word fd) {
/* Write a profile data array out to a file descriptor
* The file consists of:
* a 12 byte magic value ("MLton prof\n\000")
* the lowest address corresponding to a bin
* just past the highest address corresponding to a bin
* the counter size in bytes (4 or 8)
* the bins
*/
ullong *data;
uint i;
fprintf (stderr, "writing file\n");
assert (gcState.profileAllocIsOn);
data = (ullong*)d;
swrite (fd, MAGIC, sizeof(MAGIC));
swriteUint (fd, gcState.magic);
swriteUint (fd, START);
swriteUint (fd, END);
swriteUint (fd, sizeof(*data));
swriteUint (fd, MLPROF_KIND_ALLOC);
for (i = 0; i < gcState.profileAllocNumLabels; ++i) {
if (data[i] > 0) {
swriteUint (fd, gcState.profileAllocLabels[i]);
swriteUllong (fd, data[i]);
}
}
}
1.2 +171 -0 mlton/runtime/basis/MLton/profile-time.c
-------------------------------------------------------
This sf.net email is sponsored by: See the NEW Palm
Tungsten T handheld. Power & Color in a compact size!
http://ads.sourceforge.net/cgi-bin/redirect.pl?palm0001en
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel