[MLton-devel] cvs commit: Profiling labels in x86-codegen

Matthew Fluet fluet@users.sourceforge.net
Mon, 20 Jan 2003 08:28:43 -0800


fluet       03/01/20 08:28:43

  Modified:    mlton/atoms atoms.fun atoms.sig sources.cm
               mlton/backend machine-atoms.fun machine-atoms.sig
                        machine.fun machine.sig
               mlton/codegen/x86-codegen peephole.fun peephole.sig
                        x86-codegen.fun x86-generate-transfers.fun
                        x86-generate-transfers.sig x86-liveness.fun
                        x86-liveness.sig x86-mlton-basic.sig x86-mlton.fun
                        x86-pseudo.sig x86-simplify.fun x86-simplify.sig
                        x86-translate.fun x86.fun x86.sig
               mlton/main compile.sml
  Added:       mlton/atoms profile-label.fun profile-label.sig
  Log:
  Ensure that all blocks introduced by the x86 codegen have an
  associated profile label.  This eliminates an imprecision in time
  profiling with the native codegen.  The one outstanding issue is the
  fact that empty compensation blocks are not removed when they have
  profile labels embedded.  This shouldn't be too hard to fix, and I'll
  try to do so by the end of the week.

Revision  Changes    Path
1.4       +1 -0      mlton/mlton/atoms/atoms.fun

Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- atoms.fun	10 Jan 2003 18:36:08 -0000	1.3
+++ atoms.fun	20 Jan 2003 16:28:23 -0000	1.4
@@ -14,6 +14,7 @@
 
       structure SourceInfo = SourceInfo ()
       structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
+      structure ProfileLabel = ProfileLabel ()
       structure Var = Var (structure AstId = Ast.Var)
       structure Tycon = Tycon (structure AstId = Ast.Tycon)
       structure UnaryTycon = UnaryTycon (structure Tycon = Tycon)



1.4       +1 -0      mlton/mlton/atoms/atoms.sig

Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- atoms.sig	10 Jan 2003 18:36:08 -0000	1.3
+++ atoms.sig	20 Jan 2003 16:28:23 -0000	1.4
@@ -19,6 +19,7 @@
       structure Const: CONST
       structure Prim: PRIM 
       structure ProfileExp: PROFILE_EXP
+      structure ProfileLabel: PROFILE_LABEL
       structure Record: RECORD
       structure Scheme: SCHEME
       structure SortedRecord: RECORD



1.8       +3 -0      mlton/mlton/atoms/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- sources.cm	10 Jan 2003 18:36:08 -0000	1.7
+++ sources.cm	20 Jan 2003 16:28:24 -0000	1.8
@@ -18,6 +18,7 @@
 signature HASH_TYPE
 signature PRIM
 signature PROFILE_EXP
+signature PROFILE_LABEL
 signature RECORD
 signature SCHEME
 signature SOURCE_INFO
@@ -60,6 +61,8 @@
 prim.sig
 profile-exp.fun
 profile-exp.sig
+profile-label.fun
+profile-label.sig
 scheme.sig
 source-info.fun
 source-info.sig



1.1                  mlton/mlton/atoms/profile-label.fun

Index: profile-label.fun
===================================================================
functor ProfileLabel (S: PROFILE_LABEL_STRUCTS): PROFILE_LABEL =
   struct
      datatype t = T of {plist: PropertyList.t,
			 uniq: int}

      local
	 fun make f (T r) = f r
      in
	 val plist = make #plist
	 val uniq = make #uniq
      end

      local
	 val c = Counter.new 0
      in
	 fun new () = T {plist = PropertyList.new (),
			 uniq = Counter.next c}
      end

      fun toString (T {uniq, ...}) =
	 concat ["MLtonProfile", Int.toString uniq]

      val layout = Layout.str o toString

      fun equals (l, l') = uniq l = uniq l'

      val clear = PropertyList.clear o plist
   end



1.1                  mlton/mlton/atoms/profile-label.sig

Index: profile-label.sig
===================================================================
type int = Int.t
type word = Word.t

signature PROFILE_LABEL_STRUCTS =
   sig
   end

signature PROFILE_LABEL =
   sig
      type t
	
      val clear: t -> unit
      val equals: t * t -> bool
      val layout: t -> Layout.t
      val new: unit -> t
      val plist: t -> PropertyList.t
      val toString: t -> string
   end



1.6       +0 -29     mlton/mlton/backend/machine-atoms.fun

Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- machine-atoms.fun	2 Jan 2003 17:45:14 -0000	1.5
+++ machine-atoms.fun	20 Jan 2003 16:28:26 -0000	1.6
@@ -413,35 +413,6 @@
 	  (PointerTycon.wordVector, wordVector)]
    end
 
-structure ProfileLabel =
-   struct
-      datatype t = T of {plist: PropertyList.t,
-			 uniq: int}
-
-      local
-	 fun make f (T r) = f r
-      in
-	 val plist = make #plist
-	 val uniq = make #uniq
-      end
-
-      local
-	 val c = Counter.new 0
-      in
-	 fun new () = T {plist = PropertyList.new (),
-			 uniq = Counter.next c}
-      end
-
-      fun toString (T {uniq, ...}) =
-	 concat ["MLtonProfile", Int.toString uniq]
-
-      val layout = Layout.str o toString
-
-      fun equals (l, l') = uniq l = uniq l'
-
-      val clear = PropertyList.clear o plist
-   end
-
 fun castIsOk {from: Type.t,
 	      fromInt: int option,
 	      to: Type.t,



1.6       +1 -12     mlton/mlton/backend/machine-atoms.sig

Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- machine-atoms.sig	2 Jan 2003 17:45:14 -0000	1.5
+++ machine-atoms.sig	20 Jan 2003 16:28:26 -0000	1.6
@@ -11,6 +11,7 @@
    sig
       structure Label: HASH_ID
       structure Prim: PRIM
+      structure ProfileLabel: PROFILE_LABEL
       structure Runtime: RUNTIME
       structure SourceInfo: SOURCE_INFO
    end
@@ -112,18 +113,6 @@
 	    val thread: t
 	    val toRuntime: t -> Runtime.ObjectType.t
 	    val wordVector: t
-	 end
-
-      structure ProfileLabel:
-	 sig
-	    type t
-
-	    val clear: t -> unit
-	    val equals: t * t -> bool
-	    val layout: t -> Layout.t
-	    val new: unit -> t
-	    val plist: t -> PropertyList.t
-	    val toString: t -> string
 	 end
 
       val castIsOk: {from: Type.t,



1.40      +48 -0     mlton/mlton/backend/machine.fun

Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- machine.fun	6 Jan 2003 01:15:30 -0000	1.39
+++ machine.fun	20 Jan 2003 16:28:27 -0000	1.40
@@ -21,6 +21,7 @@
 
 structure Atoms = MachineAtoms (structure Label = Label
 				structure Prim = Prim
+				structure ProfileLabel = ProfileLabel
 				structure Runtime = Runtime
 				structure SourceInfo = SourceInfo)
    
@@ -678,6 +679,53 @@
 		      (sourceSuccessors, fn i =>
 		       0 <= i andalso i < sourceSeqsLength))
 	 end
+
+       fun modify (T {frameSources, labels, sourceSeqs, sourceSuccessors, sources}) :
+	          {newProfileLabel: ProfileLabel.t -> ProfileLabel.t,
+		   delProfileLabel: ProfileLabel.t -> unit,
+		   getProfileInfo: unit -> t} =
+	  let
+	     val {get: ProfileLabel.t -> int, set, ...} =
+	        Property.getSet
+		(ProfileLabel.plist, 
+		 Property.initRaise ("ProfileInfo.extend", ProfileLabel.layout))
+	     val _ =
+	        Vector.foreach
+		(labels, fn {label, sourceSeqsIndex} =>
+		 set (label, sourceSeqsIndex))
+	     val new = ref []
+	     fun newProfileLabel l =
+	       let
+		  val i = get l
+		  val l' = ProfileLabel.new ()
+		  val _ = set (l', i)
+		  val _ = List.push (new, {label = l', sourceSeqsIndex = i})
+	       in
+		  l'
+	       end
+	     fun delProfileLabel l = set (l, ~1)
+	     fun getProfileInfo () =
+	        let
+		   val labels = Vector.concat
+		                [labels, Vector.fromList (!new)]
+		   val labels = Vector.keepAll
+		                (labels, fn {label, ...} =>
+				 get label <> ~1)
+		   val pi = T {frameSources = frameSources,
+			       labels = Vector.concat
+			                [labels, Vector.fromList (!new)],
+			       sourceSeqs = sourceSeqs,
+			       sourceSuccessors = sourceSuccessors,
+			       sources = sources}
+		in
+		  Assert.assert ("newProfileInfo", fn () => isOK pi);
+		  pi
+		end
+	  in
+	     {newProfileLabel = newProfileLabel,
+	      delProfileLabel = delProfileLabel,
+	      getProfileInfo = getProfileInfo}
+	  end
    end
 
 structure Program =



1.30      +5 -0      mlton/mlton/backend/machine.sig

Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- machine.sig	4 Jan 2003 02:00:33 -0000	1.29
+++ machine.sig	20 Jan 2003 16:28:28 -0000	1.30
@@ -12,6 +12,7 @@
    sig
       structure Label: HASH_ID
       structure Prim: PRIM
+      structure ProfileLabel: PROFILE_LABEL
       structure SourceInfo: SOURCE_INFO
    end
 
@@ -223,6 +224,10 @@
 		     sourceSeqs: int vector vector,
 		     sourceSuccessors: int vector,
 		     sources: SourceInfo.t vector}
+
+	    val modify: t -> {newProfileLabel: ProfileLabel.t -> ProfileLabel.t,
+			      delProfileLabel: ProfileLabel.t -> unit,
+			      getProfileInfo: unit -> t}
 	 end
 
       structure Program:



1.5       +13 -2     mlton/mlton/codegen/x86-codegen/peephole.fun

Index: peephole.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/peephole.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- peephole.fun	20 Dec 2002 18:29:43 -0000	1.4
+++ peephole.fun	20 Jan 2003 16:28:30 -0000	1.5
@@ -30,6 +30,7 @@
 		     transfer: transfer_element}
 	
     type match = {entry: entry_type,
+		  profileLabel: profileLabel_type,
 		  start: statement_type list,
 		  statements: statement_type list list,
 		  finish: statement_type list,
@@ -51,6 +52,7 @@
 
     type find_state = {remaining: optimization list,
 		       state: {entry: entry_type,
+			       profileLabel: profileLabel_type,
 			       start: statement_type list,
 			       finish: statement_type list,
 			       transfer: transfer_type}}
@@ -164,7 +166,7 @@
 			match_state: match_state}
       = let
 	  fun next {remaining: optimization list,
-		    state as {entry, start, finish, transfer}} : 
+		    state as {entry, profileLabel, start, finish, transfer}} : 
 	           find_state option 
 	    = (case remaining
 		 of [] => NONE
@@ -174,6 +176,7 @@
 			 | statement::finish
 			 => SOME {remaining = optimizations,
 				  state = {entry = entry,
+					   profileLabel = profileLabel,
 					   start = statement::start,
 					   finish = finish,
 					   transfer = transfer}})
@@ -192,6 +195,7 @@
 							 = template_transfer},
 					    ...}::_,
 			      state as {entry,
+					profileLabel,
 					start, 
 					finish, 
 					transfer}}) : 
@@ -202,6 +206,7 @@
 		       of SOME find_state => findMatch' find_state
 			| NONE 
 			=> Done {block = T {entry = entry,
+					    profileLabel = profileLabel,
 					    statements = List.fold(start,
 								   finish,
 								   op ::),
@@ -225,6 +230,7 @@
 			     else Continue {remaining = remaining,
 					    match 
 					    = {entry = entry,
+					       profileLabel = profileLabel,
 					       start = start,
 					       statements = statements,
 					       finish = finish,
@@ -234,11 +240,13 @@
 
 	  fun findMatch (match_state: match_state) : match_state
 	    = case match_state
-		of Start {block as T {entry, statements, transfer}}
+		of Start {block as T {entry, profileLabel, 
+				      statements, transfer}}
 		 => let
 		      val find_state
 			= {remaining = optimizations,
 			   state = {entry = entry,
+				    profileLabel = profileLabel,
 				    start = [],
 				    finish = statements,
 				    transfer = transfer}}
@@ -247,6 +255,7 @@
 		    end
 	         | Continue {remaining,
 			     match as {entry, 
+				       profileLabel,
 				       start, 
 				       statements, 
 				       finish, 
@@ -259,6 +268,7 @@
 		      val find_state
 			= {remaining = remaining,
 			   state = {entry = entry,
+				    profileLabel = profileLabel,
 				    start = start,
 				    finish = finish,
 				    transfer = transfer}}
@@ -266,6 +276,7 @@
 		      case next find_state
 			of NONE => Done {block 
 					 = T {entry = entry,
+					      profileLabel = profileLabel,
 					      statements = List.fold(start,
 								     finish,
 								     op ::),



1.5       +4 -1      mlton/mlton/codegen/x86-codegen/peephole.sig

Index: peephole.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/peephole.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- peephole.sig	20 Dec 2002 18:29:43 -0000	1.4
+++ peephole.sig	20 Jan 2003 16:28:31 -0000	1.5
@@ -11,9 +11,11 @@
 signature PEEPHOLE_TYPES =
   sig
     type entry_type
+    type profileLabel_type
     type statement_type
     type transfer_type
     datatype block = T of {entry: entry_type,
+			   profileLabel: profileLabel_type,
 			   statements: statement_type list,
 			   transfer: transfer_type}
   end
@@ -38,6 +40,7 @@
 		     transfer: transfer_element}
 	
     type match = {entry: entry_type,
+		  profileLabel: profileLabel_type,
 		  start: statement_type list,
 		  statements: statement_type list list,
 		  finish: statement_type list,
@@ -59,4 +62,4 @@
 			  optimizations: optimization list} ->
                          {blocks: block list,
 			  changed: bool}
-  end
+  end
\ No newline at end of file



1.36      +38 -11    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.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- x86-codegen.fun	20 Dec 2002 18:29:43 -0000	1.35
+++ x86-codegen.fun	20 Jan 2003 16:28:31 -0000	1.36
@@ -11,6 +11,7 @@
 
   structure x86 
     = x86(structure Label = Machine.Label
+	  structure ProfileLabel = Machine.ProfileLabel
 	  structure Runtime = Machine.Runtime)
 
   structure x86MLtonBasic
@@ -78,15 +79,7 @@
 
   open x86
   structure Type = Machine.Type
-  fun output {program as Machine.Program.T {chunks,
-					    frameLayouts,
-					    frameOffsets,
-					    handlesSignals,
-					    intInfs,
-					    main,
-					    maxFrameSize,
-					    strings,
-					    ...},
+  fun output {program as Machine.Program.T {chunks, frameLayouts, main, ...},
               includes: string list,
 	      outputC,
 	      outputS}: unit
@@ -105,9 +98,41 @@
 	val makeC = outputC
 	val makeS = outputS
 
+	val Machine.Program.T {profileInfo, ...} = program
+	val {newProfileLabel, delProfileLabel, getProfileInfo} = 
+	  Machine.ProfileInfo.modify profileInfo
+
 	(* C specific *)
 	fun outputC ()
 	  = let
+	      local
+		val Machine.Program.T 
+		    {chunks, 
+		     frameLayouts, 
+		     frameOffsets, 
+		     handlesSignals, 
+		     intInfs, 
+		     main, 
+		     maxFrameSize, 
+		     objectTypes, 
+		     reals, 
+		     strings, ...} =
+		  program
+	      in
+		val program =
+		  Machine.Program.T 
+		  {chunks = chunks, 
+		   frameLayouts = frameLayouts, 
+		   frameOffsets = frameOffsets, 
+		   handlesSignals = handlesSignals, 
+		   intInfs = intInfs,  
+		   main = main, 
+		   maxFrameSize = maxFrameSize, 
+		   objectTypes = objectTypes, 
+		   profileInfo = getProfileInfo (),
+		   reals = reals, 
+		   strings = strings} 
+	      end
 	      val {file, print, done} = makeC ()
 	      fun make (name, l, pr, last) =
 		 (print (concat ["static ", name, " = {"])
@@ -209,6 +234,7 @@
 		   optimize = if isMain
 				then 0
 				else !Control.Native.optimize,
+		   delProfileLabel = delProfileLabel,
 		   liveInfo = liveInfo,
 		   jumpInfo = jumpInfo}
 		  handle exn
@@ -221,6 +247,7 @@
 		= (x86GenerateTransfers.generateTransfers
 		   {chunk = chunk,
 		    optimize = !Control.Native.optimize,
+		    newProfileLabel = newProfileLabel,
 		    liveInfo = liveInfo,
 		    jumpInfo = jumpInfo,
 		    reserveEsp = reserveEsp})
@@ -306,7 +333,7 @@
 	val outputAssembly =
 	   Control.trace (Control.Pass, "outputAssembly") outputAssembly
       in
-	outputC()
-	; outputAssembly()
+	outputAssembly()
+	; outputC()
       end 
 end



1.37      +48 -15    mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun

Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- x86-generate-transfers.fun	2 Jan 2003 17:45:17 -0000	1.36
+++ x86-generate-transfers.fun	20 Jan 2003 16:28:31 -0000	1.37
@@ -125,6 +125,7 @@
 
   fun generateTransfers {chunk as Chunk.T {data, blocks, ...},
 			 optimize: int,
+			 newProfileLabel: x86.ProfileLabel.t -> x86.ProfileLabel.t,
 			 liveInfo : x86Liveness.LiveInfo.t,
 			 jumpInfo : x86JumpInfo.t,
 			 reserveEsp: bool}
@@ -351,6 +352,22 @@
 		   setLayoutInfo(label, SOME block)
 		 end)
 
+ 	val profileLabel as {get = getProfileLabel : Label.t -> ProfileLabel.t option,
+			     set = setProfileLabel,
+			     destroy = destProfileLabel}
+	  = Property.destGetSetOnce
+	    (Label.plist, 
+	     Property.initRaise ("profileLabel", Label.layout))
+	val _ 
+	  = List.foreach
+	    (blocks,
+	     fn block as Block.T {entry, profileLabel, ...}
+	      => let
+		   val label = Entry.label entry
+		 in 
+		   setProfileLabel(label, profileLabel)
+		 end)
+
 	local	
 	  val stack = ref []
 	  val queue = ref (Queue.empty ())
@@ -371,8 +388,11 @@
 	  = let
 	      val label' = Label.new label
 	      val live = getLive(liveInfo, label)
+	      val profileLabel = getProfileLabel label
+	      val profileLabel' = Option.map (profileLabel, newProfileLabel)
 	      val block
 		= Block.T {entry = Entry.jump {label = label'},
+			   profileLabel = profileLabel',
 			   statements 
 			   = (Assembly.directive_restoreregalloc
 			      {live = MemLocSet.add
@@ -385,6 +405,7 @@
 			   transfer = Transfer.goto {target = label}}
 	    in
 	      setLive(liveInfo, label', live);
+	      setProfileLabel(label', profileLabel');
 	      incNear(jumpInfo, label');
 	      Assert.assert("pushCompensationBlock",
 			    fn () => getNear(jumpInfo, label') = Count 1);
@@ -420,7 +441,7 @@
 			Assembly.t AppendList.t
 	  = (case getLayoutInfo label
 	       of NONE => AppendList.empty
-	        | SOME (Block.T {entry, statements, transfer})
+	        | SOME (Block.T {entry, profileLabel, statements, transfer})
 		=> let
 		     val _ = setLayoutInfo(label, NONE)
 
@@ -475,7 +496,10 @@
 			in
 			   AppendList.appends
 			   [align,
-			    AppendList.single (Assembly.label label),
+			    AppendList.single 
+			    (Assembly.label label),
+			    AppendList.fromList 
+			    (ProfileLabel.toAssemblyOpt profileLabel),
 			    assumes]
 			end
 		     val pre
@@ -536,13 +560,15 @@
 					       (* assignTo dst *)
 					       getReturn ()]
 					in
-					  AppendList.append
-					  (AppendList.fromList
+					  AppendList.appends
+					  [AppendList.fromList
 					   [Assembly.pseudoop_p2align 
 					    (Immediate.const_int 4, NONE, NONE),
 					    Assembly.pseudoop_long 
 					    [Immediate.const_int frameLayoutsIndex],
 					    Assembly.label label],
+					   AppendList.fromList
+					   (ProfileLabel.toAssemblyOpt profileLabel),
 					   if maySwitchThreads
 					     then (* entry from far assumptions *)
 					          farEntry finish
@@ -568,31 +594,35 @@
 							  => {memloc = memloc,
 							      sync = sync,
 							      weight = 1024}))})],
-						   finish))
+						   finish)]
 					end
 				 else AppendList.append (near label, getReturn ())
 			       end
 			    | Func {label,...}
-			    => AppendList.append
-			       (AppendList.fromList
+			    => AppendList.appends
+			       [AppendList.fromList
 				[Assembly.pseudoop_p2align 
 				 (Immediate.const_int 4, NONE, NONE),
 				 Assembly.pseudoop_global label,
 				 Assembly.label label],
+				AppendList.fromList
+				(ProfileLabel.toAssemblyOpt profileLabel),
 				(* entry from far assumptions *)
-				(farEntry AppendList.empty))
+				(farEntry AppendList.empty)]
 			    | Cont {label, 
 				    frameInfo = FrameInfo.T {size,
 							     frameLayoutsIndex},
 				    ...}
 			    =>
-			       AppendList.append
-			       (AppendList.fromList
+			       AppendList.appends
+			       [AppendList.fromList
 				[Assembly.pseudoop_p2align
 				 (Immediate.const_int 4, NONE, NONE),
 				 Assembly.pseudoop_long
 				 [Immediate.const_int frameLayoutsIndex],
 				 Assembly.label label],
+				AppendList.fromList
+				(ProfileLabel.toAssemblyOpt profileLabel),
 				(* entry from far assumptions *)
 				(farEntry
 				 (let
@@ -609,18 +639,20 @@
 				       src = bytes, 
 				       size = pointerSize},
 				      profileStackTopCommit)
-				  end)))
+				  end))]
 		            | Handler {frameInfo = (FrameInfo.T
 						    {frameLayoutsIndex, size}),
 				       label,
 				       ...}
-			    => AppendList.append
-			       (AppendList.fromList
+			    => AppendList.appends
+			       [AppendList.fromList
 				[Assembly.pseudoop_p2align 
 				 (Immediate.const_int 4, NONE, NONE),
 				 Assembly.pseudoop_long
 				 [Immediate.const_int frameLayoutsIndex],
 				 Assembly.label label],
+				AppendList.fromList
+				(ProfileLabel.toAssemblyOpt profileLabel),
 				(* entry from far assumptions *)
 				(farEntry
 				 (let
@@ -637,8 +669,8 @@
 				       src = bytes, 
 				       size = pointerSize},
 				      profileStackTopCommit)
-				  end)))
-val pre
+				  end))]
+		     val pre
 		       = AppendList.appends
 		         [if !Control.Native.commented > 1
 			    then AppendList.single
@@ -1887,6 +1919,7 @@
 		       | block => block::(doit ())))
 	val assembly = doit ()
 	val _ = destLayoutInfo ()
+	val _ = destProfileLabel ()
       in
 	data::assembly
       end



1.10      +1 -0      mlton/mlton/codegen/x86-codegen/x86-generate-transfers.sig

Index: x86-generate-transfers.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- x86-generate-transfers.sig	16 Apr 2002 12:10:52 -0000	1.9
+++ x86-generate-transfers.sig	20 Jan 2003 16:28:32 -0000	1.10
@@ -31,6 +31,7 @@
     val generateTransfers:
        {chunk: x86.Chunk.t,
 	optimize: int,
+	newProfileLabel: x86.ProfileLabel.t -> x86.ProfileLabel.t,
 	liveInfo: x86Liveness.LiveInfo.t,
 	jumpInfo: x86JumpInfo.t,
 	reserveEsp: bool} -> x86.Assembly.t list list



1.13      +10 -5     mlton/mlton/codegen/x86-codegen/x86-liveness.fun

Index: x86-liveness.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-liveness.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- x86-liveness.fun	20 Dec 2002 18:29:44 -0000	1.12
+++ x86-liveness.fun	20 Jan 2003 16:28:32 -0000	1.13
@@ -504,10 +504,11 @@
   structure LivenessBlock =
     struct
       datatype t = T of {entry: (Entry.t * Liveness.t),
+			 profileLabel: ProfileLabel.t option,
 			 statements: (Assembly.t * Liveness.t) list,
 			 transfer: Transfer.t * Liveness.t}
 
-      fun toString (T {entry, statements, transfer})
+      fun toString (T {entry, statements, transfer, ...})
 	= concat [let
 		    val (entry,info) = entry
 		  in
@@ -533,7 +534,7 @@
 			   "\n"]
 		  end]
 
-      fun printBlock (T {entry, statements, transfer})
+      fun printBlock (T {entry, statements, transfer, ...})
 	= (let
 	     val (entry,info) = entry
 	   in 
@@ -650,7 +651,8 @@
 	     live = live}
 	  end
 
-      fun toLivenessBlock {block as Block.T {entry, statements, transfer},
+      fun toLivenessBlock {block as Block.T {entry, profileLabel,
+					     statements, transfer},
 			   liveInfo : LiveInfo.t}
 	= let
 	    val {transfer, live}
@@ -667,6 +669,7 @@
 
 	    val liveness_block
 	      = T {entry = entry,
+		   profileLabel = profileLabel,
 		   statements = statements,
 		   transfer = transfer}
 	  in 
@@ -717,7 +720,7 @@
 	     live = live'}
 	  end
 
-      fun verifyLivenessBlock {block as T {entry, statements, transfer},
+      fun verifyLivenessBlock {block as T {entry, statements, transfer, ...},
 			       liveInfo: LiveInfo.t}
 	= let
 	    val {verified = verified_transfer,
@@ -754,13 +757,15 @@
 	  "verifyLivenessBlock"
           verifyLivenessBlock
 
-      fun toBlock {block as T {entry, statements, transfer}}
+      fun toBlock {block as T {entry, profileLabel,
+			       statements, transfer}}
 	= let
 	    val (entry,info) = entry
 	    val statements = List.map(statements, fn (asm,info) => asm)
 	    val (transfer,info) = transfer
 	  in 
 	    Block.T {entry = entry,
+		     profileLabel = profileLabel,
 		     statements = statements,
 		     transfer = transfer}
 	  end



1.11      +1 -0      mlton/mlton/codegen/x86-codegen/x86-liveness.sig

Index: x86-liveness.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-liveness.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-liveness.sig	20 Dec 2002 18:29:44 -0000	1.10
+++ x86-liveness.sig	20 Jan 2003 16:28:32 -0000	1.11
@@ -60,6 +60,7 @@
     structure LivenessBlock:
       sig
 	datatype t = T of {entry: (x86.Entry.t * Liveness.t),
+			   profileLabel: x86.ProfileLabel.t option,
 			   statements: (x86.Assembly.t * Liveness.t) list,
 			   transfer: (x86.Transfer.t * Liveness.t)}
 



1.22      +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.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86-mlton-basic.sig	3 Jan 2003 06:14:16 -0000	1.21
+++ x86-mlton-basic.sig	20 Jan 2003 16:28:33 -0000	1.22
@@ -13,6 +13,7 @@
     structure x86 : X86_PSEUDO
     structure Machine: MACHINE
     sharing x86.Label = Machine.Label
+    sharing type x86.ProfileLabel.t = Machine.ProfileLabel.t
     sharing x86.Runtime = Machine.Runtime
   end
 



1.41      +46 -46    mlton/mlton/codegen/x86-codegen/x86-mlton.fun

Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- x86-mlton.fun	20 Dec 2002 18:29:44 -0000	1.40
+++ x86-mlton.fun	20 Jan 2003 16:28:33 -0000	1.41
@@ -49,7 +49,7 @@
 
 	fun unimplemented s
 	  = AppendList.fromList
-	    [Block.T'
+	    [Block.mkBlock'
 	     {entry = NONE,
 	      statements = [Assembly.comment ("UNIMPLEMENTED PRIM: " ^ s)],
 	      transfer = NONE}]
@@ -80,7 +80,7 @@
                                "applyPrim: lengthArrayVectorString, src"
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements 
 		= [Assembly.instruction_mov
@@ -132,7 +132,7 @@
 		     | _ => Error.bug "applyPrim: subWord8ArrayVector, src2"
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements 
 		= [Assembly.instruction_mov
@@ -184,7 +184,7 @@
 		     | _ => Error.bug "applyPrim: updateWord8Array, src2"
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements 
 		= [Assembly.instruction_mov
@@ -204,7 +204,7 @@
 		   fn () => srcsize = dstsize)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_mov
@@ -224,7 +224,7 @@
 		   fn () => Size.lt(srcsize,dstsize))
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_movx
@@ -246,7 +246,7 @@
 		   fn () => Size.lt(dstsize,srcsize))
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_xvom
@@ -292,7 +292,7 @@
 		    else (src1,src2)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_mov
@@ -336,7 +336,7 @@
 		    else (src1,src2)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_mov
@@ -376,7 +376,7 @@
 		     | _ => (src1,src2)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_mov
@@ -400,7 +400,7 @@
 		   fn () => srcsize = dstsize)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements 
 		= [Assembly.instruction_mov
@@ -429,7 +429,7 @@
 		   fn () => src2size = wordSize)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_mov
@@ -463,7 +463,7 @@
 	       *)
 	      case Operand.deImmediate src1
 		of SOME _ => AppendList.fromList
-		             [Block.T'
+		             [Block.mkBlock'
 			      {entry = NONE,
 			       statements
 			       = [Assembly.instruction_cmp
@@ -477,7 +477,7 @@
 				   size = dstsize}],
 			       transfer = NONE}]
 		 | NONE => AppendList.fromList
-			   [Block.T'
+			   [Block.mkBlock'
 			    {entry = NONE,	
 			     statements
 			     = [Assembly.instruction_cmp
@@ -510,7 +510,7 @@
 	       *)
 	      case Operand.deImmediate src1
 		of SOME _ => AppendList.fromList
-		             [Block.T'
+		             [Block.mkBlock'
 			      {entry = NONE,
 			       statements
 			       = [Assembly.instruction_test
@@ -524,7 +524,7 @@
 				   size = dstsize}],
 			       transfer = NONE}]
 		 | NONE => AppendList.fromList
-			   [Block.T'
+			   [Block.mkBlock'
 			    {entry = NONE,
 			     statements
 			     = [Assembly.instruction_test
@@ -562,7 +562,7 @@
 		     | _ => (oper,src1,src2)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_pfmov
@@ -591,7 +591,7 @@
 			    src3size = dstsize)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements
 		= [Assembly.instruction_pfmov
@@ -621,7 +621,7 @@
 		   fn () => srcsize = dstsize)
 	    in
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements 
 		= [Assembly.instruction_pfmov
@@ -645,7 +645,7 @@
 		   fn () => srcsize = dstsize)
 	    in	
 	      AppendList.fromList
-	      [Block.T'
+	      [Block.mkBlock'
 	       {entry = NONE,
 		statements 
 		= [Assembly.instruction_pfldc
@@ -667,14 +667,14 @@
 		     val comment = primName
 		   in 
 		     (AppendList.single
-		      (x86.Block.T'
+		      (x86.Block.mkBlock'
 		       {entry = NONE,
 			statements 
 			= [x86.Assembly.comment 
 			   ("begin prim: " ^ comment)],
 			transfer = NONE}),
 		      AppendList.single
-		      (x86.Block.T'
+		      (x86.Block.mkBlock'
 		       {entry = NONE,
 			statements 
 			= [x86.Assembly.comment 
@@ -700,7 +700,7 @@
 		  val (src,srcsize) = getSrc1 ()
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements 
 		    = [Assembly.instruction_cmp
@@ -726,7 +726,7 @@
 			      class = Classes.CStatic}
 		       in
 			 AppendList.fromList
-			 [Block.T'
+			 [Block.mkBlock'
 			  {entry = NONE,
 			   statements
 			   = [case Size.class dstsize
@@ -769,7 +769,7 @@
 		       fn () => srcsize = dstsize)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements
 		    = [Assembly.instruction_pfmov
@@ -819,7 +819,7 @@
 		       fn () => srcsize = dstsize)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements
 		    = [Assembly.instruction_pfmov
@@ -865,7 +865,7 @@
 		       fn () => srcsize = dstsize)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements 
 		    = [Assembly.instruction_pfmov
@@ -895,7 +895,7 @@
 		                src2size = dstsize)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements 
 		    = [Assembly.instruction_pfmov
@@ -920,7 +920,7 @@
 		       fn () => srcsize = dstsize)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements 
 		    = [Assembly.instruction_pfldc
@@ -979,7 +979,7 @@
 		       fn () => srcsize = dstsize)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements 
 		    = [Assembly.instruction_pfmov
@@ -1008,7 +1008,7 @@
 		       fn () => src1size = src2size)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements
 		    = [Assembly.instruction_pfcom
@@ -1039,7 +1039,7 @@
 		       fn () => src1size = src2size)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements
 		    = [Assembly.instruction_pfcom
@@ -1070,7 +1070,7 @@
 		       fn () => src1size = src2size)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements
 		    = [Assembly.instruction_pfucom
@@ -1106,7 +1106,7 @@
 		       fn () => src1size = src2size)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements
 		    = [Assembly.instruction_pfcom
@@ -1137,7 +1137,7 @@
 		       fn () => src1size = src2size)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements
 		    = [Assembly.instruction_pfcom
@@ -1168,7 +1168,7 @@
 		       fn () => src1size = src2size)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements
 		    = [Assembly.instruction_pfucom
@@ -1195,7 +1195,7 @@
 		  val (src,srcsize) = getSrc1 ()
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements 
 		    = [Assembly.instruction_pfmovfi
@@ -1211,7 +1211,7 @@
 		  val (src,srcsize) = getSrc1 ()
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements 
 		    = [Assembly.instruction_pfmovti
@@ -1236,7 +1236,7 @@
 		       fn () => src2size = Size.LONG)
 		in
 		  AppendList.fromList
-		  [Block.T'
+		  [Block.mkBlock'
 		   {entry = NONE,
 		    statements 
 		    = [Assembly.instruction_pfmovfi
@@ -1321,7 +1321,7 @@
 	val dstsize = Option.map (returnTy, toX86Size)
 	val comment_begin
 	  = if !Control.Native.commented > 0
-	      then AppendList.single (x86.Block.T'
+	      then AppendList.single (x86.Block.mkBlock'
 				      {entry = NONE,
 				       statements 
 				       = [x86.Assembly.comment
@@ -1332,7 +1332,7 @@
 	AppendList.appends
 	[comment_begin,
 	 AppendList.single
-	 (Block.T'
+	 (Block.mkBlock'
 	  {entry = NONE,
 	   statements = [],
 	   transfer = SOME (Transfer.ccall 
@@ -1361,7 +1361,7 @@
 		      (liveInfo, label, live label)
 	    in 
 	      AppendList.single
-	      (x86.Block.T'
+	      (x86.Block.mkBlock'
 	       {entry = SOME (Entry.creturn {dst = dst,
 					     frameInfo = frameInfo,
 					     func = func,
@@ -1372,7 +1372,7 @@
 	val comment_end
 	  = if !Control.Native.commented > 0
 	      then (AppendList.single
-		    (x86.Block.T' {entry = NONE,
+		    (x86.Block.mkBlock' {entry = NONE,
 				   statements = [x86.Assembly.comment 
 						 ("end creturn: " ^ name)],
 				   transfer = NONE}))
@@ -1400,7 +1400,7 @@
 		 fn () => src1size = dstsize)
 	fun check (src, statement, condition)
 	  = AppendList.single
-	    (x86.Block.T'
+	    (x86.Block.mkBlock'
 	     {entry = NONE,	
 	      statements = [x86.Assembly.instruction_mov
 			    {dst = dst,
@@ -1516,14 +1516,14 @@
 		     val comment = primName
 		   in 
 		     (AppendList.single
-		      (x86.Block.T'
+		      (x86.Block.mkBlock'
 		       {entry = NONE,
 			statements 
 			= [x86.Assembly.comment 
 			   ("begin arith: " ^ comment)],
 			transfer = NONE}),
 		      AppendList.single
-		      (x86.Block.T'
+		      (x86.Block.mkBlock'
 		       {entry = NONE,
 			statements 
 			= [x86.Assembly.comment 



1.16      +17 -8     mlton/mlton/codegen/x86-codegen/x86-pseudo.sig

Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- x86-pseudo.sig	2 Jan 2003 17:45:18 -0000	1.15
+++ x86-pseudo.sig	20 Jan 2003 16:28:35 -0000	1.16
@@ -453,15 +453,24 @@
 		     target: Label.t} -> t
       end
 
-    structure Block :
+    structure ProfileLabel :
       sig
-	datatype t' = T' of {entry: Entry.t option,
-			     statements: Assembly.t list,
-			     transfer: Transfer.t option}
-	datatype t = T of {entry: Entry.t,
-			   statements: Assembly.t list,
-			   transfer: Transfer.t}
-	val compress : t' list -> t list
+	type t
+      end
+
+    structure Block :
+      sig	
+	type t'
+	val mkBlock': {entry: Entry.t option,
+		       statements: Assembly.t list,
+		       transfer: Transfer.t option} -> t'
+	val mkProfileBlock': {profileLabel: ProfileLabel.t} -> t'
+	val printBlock' : t' -> unit
+
+	type t
+	val printBlock : t -> unit
+
+	val compress: t' list -> t list
       end
 
     structure Chunk :



1.24      +129 -6    mlton/mlton/codegen/x86-codegen/x86-simplify.fun

Index: x86-simplify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-simplify.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- x86-simplify.fun	20 Dec 2002 18:29:44 -0000	1.23
+++ x86-simplify.fun	20 Jan 2003 16:28:35 -0000	1.24
@@ -22,6 +22,7 @@
     struct
       structure Peephole
 	= Peephole(type entry_type = Entry.t
+		   type profileLabel_type = ProfileLabel.t option
 		   type statement_type = Assembly.t
 		   type transfer_type = Transfer.t
 		   datatype block = datatype Block.t)
@@ -72,6 +73,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -110,11 +112,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -153,11 +157,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -194,6 +200,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -235,6 +242,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.pFMOV
@@ -273,11 +281,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel, 
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.pFMOV
@@ -316,11 +326,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		  else NONE
 	     | {entry,
+	        profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.pFMOV
@@ -359,6 +371,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -437,6 +450,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -478,12 +492,14 @@
 			     in
 			       SOME (Block.T
 				     {entry = entry,
+				      profileLabel = profileLabel,
 				      statements = statements,
 				      transfer = transfer})
 			     end
 			  | _ => NONE
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -525,12 +541,14 @@
 			     in
 			       SOME (Block.T
 				     {entry = entry,
+				      profileLabel = profileLabel,
 				      statements = statements,
 				      transfer = transfer})
 			     end
 			  | _ => NONE
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -570,6 +588,7 @@
 			     in
 			       SOME (Block.T
 				     {entry = entry,
+				      profileLabel = profileLabel,
 				      statements = statements,
 				      transfer = transfer})
 			     end
@@ -615,6 +634,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start,
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -687,11 +707,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start,
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -764,11 +786,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -834,6 +858,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -879,6 +904,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -944,11 +970,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -1014,11 +1042,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.MOV
@@ -1080,6 +1110,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1134,6 +1165,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.BinAL 
@@ -1196,6 +1228,7 @@
 		       in 
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1276,6 +1309,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.pMD 
@@ -1307,6 +1341,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1324,6 +1359,7 @@
 		       in 
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1350,11 +1386,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		    | _ => NONE)
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.pMD 
@@ -1370,6 +1408,7 @@
 		    | SOME (0,false) 
 		    => SOME (Block.T
 			     {entry = entry,
+			      profileLabel = profileLabel,
 			      statements = List.fold(start,
 						     List.concat [comments, finish],
 						     op ::),
@@ -1390,6 +1429,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1416,6 +1456,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1445,11 +1486,13 @@
 			      in
 				SOME (Block.T
 				      {entry = entry,
+				       profileLabel = profileLabel,
 				       statements = statements,
 				       transfer = transfer})
 			      end
 			 else NONE)
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.pMD 
@@ -1465,6 +1508,7 @@
 		    | SOME (0,false) 
 		    => SOME (Block.T
 			     {entry = entry,
+			      profileLabel = profileLabel,
 			      statements = List.fold(start,
 						     List.concat [comments, finish],
 						     op ::),
@@ -1487,6 +1531,7 @@
 			      in 
 				SOME (Block.T
 				      {entry = entry,
+				       profileLabel = profileLabel,
 				       statements = statements,
 				       transfer = transfer})
 			      end
@@ -1494,6 +1539,7 @@
 		    | SOME (i,true)
 		    => NONE)
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.pMD
@@ -1509,6 +1555,7 @@
 		    | SOME (0,false) 
 		    => SOME (Block.T
 			     {entry = entry,
+			      profileLabel = profileLabel,
 			      statements = List.fold(start,
 						     List.concat [comments, finish],
 						     op ::),
@@ -1529,6 +1576,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1596,11 +1644,13 @@
 			      in 
 				SOME (Block.T
 				      {entry = entry,
+				       profileLabel = profileLabel,
 				       statements = statements,
 				       transfer = transfer})
 			      end
 			 else NONE)
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.pMD
@@ -1616,6 +1666,7 @@
 		    | SOME (0,false) 
 		    => SOME (Block.T
 			     {entry = entry,
+			      profileLabel = profileLabel,
 			      statements = List.fold(start,
 						     List.concat [comments, finish],
 						     op ::),
@@ -1638,12 +1689,14 @@
 			      in 
 				SOME (Block.T
 				      {entry = entry,
+				       profileLabel = profileLabel,
 				       statements = statements,
 				       transfer = transfer})
 			      end
 			 else NONE
 	            | SOME (i,true) => NONE)
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.IMUL2
@@ -1674,6 +1727,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1691,6 +1745,7 @@
 		       in 
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1717,11 +1772,13 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
 		    | _ => NONE)
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction (Instruction.IMUL2
@@ -1736,6 +1793,7 @@
 		    | SOME (0,false) 
 		    => SOME (Block.T
 			     {entry = entry,
+			      profileLabel = profileLabel,
 			      statements = List.fold(start,
 						     List.concat [comments, finish],
 						     op ::),
@@ -1756,6 +1814,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1782,6 +1841,7 @@
 		       in
 			 SOME (Block.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -1811,6 +1871,7 @@
 			      in
 				SOME (Block.T
 				      {entry = entry,
+				       profileLabel = profileLabel,
 				       statements = statements,
 				       transfer = transfer})
 			      end
@@ -1864,6 +1925,7 @@
 
 	val rewriter 
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction instruction],
@@ -1892,6 +1954,7 @@
 					op ::)
 			 in
 			   SOME (Block.T {entry = entry,
+					  profileLabel = profileLabel,
 					  statements = statements,
 					  transfer = transfer})
 			 end
@@ -1937,6 +2000,7 @@
 
 	val rewriter 
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction
@@ -1978,6 +2042,7 @@
 				    falsee = falsee}
 		in 
 		  SOME (Block.T {entry = entry,
+				 profileLabel = profileLabel,
 				 statements = statements,
 				 transfer = transfer})
 		end
@@ -2033,6 +2098,7 @@
 
 	val rewriter 
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[Assembly.Instruction instruction],
@@ -2060,6 +2126,7 @@
 				op ::)
 			 in
 			   SOME (Block.T {entry = entry,
+					  profileLabel = profileLabel,
 					  statements = statements,
 					  transfer = transfer})
 			 end
@@ -2175,6 +2242,7 @@
 
 	    val rewriter 
 	      = fn {entry,
+		    profileLabel,
 		    start, 
 		    statements as [],
 		    finish as [],
@@ -2190,6 +2258,7 @@
 		      val transfer = Transfer.goto {target = truee}
 		    in 
 		      SOME (Block.T {entry = entry,
+				     profileLabel = profileLabel,
 				     statements = statements,
 				     transfer = transfer})
 		    end
@@ -2222,6 +2291,7 @@
 
 	    val rewriter 
 	      = fn {entry,
+		    profileLabel,
 		    start as [], 
 		    statements as [statements'],
 		    finish as [],
@@ -2266,6 +2336,7 @@
 			  else Error.bug "elimSwitchTest"
 		    in
 		      SOME (Block.T {entry = entry,
+				     profileLabel = profileLabel,
 				     statements = statements,
 				     transfer = transfer})
 		    end
@@ -2304,6 +2375,7 @@
 
 	    val rewriter 
 	      = fn {entry,
+		    profileLabel,
 		    start as [], 
 		    statements as [statements'],
 		    finish as [],
@@ -2356,6 +2428,7 @@
 						 default = default})
 		    in 
 		      SOME (Block.T {entry = entry,	
+				     profileLabel = profileLabel,
 				     statements = statements,
 				     transfer = transfer})
 		    end
@@ -2370,6 +2443,7 @@
   structure ElimGoto =
     struct
       fun elimSimpleGoto {chunk as Chunk.T {data, blocks, ...},
+			  delProfileLabel : x86.ProfileLabel.t -> unit,
 			  jumpInfo : x86JumpInfo.t} 
 	= let
 	    val gotoInfo as {get: Label.t -> Label.t option,
@@ -2382,6 +2456,7 @@
 	      = List.keepAllMap
 	        (blocks,
 		 fn block as Block.T {entry as Entry.Jump {label}, 
+				      profileLabel,
 				      statements, 
 				      transfer as Transfer.Goto {target}}
 		  => if List.forall(statements,
@@ -2391,7 +2466,9 @@
 		        andalso
 			not (Label.equals(label, target))
 *)
-		       then (set(label, SOME target); SOME label)
+		       then (Option.app(profileLabel, delProfileLabel);
+			     set(label, SOME target); 
+			     SOME label)
 		       else NONE
 		  | _ => NONE)
 		
@@ -2442,8 +2519,9 @@
 	    val blocks
 	      = List.map
 	        (blocks,
-		 fn Block.T {entry, statements, transfer}
+		 fn Block.T {entry, profileLabel, statements, transfer}
 		  => Block.T {entry = entry,
+			      profileLabel = profileLabel,
 			      statements = statements,
 			      transfer = elimSimpleGoto' transfer})
 
@@ -2496,6 +2574,7 @@
 		     => case get label
 			  of SOME (Block.T 
 				   {entry,
+				    profileLabel,
 				    statements,
 				    transfer as Transfer.Goto {target}})
 			   => (if Label.equals(label,target)
@@ -2504,14 +2583,20 @@
 					 of NONE => b
 					  | SOME (Block.T
 						  {entry = entry',
+						   profileLabel = profileLabel',
 						   statements = statements',
 						   transfer = transfer'})
 					  => (set(label,
 						  SOME (Block.T
 							{entry = entry,
+							 profileLabel = profileLabel,
 							 statements
 							 = List.concat
-							   [statements, 
+							   [statements,
+							    [Assembly.Label
+							     (Entry.label entry')],
+							    ProfileLabel.toAssemblyOpt
+							    profileLabel',
 							    statements'],
 						         transfer 
 						         = transfer'}));
@@ -2525,6 +2610,7 @@
 	    val changed = ref false
 	    val elimComplexGoto'
 	      = fn block as Block.T {entry, 
+				     profileLabel,
 				     statements, 
 				     transfer as Transfer.Goto {target}}
 		 => if Label.equals(Entry.label entry,target)
@@ -2532,6 +2618,7 @@
 		      else (case get target
 			      of NONE => block
 			       | SOME (Block.T {entry = entry',
+						profileLabel = profileLabel',
 						statements = statements',
 						transfer = transfer'})
 			       => let
@@ -2547,9 +2634,14 @@
 
 				    val block
 				      = Block.T {entry = entry,
+						 profileLabel = profileLabel,
 						 statements 
 						 = List.concat
-						   [statements, 
+						   [statements,
+						    [Assembly.label
+						     (Entry.label entry')],
+						    ProfileLabel.toAssemblyOpt
+						    profileLabel',
 						    statements'],
 						 transfer = transfer'}
 				  in
@@ -2622,6 +2714,7 @@
 		 fn label 
 		  => let
 		       val {block as Block.T {entry, 
+					      profileLabel, 
 					      statements, 
 					      transfer}, 
 			    reach} = get label
@@ -2630,6 +2723,7 @@
 			 then SOME 
 			      (Block.T 
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements
 				= List.keepAll
 				  (statements,
@@ -2659,6 +2753,7 @@
 	  elimBlocks
 
       fun elimGoto {chunk : Chunk.t,
+		    delProfileLabel: x86.ProfileLabel.t -> unit,
 		    jumpInfo : x86JumpInfo.t}
 	= let
 	    val elimIff 
@@ -2673,6 +2768,7 @@
 		  val {chunk,
 		       changed = changed_elimSimpleGoto}
 		    = elimSimpleGoto {chunk = chunk,
+				      delProfileLabel = delProfileLabel,
 				      jumpInfo = jumpInfo}
 
 		  val Chunk.T {data, blocks, ...} = chunk
@@ -2736,7 +2832,8 @@
       structure Liveness = x86Liveness.Liveness
       structure LivenessBlock = x86Liveness.LivenessBlock
 
-      fun moveHoist {block as LivenessBlock.T {entry, statements, transfer}}
+      fun moveHoist {block as LivenessBlock.T 
+		              {entry, profileLabel, statements, transfer}}
 	= let
 	    val {transfer,live} 
 	      = LivenessBlock.reLivenessTransfer {transfer = transfer}
@@ -3026,6 +3123,7 @@
 				      fn force as {age,...}
 				       => age <> 0)
 	    val block = LivenessBlock.T {entry = entry,
+					 profileLabel = profileLabel,
 					 statements = statements,
 					 transfer = transfer}
 	  in
@@ -3271,7 +3369,8 @@
 	| copyPropagate' _ = Error.bug "copyPropagate'"
 
 
-      fun copyPropagate {block as LivenessBlock.T {entry, statements, transfer},
+      fun copyPropagate {block as LivenessBlock.T 
+			          {entry, profileLabel, statements, transfer},
 			 liveInfo}
 	= let
 	    val {pblock as {statements,transfer},changed}
@@ -3356,6 +3455,7 @@
 		       changed = changed})
 	  in
 	    {block = LivenessBlock.T {entry = entry,
+				      profileLabel = profileLabel,
 				      statements = statements,
 				      transfer = transfer},
 	     changed = changed}
@@ -3388,6 +3488,7 @@
 
       structure Peephole 
 	= Peephole(type entry_type = Entry.t * Liveness.t
+		   type profileLabel_type = ProfileLabel.t option
 		   type statement_type = Assembly.t * Liveness.t
 		   type transfer_type = Transfer.t * Liveness.t
 		   datatype block = datatype LivenessBlock.t)
@@ -3440,6 +3541,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction instruction,
@@ -3498,6 +3600,7 @@
 		       in
 			 SOME (LivenessBlock.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -3570,6 +3673,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction (Instruction.MOV 
@@ -3695,6 +3799,7 @@
 		       in
 			 SOME (LivenessBlock.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})		 
 		       end
@@ -3728,6 +3833,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction (Instruction.MOV 
@@ -3745,6 +3851,7 @@
 		in 
 		  SOME (LivenessBlock.T
 			{entry = entry,
+			 profileLabel = profileLabel,
 			 statements = statements,
 			 transfer = transfer})
 		end
@@ -3805,6 +3912,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction (Instruction.MOV 
@@ -3880,11 +3988,13 @@
 		       in
 			 SOME (LivenessBlock.T
 			       {entry = entry,	
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})		 
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction (Instruction.MOV 
@@ -3960,11 +4070,13 @@
 		       in
 			 SOME (LivenessBlock.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})		 
 		       end
 		  else NONE
 	     | {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction (Instruction.MOV 
@@ -4038,6 +4150,7 @@
 		       in
 			 SOME (LivenessBlock.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})		 
 		       end
@@ -4109,6 +4222,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction (Instruction.pFMOV 
@@ -4224,6 +4338,7 @@
 		       in
 			 SOME (LivenessBlock.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})		 
 		       end
@@ -4257,6 +4372,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction (Instruction.pFMOV 
@@ -4275,6 +4391,7 @@
 		in 
 		  SOME (LivenessBlock.T
 			{entry = entry,
+			 profileLabel = profileLabel,
 			 statements = statements,
 			 transfer = transfer})
 		end
@@ -4316,6 +4433,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(Assembly.Instruction (Instruction.pFMOV 
@@ -4391,6 +4509,7 @@
 		       in
 			 SOME (LivenessBlock.T
 			       {entry = entry,	
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})		 
 		       end
@@ -4443,6 +4562,7 @@
 
 	val rewriter : rewriter
 	  = fn {entry,
+		profileLabel,
 		start, 
 		statements as
 		[[(statement as 
@@ -4516,6 +4636,7 @@
 		       in
 			 SOME (LivenessBlock.T
 			       {entry = entry,
+				profileLabel = profileLabel,
 				statements = statements,
 				transfer = transfer})
 		       end
@@ -4643,6 +4764,7 @@
 
   fun simplify {chunk as Chunk.T {data, blocks, ...}: Chunk.t,
 		optimize : int,
+		delProfileLabel : x86.ProfileLabel.t -> unit,
 		liveInfo : x86Liveness.LiveInfo.t,
 		jumpInfo : x86JumpInfo.t} :
                Chunk.t
@@ -4821,6 +4943,7 @@
 	       val {chunk = chunk',
 		    changed = changed'}
 		 = ElimGoto.elimGoto {chunk = chunk,
+				      delProfileLabel = delProfileLabel,
 				      jumpInfo = jumpInfo}
 		   handle exn
 		    => Error.bug 



1.4       +1 -0      mlton/mlton/codegen/x86-codegen/x86-simplify.sig

Index: x86-simplify.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-simplify.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- x86-simplify.sig	10 Apr 2002 07:02:19 -0000	1.3
+++ x86-simplify.sig	20 Jan 2003 16:28:36 -0000	1.4
@@ -25,6 +25,7 @@
 
     val simplify : {chunk : x86.Chunk.t,
 		    optimize : int,
+		    delProfileLabel : x86.ProfileLabel.t -> unit,
 		    liveInfo : x86Liveness.LiveInfo.t,
 		    jumpInfo : x86JumpInfo.t} -> x86.Chunk.t
 



1.38      +28 -51    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.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- x86-translate.fun	3 Jan 2003 06:14:16 -0000	1.37
+++ x86-translate.fun	20 Jan 2003 16:28:37 -0000	1.38
@@ -221,7 +221,7 @@
 	      => let
 		 in
 		   AppendList.single
-		   (x86.Block.T'
+		   (x86.Block.mkBlock'
 		    {entry = SOME (x86.Entry.jump {label = label}),
 		     statements = [],
 		     transfer = NONE})
@@ -238,7 +238,7 @@
 			       | NONE => args)
 		 in
 		   AppendList.single
-		   (x86.Block.T'
+		   (x86.Block.mkBlock'
 		    {entry = SOME (x86.Entry.func {label = label,
 						   live = args}),
 		     statements = [],
@@ -258,7 +258,7 @@
 			       | NONE => args)
 		 in
 		   AppendList.single
-		   (x86.Block.T'
+		   (x86.Block.mkBlock'
 		    {entry = SOME (x86.Entry.cont {label = label,
 						   live = args,
 						   frameInfo = frameInfo}),
@@ -269,7 +269,7 @@
 	      => let
 		 in 
 		   AppendList.single
-		   (x86.Block.T'
+		   (x86.Block.mkBlock'
 		    {entry = SOME (x86.Entry.handler
 				   {frameInfo = frameInfoToX86 frameInfo,
 				    label = label,
@@ -300,14 +300,14 @@
 		   val comment = (Layout.toString o layout) statement
 		 in
 		   (AppendList.single
-		    (x86.Block.T'
+		    (x86.Block.mkBlock'
 		     {entry = NONE,
 		      statements = [x86.Assembly.comment
 				    (concat ["begin: ",
 					     comment])],
 		      transfer = NONE}),
 		    AppendList.single
-		    (x86.Block.T'
+		    (x86.Block.mkBlock'
 		     {entry = NONE,
 		      statements = [x86.Assembly.comment
 				    (concat ["end: ",
@@ -340,7 +340,7 @@
 		   AppendList.appends
 		   [comment_begin,
 		    AppendList.single
-		    (x86.Block.T'
+		    (x86.Block.mkBlock'
 		     {entry = NONE,
 		      statements
 		      = [(* dst = src *)
@@ -372,17 +372,9 @@
 		    comment_end]
 		 end
 	      | ProfileLabel l =>
-		   let
-		      val label =
-			 Label.fromString (Machine.ProfileLabel.toString l)
-		   in
-		      AppendList.single
-		      (x86.Block.T'
-		       {entry = NONE,
-			statements = [x86.Assembly.pseudoop_global label,
-				      x86.Assembly.label label],
-			transfer = NONE})
-		   end
+		   AppendList.single
+		   (x86.Block.mkProfileBlock'
+		    {profileLabel = l})
  	      | SetSlotExnStack {offset}
 	      => let
 		   val (comment_begin, comment_end) = comments statement
@@ -408,7 +400,7 @@
 		   AppendList.appends
 		   [comment_begin,
 		    AppendList.single
-		    (x86.Block.T'
+		    (x86.Block.mkBlock'
 		     {entry = NONE,
 		      statements =
 		      [(* *(stackTop + offset) = exnStack *)
@@ -432,7 +424,7 @@
 		   AppendList.appends
 		   [comment_begin,
 		    AppendList.single
-		    (x86.Block.T'
+		    (x86.Block.mkBlock'
 		     {entry = NONE,
 		      statements
 		      = [(* exnStack = (stackTop + offset) - stackBottom *)
@@ -479,7 +471,7 @@
 		   AppendList.appends
 		   [comment_begin,
 		    AppendList.single
-		    (x86.Block.T'
+		    (x86.Block.mkBlock'
 		     {entry = NONE,
 		      statements 
 		      = [(* exnStack = *(stackTop + offset) *)
@@ -552,7 +544,7 @@
 		   AppendList.appends
 		   [comment_begin,
 		    AppendList.single
-		    (x86.Block.T'
+		    (x86.Block.mkBlock'
 		     {entry = NONE,
 		      statements
 		      = ((* *(frontier) = header *)
@@ -587,7 +579,7 @@
 
       fun goto l
 	= AppendList.single
-	  (x86.Block.T'
+	  (x86.Block.mkBlock'
 	   {entry = NONE,
 	    statements = [],
 	    transfer = SOME (x86.Transfer.goto
@@ -600,7 +592,7 @@
 	  in
 	    if Label.equals(a, b)
 	      then AppendList.single
-		   (x86.Block.T'
+		   (x86.Block.mkBlock'
 		    {entry = NONE,
 		     statements = [],
 		     transfer = SOME (x86.Transfer.goto {target = a})})
@@ -608,7 +600,7 @@
 		   ((* if (test) goto a
 		     * goto b
 		     *)
-		    x86.Block.T'
+		    x86.Block.mkBlock'
 		    {entry = NONE,
 		     statements 
 		     = [x86.Assembly.instruction_test
@@ -629,7 +621,7 @@
 	  in
 	    if Label.equals(a, b)
 	      then AppendList.single
-		   (x86.Block.T'
+		   (x86.Block.mkBlock'
 		    {entry = NONE,
 		     statements = [],
 		     transfer = SOME (x86.Transfer.goto {target = a})})
@@ -637,7 +629,7 @@
 		   ((* if (test = k) goto a
 		     * goto b
 		     *)
-		    x86.Block.T'
+		    x86.Block.mkBlock'
 		    {entry = NONE,
 		     statements 
 		     = [x86.Assembly.instruction_cmp
@@ -656,7 +648,7 @@
 	    val test = Operand.toX86Operand test
 	  in
 	    AppendList.single
-	    (x86.Block.T'
+	    (x86.Block.mkBlock'
 	     {entry = NONE,
 	      statements = [],
 	      transfer = SOME (x86.Transfer.switch
@@ -722,7 +714,7 @@
 		   val comment = (Layout.toString o layout) transfer
 		 in
 		   AppendList.single
-		   (x86.Block.T'
+		   (x86.Block.mkBlock'
 		    {entry = NONE,
 		     statements = [x86.Assembly.comment comment],
 		      transfer = NONE})
@@ -764,7 +756,7 @@
 	      => AppendList.append
 	         (comments transfer,
 		  AppendList.single
-		  (x86.Block.T'
+		  (x86.Block.mkBlock'
 		   {entry = NONE,
 		    statements = [],
 		    transfer 
@@ -784,7 +776,7 @@
 	      => AppendList.append
 	         (comments transfer,
 		  AppendList.single
-		  (x86.Block.T'
+		  (x86.Block.mkBlock'
 		   {entry = NONE,
 		    statements = [],
 		    transfer 
@@ -817,7 +809,7 @@
 			      ((* if (test & 0x3) goto int 
 				* goto pointer
 				*)
-			       x86.Block.T'
+			       x86.Block.mkBlock'
 			       {entry = NONE,
 				statements 
 				= [x86.Assembly.instruction_test
@@ -845,7 +837,7 @@
 		  (comments transfer,
 		   AppendList.single
 		   ((* goto label *)
-		    x86.Block.T'
+		    x86.Block.mkBlock'
 		    {entry = NONE,
 		     statements = [],
 		     transfer = SOME (x86.Transfer.goto {target = label})})))
@@ -874,7 +866,7 @@
 		    AppendList.append
 		    (com,
 		     AppendList.single
-		     (x86.Block.T' {entry = NONE,
+		     (x86.Block.mkBlock' {entry = NONE,
 				    statements = [],
 				    transfer = SOME transfer}))
 		 end)
@@ -902,7 +894,7 @@
 		 (Entry.toX86Blocks {label = label,
 				     kind = kind,
 				     transInfo = transInfo},
-		  x86.Block.T'
+		  x86.Block.mkBlock'
 		  {entry = NONE,
 		   statements 
 		   = if !Control.Native.commented > 0
@@ -928,23 +920,8 @@
 				    transInfo = transInfo}, l)))
 
 	    val pseudo_blocks = AppendList.toList pseudo_blocks
-		 
-	    val blocks = x86.Block.compress pseudo_blocks
 
-	    val blocks
-	      = if !Control.profile = Control.ProfileNone
-		   then blocks
-		else
-		       List.map
-		       (blocks,
-			fn (x86.Block.T {entry, statements, transfer})
-			 => let
-			      val label = x86.Entry.label entry
-			    in
-			      x86.Block.T {entry = entry,
-					   statements = statements,
-					   transfer = transfer}
-			    end)
+	    val blocks = x86.Block.compress pseudo_blocks
 	  in
 	    blocks
 	  end



1.35      +69 -17    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.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- x86.fun	2 Jan 2003 17:45:19 -0000	1.34
+++ x86.fun	20 Jan 2003 16:28:38 -0000	1.35
@@ -3712,11 +3712,6 @@
 	            | _ => false
     end
 
-  val addProfileLabel: (string * Label.t -> unit) ref =
-     ref (fn _ => ())
-
-  fun setAddProfileLabel x = addProfileLabel := x
-     
   structure Transfer =
     struct
       structure Cases =
@@ -4063,36 +4058,72 @@
       val ccall = CCall
     end
 
+  structure ProfileLabel =
+    struct
+      open ProfileLabel
+
+      fun toAssembly pl =
+	let
+	  val label = Label.fromString (toString pl)
+	in
+	  [Assembly.pseudoop_global label,
+	   Assembly.label label]
+	end
+      fun toAssemblyOpt pl =
+	case pl of
+	  NONE => []
+	| SOME pl => toAssembly pl
+    end
+
   structure Block =
     struct
       datatype t' = T' of {entry: Entry.t option,
+			   profileLabel: ProfileLabel.t option,
 			   statements: Assembly.t list,
 			   transfer: Transfer.t option}
+      fun mkBlock' {entry, statements, transfer} =
+	T' {entry = entry,
+	    profileLabel = NONE,
+	    statements = statements,
+	    transfer = transfer}
+      fun mkProfileBlock' {profileLabel} =
+	T' {entry = NONE,
+	    profileLabel = SOME profileLabel,
+	    statements = [],
+	    transfer = NONE}
+
       datatype t = T of {entry: Entry.t,
+			 profileLabel: ProfileLabel.t option,
 			 statements: Assembly.t list,
 			 transfer: Transfer.t}
 
-      fun printBlock (T {entry, statements, transfer})
+      fun printBlock (T {entry, profileLabel, statements, transfer, ...})
 	= (print (Entry.toString entry);
 	   print ":\n";
+	   Option.app
+	   (profileLabel, fn profileLabel =>
+	    (print (ProfileLabel.toString profileLabel);
+	     print ":\n"));
 	   List.foreach
-	   (statements,
-	    fn asm
-	     => (print (Assembly.toString asm);
-		 print "\n"));
+	   (statements, fn asm => 
+	    (print (Assembly.toString asm);
+	     print "\n"));
 	   print (Transfer.toString transfer);
 	   print "\n")
 
-      fun print_block' (T' {entry, statements, transfer})
+      fun printBlock' (T' {entry, profileLabel, statements, transfer, ...})
 	= (print (if isSome entry
 		    then Entry.toString (valOf entry)
 		    else "---");
 	   print ":\n";
+	   Option.app
+	   (profileLabel, fn profileLabel =>
+	    (print (ProfileLabel.toString profileLabel);
+	     print ":\n"));
 	   List.foreach
-	   (statements,
-	    fn asm
-	     => (print (Assembly.toString asm);
-		 print "\n"));
+	   (statements, fn asm => 
+	    (print (Assembly.toString asm);
+	     print "\n"));
 	   print (if isSome transfer
 		    then Transfer.toString (valOf transfer)
 		    else "NONE");
@@ -4101,25 +4132,46 @@
       val rec compress
 	= fn [] => []
            | [T' {entry = SOME entry1,
+		  profileLabel = profileLabel1,
 		  statements = statements1,
 		  transfer = SOME transfer1}]
 	   => [T {entry = entry1,
+		  profileLabel = profileLabel1,
 		  statements = statements1,
 		  transfer = transfer1}]
 	   | (T' {entry = SOME entry1,
+		  profileLabel = profileLabel1,
 		  statements = statements1,
 		  transfer = SOME transfer1})::blocks
 	   => (T {entry = entry1,
+		  profileLabel = profileLabel1,
 		  statements = statements1,
 		  transfer = transfer1})::(compress blocks)
 	   | (T' {entry = SOME entry1, 
+		  profileLabel = NONE,
+		  statements = [], 
+		  transfer = NONE})::
+	     (T' {entry = NONE, 
+		  profileLabel = profileLabel2,
+		  statements = statements2, 
+		  transfer = transfer2})::blocks
+           => compress ((T' {entry = SOME entry1,
+			     profileLabel = profileLabel2,
+			     statements = statements2,
+			     transfer = transfer2})::blocks)
+	   | (T' {entry = SOME entry1, 
+		  profileLabel = profileLabel1,
 		  statements = statements1, 
-		 transfer = NONE})::
+		  transfer = NONE})::
 	     (T' {entry = NONE, 
+		  profileLabel = profileLabel2,
 		  statements = statements2, 
 		  transfer = transfer2})::blocks
            => compress ((T' {entry = SOME entry1,
-			     statements = statements1 @ statements2,
+			     profileLabel = profileLabel1,
+			     statements = statements1 @
+			                  (ProfileLabel.toAssemblyOpt profileLabel2) @
+			                  statements2,
 			     transfer = transfer2})::blocks)
 	   | _ => Error.bug "Blocks.compress"
     end



1.25      +19 -4     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.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- x86.sig	2 Jan 2003 17:45:19 -0000	1.24
+++ x86.sig	20 Jan 2003 16:28:39 -0000	1.25
@@ -11,15 +11,15 @@
 signature X86_STRUCTS =
   sig
     structure Label: HASH_ID
+    structure ProfileLabel: PROFILE_LABEL
     structure Runtime: RUNTIME
   end
 
 signature X86 =
   sig
-    include X86_STRUCTS
+    structure Label: HASH_ID
+    structure Runtime: RUNTIME
 
-    val setAddProfileLabel: (string * Label.t -> unit) -> unit
-       
     val tracer : string -> ('a -> 'b) -> 
                  (('a -> 'b) * (unit -> unit))
     val tracerTop : string -> ('a -> 'b) -> 
@@ -1163,16 +1163,31 @@
 		    target: Label.t} -> t		       
       end
 
+    structure ProfileLabel :
+      sig
+	include PROFILE_LABEL
+	val toAssembly : t -> Assembly.t list
+	val toAssemblyOpt : t option -> Assembly.t list
+      end
+
     structure Block :
       sig
 	datatype t' = T' of {entry: Entry.t option,
+			     profileLabel: ProfileLabel.t option,
 			     statements: Assembly.t list,
 			     transfer: Transfer.t option}
+	val mkBlock': {entry: Entry.t option,
+		       statements: Assembly.t list,
+		       transfer: Transfer.t option} -> t'
+	val mkProfileBlock': {profileLabel: ProfileLabel.t} -> t'
+	val printBlock' : t' -> unit
+
 	datatype t = T of {entry: Entry.t,
+			   profileLabel: ProfileLabel.t option,
 			   statements: Assembly.t list,
 			   transfer: Transfer.t}
-
 	val printBlock : t -> unit
+
 	val compress : t' list -> t list
       end
 



1.46      +1 -0      mlton/mlton/main/compile.sml

Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- compile.sml	3 Jan 2003 06:14:16 -0000	1.45
+++ compile.sml	20 Jan 2003 16:28:42 -0000	1.46
@@ -21,6 +21,7 @@
 structure Ssa = Ssa (open Atoms)
 structure Machine = Machine (structure Label = Ssa.Label
 			     structure Prim = Atoms.Prim
+			     structure ProfileLabel = Atoms.ProfileLabel
 			     structure SourceInfo = Ssa.SourceInfo)
 local
    open Machine





-------------------------------------------------------
This SF.NET email is sponsored by: FREE  SSL Guide from Thawte
are you planning your Web Server Security? Click here to get a FREE
Thawte SSL guide and find the answers to all your  SSL security issues.
http://ads.sourceforge.net/cgi-bin/redirect.pl?thaw0026en
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel