[MLton-devel] cvs commit: -profile time with the C codegen

[Stephen Weeks]

sweeks      03/01/27 22:47:09

  Modified:    mlton/codegen/c-codegen c-codegen.fun
               mlton/main main.sml
               runtime  gc.c
  Log:
  Added support for -profile time to the C codegen.  This is not
  intended to be perfect, since we can't control what gcc does with the
  code.  But it can still be useful.
  
  The idea is to emit a profile label via __asm__ whenever the Machine
  code has a ProfileLabel statement.  The only (minor) complexity is
  that gcc may prove that code is dead even if MLton didn't -- hence the
  labels must be weak.  This also meant changing the runtime to allow
  labels to be zero valued.
  
  Nicely enough, this helped me find a couple of missing simplifications
  in MLton's Prim.apply.

Revision  Changes    Path
1.45      +14 -7     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.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- c-codegen.fun	23 Jan 2003 03:34:37 -0000	1.44
+++ c-codegen.fun	28 Jan 2003 06:47:08 -0000	1.45
@@ -253,9 +253,9 @@
 	       profileInfo
 	 in
 	    Vector.foreach (labels, fn {label, ...} =>
-			    print (concat ["void ",
-					   ProfileLabel.toString label,
-					   "();\n"]))
+			    C.call ("DeclareProfileLabel",
+				    [ProfileLabel.toString label],
+				    print))
 	    ; declareArray ("struct GC_sourceLabel", "sourceLabels", labels,
 			    fn (_, {label, sourceSeqsIndex}) =>
 			    concat ["{(pointer)", ProfileLabel.toString label,
@@ -480,8 +480,9 @@
 			    in 
 			       ()
 			    end
-		       | ProfileLabel _ =>
-			    Error.bug "C codegen can't do profiling"
+		       | ProfileLabel l =>
+			    C.call ("ProfileLabel", [ProfileLabel.toString l],
+				    print)
 		       | SetExnStackLocal {offset} =>
 			    C.call ("SetExnStackLocal", [C.int offset], print)
 		       | SetExnStackSlot {offset} =>
@@ -490,6 +491,7 @@
 			    C.call ("SetSlotExnStack", [C.int offset], print)
 			    ))
 	 end
+      val profiling = !Control.profile <> Control.ProfileNone
       fun outputChunk (chunk as Chunk.T {chunkLabel, blocks, regMax, ...}) =
 	 let
 	    fun labelFrameSize (l: Label.t): int =
@@ -535,7 +537,7 @@
 			   src = operandToString (Operand.Label return)},
 			  print)
 		; C.push (size, print)
-		; if !Control.profile <> Control.ProfileNone
+		; if profiling
 		     then print "\tFlushStackTop();\n"
 		  else ())
 	    fun copyArgs (args: Operand.t vector): string list * (unit -> unit) =
@@ -611,7 +613,10 @@
 			   end 
 		      | _ => ()
 		  fun pop (fi: FrameInfo.t) =
-		     C.push (~ (Program.frameSize (program, fi)), print)
+		     (C.push (~ (Program.frameSize (program, fi)), print)
+		      ; if profiling
+			   then print "\tFlushStackTop();\n"
+			else ())
 		  val _ =
 		     case kind of
 			Kind.Cont {frameInfo, ...} => pop frameInfo
@@ -740,6 +745,8 @@
 			      else ()
 			   val _ =
 			      if modifiesStackTop
+				 andalso (Option.isNone frameInfo
+					  orelse not profiling)
 				 then print "\tFlushStackTop();\n"
 			      else ()
 			   val _ = print "\t"



1.115     +0 -3      mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.114
retrieving revision 1.115
diff -u -r1.114 -r1.115
--- main.sml	18 Jan 2003 19:01:11 -0000	1.114
+++ main.sml	28 Jan 2003 06:47:09 -0000	1.115
@@ -372,9 +372,6 @@
       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 = ProfileTime
-		 then usage "can't use -profile time with -native false"
-	      else ()
       val _ =
 	 if !keepDot andalso List.isEmpty (!keepPasses)
 	    then keepSSA := true



1.124     +8 -3      mlton/runtime/gc.c

Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.123
retrieving revision 1.124
diff -u -r1.123 -r1.124
--- gc.c	23 Jan 2003 21:44:27 -0000	1.123
+++ gc.c	28 Jan 2003 06:47:09 -0000	1.124
@@ -3187,9 +3187,14 @@
 	s->textEnd = (pointer)&etext;
 	s->textStart = (pointer)&_start;
 	if (ASSERT)
-		for (i = 0; i < s->sourceLabelsSize; ++i)
-			assert (s->textStart <= s->sourceLabels[i].label
-				and s->sourceLabels[i].label < s->textEnd);
+		for (i = 0; i < s->sourceLabelsSize; ++i) {
+			pointer label;
+
+			label = s->sourceLabels[i].label;
+			assert (0 == label
+				or (s->textStart <= label 
+					and label < s->textEnd));
+		}
 	ARRAY (s->textSources, s->textEnd - s->textStart);
 	p = s->textStart;
 	sourceSeqsIndex = SOURCE_SEQ_UNKNOWN;





-------------------------------------------------------
This SF.NET email is sponsored by:
SourceForge Enterprise Edition + IBM + LinuxWorld = Something 2 See!
http://www.vasoftware.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel