[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