[MLton-devel] cvs commit: source-level profiling

Stephen Weeks sweeks@users.sourceforge.net
Fri, 10 Jan 2003 10:36:16 -0800


sweeks      03/01/10 10:36:16

  Modified:    mlton    mlton-stubs-1997.cm mlton-stubs.cm mlton.cm
               mlton/atoms atoms.fun atoms.sig sources.cm
               mlton/backend backend.fun implement-handlers.fun rssa.fun
               mlton/closure-convert closure-convert.fun globalize.fun
                        lambda-free.fun
               mlton/control control.sig control.sml
               mlton/main main.sml
               mlton/ssa analyze.fun direct-exp.fun direct-exp.sig
                        flat-lattice.fun flat-lattice.sig flatten.fun
                        shrink.fun sources.cm ssa-tree.fun ssa-tree.sig
                        type-check.fun
               mlton/type-inference infer.fun
               mlton/xml implement-exceptions.fun monomorphise.fun
                        polyvariance.fun scc-funs.fun simplify.fun
                        sources.cm type-check.fun xml-tree.fun xml-tree.sig
  Added:       mlton/atoms profile-exp.fun profile-exp.sig source-info.fun
                        source-info.sig
  Removed:     mlton/ssa profile-exp.sig source-info.fun source-info.sig
  Log:
  Moved insertion of Profile Enter/Leave statements to the Xml right
  after type inference.  This should eliminate any problems with missed
  information due to (S)Xml inlining.  Added flag: -profile-il
  {xml|ssa}.  This controls where the Enter/Leaves are inserted.  For
  now, -profile-il ssa behaves like profiling used to before this
  checkin -- i.e., it inserts source level profiling information in each
  SSA function just before the SSA simplifier pipeline.  Very soon, once
  I am completely convinced that -profile-il xml is working, I
  anticipate changing the meaning of -profile-il ssa so that it instead
  insterts Enter/Leaves for each SSA function and basic block at the end
  of the SSA pipeline, *not* based on source information.  This should
  allow us to get old-style SSA based profiling information like we had
  before source-level profiling that is often more useful for trying to
  improve the optimizer.
  
  Added optimization to SSA shrinker to turn a nontail call where the
  cont and handler only do profile statements into a tail call where the
  profile statements precede the tail call.  This optimization is
  necessary to undo stuff introduced by -profile xml, which turns all
  tail calls into nontail calls because it wraps a handler around them.
  
  After encountering yet more annoyances with HandlerPush/Pop while
  working on this, I decided to go ahead and put in a couple of simple
  strategies for implementing handlers that do not require
  HandlerPush/Pop.
  
  Added flag: -handlers {flow|pushpop|simple}
  
  -handlers pushpop
  	the old way, using HandlerPush/Pop
  -handlers simple
   	insert appropriate statements before each call, raise, and return
  -handlers flow
  	like -handlers simple, but with some simple forward dataflow
  	analysis to eliminate redundant assignments
  
  After benchmarks showed that using -flow was in the noise, I decided
  to switch to that as the default.  This means that we can eliminate
  HandlerPush/Pop whenever we want.

Revision  Changes    Path
1.8       +18 -17    mlton/mlton/mlton-stubs-1997.cm

Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mlton-stubs-1997.cm	2 Jan 2003 17:45:09 -0000	1.7
+++ mlton-stubs-1997.cm	10 Jan 2003 18:36:03 -0000	1.8
@@ -231,8 +231,12 @@
 atoms/type-ops.fun
 atoms/type.fun
 atoms/tycon.fun
+atoms/source-info.sig
+atoms/source-info.fun
 atoms/generic-scheme.sig
 atoms/scheme.sig
+atoms/profile-exp.sig
+atoms/profile-exp.fun
 atoms/cons.sig
 atoms/const.sig
 atoms/prim.sig
@@ -244,8 +248,6 @@
 atoms/atoms.fun
 atoms/hash-type.sig
 atoms/cases.sig
-ssa/source-info.sig
-ssa/profile-exp.sig
 ssa/ssa-tree.sig
 ssa/direct-exp.sig
 ssa/analyze.sig
@@ -320,7 +322,6 @@
 ../lib/mlton/basic/clearable-promise.sml
 atoms/hash-type.fun
 atoms/cases.fun
-ssa/source-info.fun
 ssa/ssa-tree.fun
 ssa/ssa.fun
 backend/mtype.sig
@@ -367,9 +368,19 @@
 xml/xml-type.sig
 xml/xml-tree.sig
 xml/xml.sig
+xml/xml-tree.fun
+xml/type-check.sig
+xml/type-check.fun
+xml/simplify-types.sig
+xml/simplify-types.fun
+xml/scc-funs.sig
+xml/scc-funs.fun
+xml/simplify.sig
+xml/simplify.fun
+xml/xml.fun
 xml/sxml.sig
-xml/implement-exceptions.sig
-xml/implement-exceptions.fun
+xml/polyvariance.sig
+xml/polyvariance.fun
 ../lib/smlnj/ord-key-sig.sml
 ../lib/smlnj/splaytree-sig.sml
 ../lib/smlnj/splaytree.sml
@@ -383,18 +394,8 @@
 xml/sxml-exns.sig
 xml/monomorphise.sig
 xml/monomorphise.fun
-xml/polyvariance.sig
-xml/polyvariance.fun
-xml/xml-tree.fun
-xml/type-check.sig
-xml/type-check.fun
-xml/simplify-types.sig
-xml/simplify-types.fun
-xml/scc-funs.sig
-xml/scc-funs.fun
-xml/simplify.sig
-xml/simplify.fun
-xml/xml.fun
+xml/implement-exceptions.sig
+xml/implement-exceptions.fun
 closure-convert/lambda-free.sig
 closure-convert/lambda-free.fun
 closure-convert/globalize.sig



1.13      +18 -17    mlton/mlton/mlton-stubs.cm

Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- mlton-stubs.cm	2 Jan 2003 17:45:09 -0000	1.12
+++ mlton-stubs.cm	10 Jan 2003 18:36:04 -0000	1.13
@@ -230,8 +230,12 @@
 atoms/type-ops.fun
 atoms/type.fun
 atoms/tycon.fun
+atoms/source-info.sig
+atoms/source-info.fun
 atoms/generic-scheme.sig
 atoms/scheme.sig
+atoms/profile-exp.sig
+atoms/profile-exp.fun
 atoms/cons.sig
 atoms/const.sig
 atoms/prim.sig
@@ -243,8 +247,6 @@
 atoms/atoms.fun
 atoms/hash-type.sig
 atoms/cases.sig
-ssa/source-info.sig
-ssa/profile-exp.sig
 ssa/ssa-tree.sig
 ssa/direct-exp.sig
 ssa/analyze.sig
@@ -319,7 +321,6 @@
 ../lib/mlton/basic/clearable-promise.sml
 atoms/hash-type.fun
 atoms/cases.fun
-ssa/source-info.fun
 ssa/ssa-tree.fun
 ssa/ssa.fun
 backend/mtype.sig
@@ -366,9 +367,19 @@
 xml/xml-type.sig
 xml/xml-tree.sig
 xml/xml.sig
+xml/xml-tree.fun
+xml/type-check.sig
+xml/type-check.fun
+xml/simplify-types.sig
+xml/simplify-types.fun
+xml/scc-funs.sig
+xml/scc-funs.fun
+xml/simplify.sig
+xml/simplify.fun
+xml/xml.fun
 xml/sxml.sig
-xml/implement-exceptions.sig
-xml/implement-exceptions.fun
+xml/polyvariance.sig
+xml/polyvariance.fun
 ../lib/smlnj/ord-key-sig.sml
 ../lib/smlnj/splaytree-sig.sml
 ../lib/smlnj/splaytree.sml
@@ -382,18 +393,8 @@
 xml/sxml-exns.sig
 xml/monomorphise.sig
 xml/monomorphise.fun
-xml/polyvariance.sig
-xml/polyvariance.fun
-xml/xml-tree.fun
-xml/type-check.sig
-xml/type-check.fun
-xml/simplify-types.sig
-xml/simplify-types.fun
-xml/scc-funs.sig
-xml/scc-funs.fun
-xml/simplify.sig
-xml/simplify.fun
-xml/xml.fun
+xml/implement-exceptions.sig
+xml/implement-exceptions.fun
 closure-convert/lambda-free.sig
 closure-convert/lambda-free.fun
 closure-convert/globalize.sig



1.61      +18 -17    mlton/mlton/mlton.cm

Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -r1.60 -r1.61
--- mlton.cm	2 Jan 2003 17:45:09 -0000	1.60
+++ mlton.cm	10 Jan 2003 18:36:05 -0000	1.61
@@ -201,8 +201,12 @@
 atoms/type-ops.fun
 atoms/type.fun
 atoms/tycon.fun
+atoms/source-info.sig
+atoms/source-info.fun
 atoms/generic-scheme.sig
 atoms/scheme.sig
+atoms/profile-exp.sig
+atoms/profile-exp.fun
 atoms/cons.sig
 atoms/const.sig
 atoms/prim.sig
@@ -214,8 +218,6 @@
 atoms/atoms.fun
 atoms/hash-type.sig
 atoms/cases.sig
-ssa/source-info.sig
-ssa/profile-exp.sig
 ssa/ssa-tree.sig
 ssa/direct-exp.sig
 ssa/analyze.sig
@@ -290,7 +292,6 @@
 ../lib/mlton/basic/clearable-promise.sml
 atoms/hash-type.fun
 atoms/cases.fun
-ssa/source-info.fun
 ssa/ssa-tree.fun
 ssa/ssa.fun
 backend/mtype.sig
@@ -337,9 +338,19 @@
 xml/xml-type.sig
 xml/xml-tree.sig
 xml/xml.sig
+xml/xml-tree.fun
+xml/type-check.sig
+xml/type-check.fun
+xml/simplify-types.sig
+xml/simplify-types.fun
+xml/scc-funs.sig
+xml/scc-funs.fun
+xml/simplify.sig
+xml/simplify.fun
+xml/xml.fun
 xml/sxml.sig
-xml/implement-exceptions.sig
-xml/implement-exceptions.fun
+xml/polyvariance.sig
+xml/polyvariance.fun
 ../lib/smlnj/ord-key-sig.sml
 ../lib/smlnj/splaytree-sig.sml
 ../lib/smlnj/splaytree.sml
@@ -353,18 +364,8 @@
 xml/sxml-exns.sig
 xml/monomorphise.sig
 xml/monomorphise.fun
-xml/polyvariance.sig
-xml/polyvariance.fun
-xml/xml-tree.fun
-xml/type-check.sig
-xml/type-check.fun
-xml/simplify-types.sig
-xml/simplify-types.fun
-xml/scc-funs.sig
-xml/scc-funs.fun
-xml/simplify.sig
-xml/simplify.fun
-xml/xml.fun
+xml/implement-exceptions.sig
+xml/implement-exceptions.fun
 closure-convert/lambda-free.sig
 closure-convert/lambda-free.fun
 closure-convert/globalize.sig



1.3       +2 -0      mlton/mlton/atoms/atoms.fun

Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- atoms.fun	10 Apr 2002 07:02:18 -0000	1.2
+++ atoms.fun	10 Jan 2003 18:36:08 -0000	1.3
@@ -12,6 +12,8 @@
    struct
       open S
 
+      structure SourceInfo = SourceInfo ()
+      structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
       structure Var = Var (structure AstId = Ast.Var)
       structure Tycon = Tycon (structure AstId = Ast.Tycon)
       structure UnaryTycon = UnaryTycon (structure Tycon = Tycon)



1.3       +36 -24    mlton/mlton/atoms/atoms.sig

Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- atoms.sig	10 Apr 2002 07:02:18 -0000	1.2
+++ atoms.sig	10 Jan 2003 18:36:08 -0000	1.3
@@ -14,32 +14,21 @@
    sig
       include ATOMS_STRUCTS
 
-      structure Con: CON sharing Con.AstId = Ast.Con
+      structure Con: CON
+      structure Cons: SET
       structure Const: CONST
-      structure Prim: PRIM sharing Con = Prim.Con sharing Const = Prim.Const
-      structure Tycon: TYCON sharing Tycon.AstId = Ast.Tycon
-      structure UnaryTycon: UNARY_TYCON sharing Tycon = UnaryTycon.Tycon
-      structure Scheme: SCHEME
-      structure Var: VAR sharing Var.AstId = Ast.Var
-      sharing Tycon = Const.Tycon
-      sharing Ast = Const.Ast = Prim.Type.Ast
-      sharing Tycon = Scheme.Tycon
-      sharing Ast.Tyvar = Scheme.Tyvar
-      sharing Scheme = Prim.Scheme
-
+      structure Prim: PRIM 
+      structure ProfileExp: PROFILE_EXP
       structure Record: RECORD
-      sharing Record = Ast.Record
+      structure Scheme: SCHEME
       structure SortedRecord: RECORD
-      sharing SortedRecord = Ast.SortedRecord
-
+      structure SourceInfo: SOURCE_INFO
+      structure Tycon: TYCON
+      structure Tycons: SET
       structure Tyvar: TYVAR
-      sharing Tyvar = Ast.Tyvar
-
-      structure Tyvars: SET sharing type Tyvars.Element.t = Tyvar.t
-      structure Cons: SET sharing type Cons.Element.t = Con.t
-      structure Vars: SET sharing type Vars.Element.t = Var.t
-      structure Tycons: SET sharing type Tycons.Element.t = Tycon.t
-
+      structure UnaryTycon: UNARY_TYCON
+      structure Var: VAR
+      structure Vars: SET
       structure TyvarEnv:
 	 sig
 	    include MONO_ENV 
@@ -50,8 +39,29 @@
 	     *)
             val rename: t * Tyvar.t vector -> t * Tyvar.t vector
 	 end
-      sharing type TyvarEnv.Domain.t = Tyvar.t
-      sharing type TyvarEnv.Range.t = Tyvar.t
+      structure Tyvars: SET
+
+      sharing Ast = Const.Ast = Prim.Type.Ast
+      sharing Ast.Con = Con.AstId
+      sharing Ast.Tycon = Tycon.AstId
+      sharing Ast.Tyvar = Scheme.Tyvar
+      sharing Ast.Var = Var.AstId
+      sharing Con = Prim.Con
+      sharing Const = Prim.Const
+      sharing Record = Ast.Record
+      sharing Scheme = Prim.Scheme
+      sharing SortedRecord = Ast.SortedRecord
+      sharing SourceInfo = ProfileExp.SourceInfo
+      sharing Tycon = Const.Tycon
+      sharing Tycon = Scheme.Tycon
+      sharing Tycon = UnaryTycon.Tycon
+      sharing Tyvar = Ast.Tyvar
+      sharing type Con.t = Cons.Element.t
+      sharing type Tycon.t = Tycons.Element.t
+      sharing type Tyvar.t = TyvarEnv.Domain.t
+      sharing type Tyvar.t = TyvarEnv.Range.t
+      sharing type Tyvar.t = Tyvars.Element.t
+      sharing type Var.t = Vars.Element.t
    end
 
 signature ATOMS =
@@ -65,9 +75,11 @@
       sharing Var = Atoms.Var
       sharing Con = Atoms.Con
       sharing Prim = Atoms.Prim
+      sharing ProfileExp = Atoms.ProfileExp
       sharing Tycon = Atoms.Tycon
       sharing Tyvar = Atoms.Tyvar
       sharing Record = Atoms.Record
+      sharing SourceInfo = Atoms.SourceInfo
       sharing Vars = Atoms.Vars
       sharing Cons = Atoms.Cons
       sharing Tycons = Atoms.Tycons



1.7       +6 -0      mlton/mlton/atoms/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- sources.cm	7 Dec 2002 02:21:51 -0000	1.6
+++ sources.cm	10 Jan 2003 18:36:08 -0000	1.7
@@ -17,8 +17,10 @@
 signature HASH_ID
 signature HASH_TYPE
 signature PRIM
+signature PROFILE_EXP
 signature RECORD
 signature SCHEME
+signature SOURCE_INFO
 signature TYCON
 signature TYPE_OPS
 signature TYPE
@@ -56,7 +58,11 @@
 id.sig
 prim.fun
 prim.sig
+profile-exp.fun
+profile-exp.sig
 scheme.sig
+source-info.fun
+source-info.sig
 tycon.fun
 tycon.sig
 type-ops.fun



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

Index: profile-exp.fun
===================================================================
functor ProfileExp (S: PROFILE_EXP_STRUCTS): PROFILE_EXP =
struct

open S

datatype t =
   Enter of SourceInfo.t
 | Leave of SourceInfo.t

val toString =
   fn Enter si => concat ["Enter ", SourceInfo.toString si]
    | Leave si => concat ["Leave " , SourceInfo.toString si]

val layout = Layout.str o toString

val equals =
   fn (Enter si, Enter si') => SourceInfo.equals (si, si')
    | (Leave si, Leave si') => SourceInfo.equals (si, si')
    | _ => false

local
   val newHash = Random.word
   val enter = newHash ()
   val leave = newHash ()
in
   val hash =
      fn Enter si => Word.xorb (enter, SourceInfo.hash si)
       | Leave si => Word.xorb (leave, SourceInfo.hash si)
end

end



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

Index: profile-exp.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature PROFILE_EXP_STRUCTS =
   sig
      structure SourceInfo: SOURCE_INFO
   end

signature PROFILE_EXP =
   sig
      include PROFILE_EXP_STRUCTS

      datatype t =
	 Enter of SourceInfo.t
       | Leave of SourceInfo.t

      val equals: t * t -> bool
      val hash: t -> word
      val layout: t -> Layout.t
      val toString: t -> string
   end



1.1                  mlton/mlton/atoms/source-info.fun

Index: source-info.fun
===================================================================
functor SourceInfo (S: SOURCE_INFO_STRUCTS): SOURCE_INFO =
struct

type t = string

fun toString s = s

val layout = Layout.str o toString

val equals: t * t -> bool = op =

val fromString = fn s => s

val hash = String.hash

val gc = "<gc>"
val main = "<main>"
val polyEqual = "<poly-equal>"
val unknown = "<unknown>"

val basisPrefix = "<basis>/"
   
fun fromRegion r =
   case Region.left r of
      NONE => "<unknown>"
    | SOME (SourcePos.T {file, line, ...}) =>
	 let
	    val s = "/basis-library/"
	    val file = 
	       case String.findSubstring {string = file, substring = s} of
		  NONE => file
		| SOME i =>
		     concat [basisPrefix,
			     String.dropPrefix (file, i + String.size s)]
	 in
	    concat [file, ":", Int.toString line]
	 end

fun isBasis s =
   String.isPrefix {prefix = basisPrefix,
		    string = s}

end



1.1                  mlton/mlton/atoms/source-info.sig

Index: source-info.sig
===================================================================
type int = Int.t
type word = Word.t
   
signature SOURCE_INFO_STRUCTS =
   sig
   end

signature SOURCE_INFO =
   sig
      include SOURCE_INFO_STRUCTS
	 
      type t

      val equals: t * t -> bool
      val gc: t
      val fromRegion: Region.t -> t
      val fromString: string -> t
      val hash: t -> word
      val isBasis: t -> bool
      val layout: t -> Layout.t
      val main: t
      val polyEqual: t
      val toString: t -> string
      val unknown: t
   end



1.47      +1 -1      mlton/mlton/backend/backend.fun

Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- backend.fun	4 Jan 2003 02:00:27 -0000	1.46
+++ backend.fun	10 Jan 2003 18:36:08 -0000	1.47
@@ -152,6 +152,7 @@
       val program = pass ("insertLimitChecks", LimitCheck.insert, program)
       val program = pass ("insertSignalChecks", SignalCheck.insert, program)
       val program = pass ("implementHandlers", ImplementHandlers.doit, program)
+      val _ = R.Program.checkHandlers program
       val {frameProfileIndices, labels = profileLabels, program, sources,
 	   sourceSeqs, sourceSuccessors} =
 	 Control.passTypeCheck
@@ -162,7 +163,6 @@
 	  suffix = "rssa",
 	  thunk = fn () => Profile.profile program,
 	  typeCheck = R.Program.typeCheck o #program}
-      val _ = R.Program.checkHandlers program
       val profileStack =
 	 !Control.profile <> Control.ProfileNone
 	 andalso !Control.profileStack



1.8       +363 -121  mlton/mlton/backend/implement-handlers.fun

Index: implement-handlers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/implement-handlers.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- implement-handlers.fun	2 Jan 2003 17:45:13 -0000	1.7
+++ implement-handlers.fun	10 Jan 2003 18:36:10 -0000	1.8
@@ -10,6 +10,8 @@
 
 open S
 open Rssa
+datatype z = datatype Statement.t
+datatype z = datatype Transfer.t
 
 structure LabelInfo =
    struct
@@ -25,134 +27,374 @@
 	  ("visited", Bool.layout (!visited))]
    end
 
-fun doit (Program.T {functions, main, objectTypes}) =
+structure Function =
+   struct
+      open Function
+
+      fun hasHandler (f: t): bool =
+	 let
+	    val {blocks, ...} = dest f
+	 in
+	    Vector.exists
+	    (blocks, fn Block.T {transfer, ...} =>
+	     case transfer of
+		Transfer.Call
+		{return = (Return.NonTail
+			   {handler = Handler.Handle _, ...}), ...} =>
+		   true
+              | _ => false)
+	 end
+   end
+
+structure HandlerLat = FlatLattice (structure Point = Label)
+
+structure ExnStack =
+   struct
+      local
+	 structure ZPoint =
+	    struct
+	       datatype t = Local | Slot
+	       
+	       val equals: t * t -> bool = op =
+	       
+	       val toString =
+		  fn Local => "Local"
+		   | Slot => "Slot"
+
+	       val layout = Layout.str o toString
+	    end
+	 structure L = FlatLattice (structure Point = ZPoint)
+      in
+	 open L
+	 structure Point = ZPoint
+	 val locall = point Point.Local
+	 val slot = point Point.Slot
+      end
+   end
+
+fun flow (f: Function.t): Function.t =
+   if not (Function.hasHandler f)
+      then f
+   else
    let
-      fun implementFunction (f: Function.t): Function.t =
+      val debug = false
+      val {args, blocks, name, raises, returns, start} =
+	 Function.dest f
+      val {get = labelInfo: Label.t -> {global: ExnStack.t,
+					handler: HandlerLat.t}, ...} =
+	 Property.get (Label.plist,
+		       Property.initFun (fn _ =>
+					 {global = ExnStack.new (),
+					  handler = HandlerLat.new ()}))
+      val _ =
+	 Vector.foreach
+	 (blocks, fn Block.T {label, transfer, ...} =>
+	  let
+	     val {global, handler} = labelInfo label
+	     val _ =
+		if Label.equals (label, start)
+		   then (ExnStack.<= (ExnStack.slot, global)
+			 ; HandlerLat.forceTop handler
+			 ; ())
+		else ()
+	     fun goto' {global = g, handler = h}: unit =
+		(ExnStack.<= (global, g)
+		 ; HandlerLat.<= (handler, h)
+		 ; ())
+	     val goto = goto' o labelInfo
+	  in
+	     case transfer of
+		Call {return, ...} =>
+		   (case return of
+		       Return.Dead => ()
+		     | Return.NonTail {cont, handler = h} =>
+			  let
+			     val li as {global = g', handler = h'} =
+				labelInfo cont
+			  in
+			     case h of
+				Handler.Caller =>
+				   (ExnStack.<= (ExnStack.slot, g')
+				    ; HandlerLat.<= (handler, h')
+				    ; ())
+			      | Handler.Dead => goto' li
+			      | Handler.Handle l =>
+				   let
+				      fun doit {global = g'', handler = h''} =
+					 (ExnStack.<= (ExnStack.locall, g'')
+					  ; (HandlerLat.<=
+					     (HandlerLat.point l, h'')))
+				   in
+				      doit (labelInfo l)
+				      ; doit li
+				      ; ()
+				   end
+			  end
+		     | Return.Tail => ())
+	      | _ => Transfer.foreachLabel (transfer, goto)
+	  end)
+      val _ =
+	 if debug
+	    then
+	       Layout.outputl
+	       (Vector.layout
+		(fn Block.T {label, ...} =>
+		 let
+		    val {global, handler} = labelInfo label
+		 in
+		    Layout.record [("label", Label.layout label),
+				   ("global", ExnStack.layout global),
+				   ("handler", HandlerLat.layout handler)]
+		 end)
+		blocks,
+		Out.error)
+	 else ()
+      val blocks =
+	 Vector.map
+	 (blocks,
+	  fn Block.T {args, kind, label, statements, transfer} =>
+	  let
+	     val {global, handler} = labelInfo label
+	     fun setExnStackSlot () =
+		if ExnStack.isPointEq (global, ExnStack.Point.Slot)
+		   then Vector.new0 ()
+		else Vector.new1 SetExnStackSlot
+	     fun setExnStackLocal () =
+		if ExnStack.isPointEq (global, ExnStack.Point.Local)
+		   then Vector.new0 ()
+		else Vector.new1 SetExnStackLocal
+	     fun setHandler (l: Label.t) =
+		if HandlerLat.isPointEq (handler, l)
+		   then Vector.new0 ()
+		else Vector.new1 (SetHandler l)
+	     val post =
+		case transfer of
+		   Call {args, func, return} =>
+		      (case return of
+			  Return.Dead => Vector.new0 ()
+			| Return.NonTail {cont, handler} =>
+			     (case handler of
+				 Handler.Caller => setExnStackSlot ()
+			       | Handler.Dead => Vector.new0 ()
+			       | Handler.Handle l =>
+				    Vector.concat
+				    [setHandler l, setExnStackLocal ()])
+			| Return.Tail => setExnStackSlot ())
+		 | Raise _ => setExnStackSlot ()
+		 | Return _ => setExnStackSlot ()
+		 | _ => Vector.new0 ()
+	     val statements = Vector.concat [statements, post]
+	  in
+	     Block.T {args = args,
+		      kind = kind,
+		      label = label,
+		      statements = statements,
+		      transfer = transfer}
+	  end)
+      val newStart = Label.newNoname ()
+      val startBlock =
+	 Block.T {args = Vector.new0 (),
+		  kind = Kind.Jump,
+		  label = newStart,
+		  statements = Vector.new1 SetSlotExnStack,
+		  transfer = Goto {args = Vector.new0 (),
+				   dst = start}}
+      val blocks = Vector.concat [blocks, Vector.new1 startBlock]
+   in
+      Function.new {args = args,
+		    blocks = blocks,
+		    name = name,
+		    raises = raises,
+		    returns = returns,
+		    start = newStart}
+   end
+
+fun pushPop (f: Function.t): Function.t =
+   let
+      val {args, blocks, name, raises, returns, start} =
+	 Function.dest f
+      val {get = labelInfo: Label.t -> LabelInfo.t,
+	   set = setLabelInfo, ...} =
+	 Property.getSetOnce
+	 (Label.plist, Property.initRaise ("info", Label.layout))
+      val _ =
+	 Vector.foreach
+	 (blocks, fn b as Block.T {label, ...} =>
+	  setLabelInfo (label,
+			{block = b,
+			 handlerStack = ref NONE,
+			 replacement = ref NONE,
+			 visited = ref false}))
+      (* Do a dfs from the start, figuring out the handler stack at
+       * each label.
+       *)
+      fun visit (l: Label.t, hs: Label.t list): unit =
 	 let
-	    val {args, blocks, name, raises, returns, start} =
-	       Function.dest f
-	    val {get = labelInfo: Label.t -> LabelInfo.t,
-		 set = setLabelInfo, ...} =
-	       Property.getSetOnce
-	       (Label.plist, Property.initRaise ("info", Label.layout))
-	    val _ =
-	       Vector.foreach
-	       (blocks, fn b as Block.T {label, ...} =>
-		setLabelInfo (label,
-			      {block = b,
-			       handlerStack = ref NONE,
-			       replacement = ref NONE,
-			       visited = ref false}))
-	    (* Do a dfs from the start, figuring out the handler stack at
-	     * each label.
-	     *)
-	    fun visit (l: Label.t, hs: Label.t list): unit =
+	    val {block, handlerStack, replacement, visited} = labelInfo l
+	    val Block.T {statements, transfer, ...} = block
+	 in
+	    if !visited
+	       then ()
+	    else
 	       let
-		  val {block, handlerStack, replacement, visited} = labelInfo l
-		  val Block.T {statements, transfer, ...} = block
-	       in
-		  if !visited
-		     then ()
-		  else
-		     let
-			val _ = visited := true
-			fun bug msg =
-			   (Vector.layout
-			    (fn Block.T {label, ...} =>
-			     let open Layout
-			     in seq [Label.layout label,
-				     str " ",
-				     LabelInfo.layout (labelInfo label)]
-			     end)
-			    ; Error.bug (concat
-					 [msg, ": ", Label.toString l]))
-			val _ =
-			   case !handlerStack of
-			      NONE => handlerStack := SOME hs
-			    | SOME hs' =>
-				 if List.equals (hs, hs', Label.equals)
-				    then ()
-				 else bug "handler stack mismatch"
-			datatype z = datatype Statement.t
-			val hs =
-			   if not (Vector.exists
-				   (statements, fn s =>
-				    case s of
-				       HandlerPop _ => true
-				     | HandlerPush _ => true
-				     | _ => false))
-			      (* An optimization to avoid recopying blocks
-			       * with no handlers.
-			       *)
-			      then (replacement := SOME statements
-				    ; hs)
-			   else
-			      let
-				 val (hs, ac) =
-				    Vector.fold
-				    (statements, (hs, []), fn (s, (hs, ac)) =>
-				     case s of
-					HandlerPop _ =>
-					   (case hs of
-					       [] => bug "pop of empty handler stack"
-					     | _ :: hs =>
-						  let
-						     val s =
-							case hs of
-							   [] =>
-							      Statement.SetExnStackSlot
-							 | h :: _ =>
-							      Statement.SetHandler h
-						  in (hs, s :: ac)
-						  end)
-				      | HandlerPush h =>
-					   let
-					      val ac =
-						 Statement.SetHandler h :: ac
-					      val ac =
-						 case hs of
-						    [] =>
-						       Statement.SetExnStackLocal
-						       :: Statement.SetSlotExnStack
-						       :: ac
-						  | _ => ac
-					   in
-					      (h :: hs, ac)
-					   end
-				      | _ => (hs, s :: ac))
-			val _ =
-				    replacement := SOME (Vector.fromListRev ac)
-			      in
-				 hs
-			      end
+		  val _ = visited := true
+		  fun bug msg =
+		     (Vector.layout
+		      (fn Block.T {label, ...} =>
+		       let open Layout
+		       in seq [Label.layout label,
+			       str " ",
+			       LabelInfo.layout (labelInfo label)]
+		       end)
+		      ; Error.bug (concat
+				   [msg, ": ", Label.toString l]))
+		  val _ =
+		     case !handlerStack of
+			NONE => handlerStack := SOME hs
+		      | SOME hs' =>
+			   if List.equals (hs, hs', Label.equals)
+			      then ()
+			   else bug "handler stack mismatch"
+		  val hs =
+		     if not (Vector.exists
+			     (statements, fn s =>
+			      case s of
+				 HandlerPop _ => true
+			       | HandlerPush _ => true
+			       | _ => false))
+			(* An optimization to avoid recopying blocks
+			 * with no handlers.
+			 *)
+			then (replacement := SOME statements
+			      ; hs)
+		     else
+			let
+			   val (hs, ac) =
+			      Vector.fold
+			      (statements, (hs, []), fn (s, (hs, ac)) =>
+			       case s of
+				  HandlerPop _ =>
+				     (case hs of
+					 [] => bug "pop of empty handler stack"
+				       | _ :: hs =>
+					    let
+					       val s =
+						  case hs of
+						     [] => SetExnStackSlot
+						   | h :: _ => SetHandler h
+					    in (hs, s :: ac)
+					    end)
+				| HandlerPush h =>
+				     let
+					val ac = SetHandler h :: ac
+					val ac =
+					   case hs of
+					      [] =>
+						 SetExnStackLocal
+						 :: SetSlotExnStack
+						 :: ac
+					    | _ => ac
+				     in
+					(h :: hs, ac)
+				     end
+				| _ => (hs, s :: ac))
+			   val _ =
+			      replacement := SOME (Vector.fromListRev ac)
 			in
-			   Transfer.foreachLabel (transfer, fn l =>
-						  visit (l, hs))
+			   hs
 			end
+	       in
+		  Transfer.foreachLabel (transfer, fn l =>
+					 visit (l, hs))
 	       end
-	    val _ = visit (start, [])
-	    val blocks =
-	       Vector.map
-	       (blocks, fn b as Block.T {args, kind, label, transfer, ...} =>
-		let
-		   val {replacement, visited, ...} = labelInfo label
-		in
-		   if !visited
-		      then Block.T {args = args,
-				    kind = kind,
-				    label = label,
-				    statements = valOf (! replacement),
-				    transfer = transfer}
-		   else b
-		end)
-	 in
-	    Function.new {args = args,
-			  blocks = blocks,
-			  name = name,
-			  raises = raises,
-			  returns = returns,
-			  start = start}
 	 end
+      val _ = visit (start, [])
+      val blocks =
+	 Vector.map
+	 (blocks, fn b as Block.T {args, kind, label, transfer, ...} =>
+	  let
+	     val {replacement, visited, ...} = labelInfo label
+	  in
+	     if !visited
+		then Block.T {args = args,
+			      kind = kind,
+			      label = label,
+			      statements = valOf (! replacement),
+			      transfer = transfer}
+	     else b
+	  end)
+   in
+      Function.new {args = args,
+		    blocks = blocks,
+		    name = name,
+		    raises = raises,
+		    returns = returns,
+		    start = start}
+   end
+
+fun simple (f: Function.t): Function.t =
+   if not (Function.hasHandler f)
+      then f
+   else
+   let
+      val {args, blocks, name, raises, returns, start} =
+	 Function.dest f
+      val blocks =
+	 Vector.map
+	 (blocks,
+	  fn Block.T {args, kind, label, statements, transfer} =>
+	  let
+	     val post =
+		case transfer of
+		   Call {args, func, return} =>
+		      (case return of
+			  Return.Dead => Vector.new0 ()
+			| Return.NonTail {cont, handler} =>
+			     (case handler of
+				 Handler.Caller =>
+				    Vector.new1 SetExnStackSlot
+			       | Handler.Dead => Vector.new0 ()
+			       | Handler.Handle l =>
+				    Vector.new2 (SetHandler l,
+						 SetExnStackLocal))
+			| Return.Tail =>
+			     Vector.new1 SetExnStackSlot)
+		 | Raise _ => Vector.new1 SetExnStackSlot
+		 | Return _ => Vector.new1 SetExnStackSlot
+		 | _ => Vector.new0 ()
+	     val statements = Vector.concat [statements, post]
+	  in
+	     Block.T {args = args,
+		      kind = kind,
+		      label = label,
+		      statements = statements,
+		      transfer = transfer}
+	  end)
+      val newStart = Label.newNoname ()
+      val startBlock =
+	 Block.T {args = Vector.new0 (),
+		  kind = Kind.Jump,
+		  label = newStart,
+		  statements = Vector.new1 SetSlotExnStack,
+		  transfer = Goto {args = Vector.new0 (),
+				   dst = start}}
+      val blocks = Vector.concat [blocks, Vector.new1 startBlock]
+   in
+      Function.new {args = args,
+		    blocks = blocks,
+		    name = name,
+		    raises = raises,
+		    returns = returns,
+		    start = newStart}
+   end
+
+fun doit (Program.T {functions, main, objectTypes}) =
+   let
+      val implementFunction =
+	 case !Control.handlers of
+	    Control.Flow => flow
+	  | Control.PushPop => pushPop
+	  | Control.Simple => simple
    in
       Program.T {functions = List.revMap (functions, implementFunction),
 		 main = main,



1.27      +19 -2     mlton/mlton/backend/rssa.fun

Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- rssa.fun	2 Jan 2003 17:45:15 -0000	1.26
+++ rssa.fun	10 Jan 2003 18:36:10 -0000	1.27
@@ -721,8 +721,12 @@
 			      ("handler", HandlerLat.layout handler)]
 	 end
 
+      val traceGoto =
+	 Trace.trace ("checkHandlers.goto", Label.layout, Unit.layout)
+	 
       fun checkHandlers (T {functions, ...}) =
 	 let
+	    val debug = false
 	    fun checkFunction (f: Function.t): unit =
 	       let
 		  val {name, start, blocks, ...} = Function.dest f
@@ -746,6 +750,18 @@
 			let
 			   val _ = visited := true
 			   val Block.T {label, statements, transfer, ...} = block
+			   val _ =
+			      if debug
+				 then
+				    let
+				       open Layout
+				    in
+				       outputl
+				       (seq [str "visiting ",
+					     Label.layout label],
+					Out.error)
+				    end
+			      else ()
 			   datatype z = datatype ExnStack.t
 			   datatype z = datatype Statement.t
 			   val {global, handler, slot} =
@@ -762,7 +778,7 @@
 						      slot = slot}
 				| SetSlotExnStack => {global = global,
 						      handler = handler,
-						      slot = slot}
+						      slot = global}
 				| SetHandler l => {global = global,
 						   handler = HandlerLat.point l,
 						   slot = slot}
@@ -807,6 +823,7 @@
 			      in
 				 visitLabel l
 			      end
+			   val goto = traceGoto goto
 			   fun tail name =
 			      assert (name,
 				      ExnStack.forcePoint
@@ -823,7 +840,7 @@
 				  let
 				     datatype z = datatype Return.t
 				  in
-				     case (return) of
+				     case return of
 					Dead => true
 				      | NonTail {handler = h, ...} =>
 					   (case h of



1.23      +207 -203  mlton/mlton/closure-convert/closure-convert.fun

Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- closure-convert.fun	2 Jan 2003 17:45:15 -0000	1.22
+++ closure-convert.fun	10 Jan 2003 18:36:10 -0000	1.23
@@ -334,6 +334,7 @@
 			set (Value.primApply {prim = prim,
 					      args = varExps args,
 					      resultTy = ty})
+		   | Profile _ => (new (); ())
 		   | Raise _ => (new (); ())
 		   | Select {tuple, offset} =>
 			set (Value.select (varExp tuple, offset))
@@ -771,211 +772,214 @@
 	       in (coerce (e', expValue e, v), ac)
 	       end
 	    fun simple e = (e, ac)
-	 in case e of
-	    SprimExp.Var y => simple (convertVarExp y)
-	  | SprimExp.Const c => simple (Dexp.const c)
-	  | SprimExp.PrimApp {prim, targs, args} =>
-	       let
-		  open Prim.Name
-		  fun arg i = Vector.sub (args, i)
-		  val v1 = Vector.new1
-		  val v2 = Vector.new2
-		  val v3 = Vector.new3
-		  fun primApp (targs, args) =
-		     Dexp.primApp {args = args,
-				   prim = prim,
-				   targs = targs,
-				   ty = ty}
-	       in
-   		 if Prim.mayOverflow prim
-		   then simple (Dexp.arith
-				{args = Vector.map (args, convertVarExp),
-				 overflow = Dexp.raisee (convertVar overflow),
-				 prim = prim,
-				 ty = ty})
-		 else
-		    let
-		       datatype z = datatype Prim.Name.t
-		    in
-		       simple
-		       (case Prim.name prim of
-			   Array_update =>
-			      let
-				 val a = varExpInfo (arg 0)
-				 val y = varExpInfo (arg 2)
-				 val v = Value.dearray (VarInfo.value a)
-			      in
-				 primApp (v1 (valueType v),
-					  v3 (convertVarInfo a,
-					      convertVarExp (arg 1),
-					      coerce (convertVarInfo y,
-						      VarInfo.value y, v)))
-			      end
-			 | MLton_eq =>
-			      let
-				 val a0 = varExpInfo (arg 0)
-				 val a1 = varExpInfo (arg 1)
-				 fun doit () =
-				    primApp (v1 (valueType (VarInfo.value a0)),
-					     v2 (convertVarInfo a0,
-						 convertVarInfo a1))
-			      in
-				 case (Value.dest (VarInfo.value a0),
-				       Value.dest (VarInfo.value a1)) of
-				    (Value.Lambdas l, Value.Lambdas l') =>
-				       if Lambdas.equals (l, l')
-					  then doit () 
-				       else Dexp.falsee
-				  | _ => doit ()
-			      end
-			 | MLton_handlesSignals =>
-			      if handlesSignals then Dexp.truee else Dexp.falsee
-			 | Ref_assign =>
-			      let
-				 val r = varExpInfo (arg 0)
-				 val y = varExpInfo (arg 1)
-				 val v = Value.deref (VarInfo.value r)
-			      in
-				 primApp (v1 (valueType v),
-					  v2 (convertVarInfo r,
-					      coerce (convertVarInfo y,
-						      VarInfo.value y, v)))
-			      end
-			 | Ref_ref =>
-			      let
-				 val y = varExpInfo (arg 0)
-				 val v = Value.deref v
-			      in
-				 primApp (v1 (valueType v),
-					  v1 (coerce (convertVarInfo y,
-						      VarInfo.value y, v)))
-			      end
-			 | MLton_serialize =>
-			      let
-				 val y = varExpInfo (arg 0)
-				 val v =
-				    Value.serialValue (Vector.sub (targs, 0))
-			      in
-				 primApp (v1 (valueType v),
-					  v1 (coerce (convertVarInfo y,
-						      VarInfo.value y, v)))
-			      end
-			 | _ =>
-			      let
-				 val args = Vector.map (args, varExpInfo)
-			      in
-				 primApp
-				 (Prim.extractTargs
-				  {prim = prim,
-				   args = Vector.map (args, varInfoType),
-				   result = ty,
-				   dearray = Type.dearray,
-				   dearrow = Type.dearrow,
-				   deref = Type.deref,
-				   devector = Type.devector},
-				  Vector.map (args, convertVarInfo))
-			      end)
-		    end
-	       end
-	  | SprimExp.Tuple xs =>
-	       simple (Dexp.tuple {exps = Vector.map (xs, convertVarExp),
-				   ty = ty})
-	  | SprimExp.Select {tuple, offset} =>
-	       simple (Dexp.select {tuple = convertVarExp tuple,
-				    offset = offset,
-				    ty = ty})
-	  | SprimExp.ConApp {con = con, arg, ...} =>
-	       simple
-	       (Dexp.conApp
-		{con = con,
-		 ty = ty,
-		 args = (case (arg, conArg con) of
-			    (NONE, NONE) => Vector.new0 ()
-			  | (SOME arg, SOME conArg) =>
-			       let
-				  val arg = varExpInfo arg
-				  val argVal = VarInfo.value arg
-				  val arg = convertVarInfo arg
-			       in if Value.equals (argVal, conArg)
-				     then Vector.new1 arg
-				  else Vector.new1 (coerce (arg, argVal, conArg))
-			       end
-			  | _ => Error.bug "constructor mismatch")})
-	  | SprimExp.Raise {exn, ...} => simple (Dexp.raisee (convertVarExp exn))
-	  | SprimExp.Handle {try, catch = (catch, _), handler} =>
-	       let
-		  val catchInfo = varInfo catch
-		  val (try, ac) = convertJoin (try, ac)
-		  val catch = (newVarInfo (catch, catchInfo),
-			       varInfoType catchInfo)
-		  val (handler, ac) = convertJoin (handler, ac)
-	       in (Dexp.handlee {try = try, ty = ty,
-				 catch = catch, handler = handler},
-		   ac)
-	       end
-	  | SprimExp.Case {test, cases, default} =>
-	       let
-		  val (default, ac) =
-		     case default of
-			NONE => (NONE, ac)
-		      | SOME (e, _) => let
-					  val (e, ac) =  convertJoin (e, ac)
-				       in
-					  (SOME e, ac)
-				       end
-		  fun doCases (cases, finish, make) =
-		     let
-			val (cases, ac) =
-			   Vector.mapAndFold
-			   (cases, ac, fn ((x, e), ac) =>
-			    let
-			       val make = make x
-			       val (body, ac) = convertJoin (e, ac)
-			    in (make body, ac)
-			    end)
-		     in (finish cases, ac)
-		     end
-		  fun doit (l, f) = doCases (l, f, fn i => fn e => (i, e))
-		  val (cases, ac) =
-		     case cases of
-			Scases.Char l => doit (l, Dexp.Char)
-		      | Scases.Con cases =>
-			   doCases
-			   (cases, Dexp.Con,
-			    fn Spat.T {con, arg, ...} =>
-			    let
-			       val args =
-				  case (conArg con, arg) of
-				     (NONE, NONE) => Vector.new0 ()
-				   | (SOME v, SOME (arg, _)) =>
-					Vector.new1 (newVar arg, valueType v)
-				   | _ => Error.bug "constructor mismatch"
-			    in fn body => {con = con, args = args, body = body}
-			    end)
-		      | Scases.Int l => doit (l, Dexp.Int)
-		      | Scases.Word l => doit (l, Dexp.Word)
-		      | Scases.Word8 l => doit (l, Dexp.Word8)
-	       in (Dexp.casee
-		   {test = convertVarExp test,
-		    ty = ty, cases = cases, default = default},
+	 in
+	    case e of
+	       SprimExp.App {func, arg} =>
+		  (apply {func = func, arg = arg, resultVal = v},
 		   ac)
-	       end
-	  | SprimExp.Lambda l =>
-	       let
-		  val info = lambdaInfo l
-		  val ac = convertLambda (l, info, ac)
-		  val {cons, ...} = valueLambdasInfo v
-	       in case Vector.peek (cons, fn {lambda = l', ...} =>
-				    Slambda.equals (l, l')) of
-		  NONE => Error.bug "lambda must exist in its own set"
-		| SOME {con, ...} =>
-		     (Dexp.conApp {con = con, ty = ty,
-				   args = Vector.new1 (lambdaInfoTuple info)},
+	     | SprimExp.Case {test, cases, default} =>
+		  let
+		     val (default, ac) =
+			case default of
+			   NONE => (NONE, ac)
+			 | SOME (e, _) => let
+					     val (e, ac) =  convertJoin (e, ac)
+					  in
+					     (SOME e, ac)
+					  end
+		     fun doCases (cases, finish, make) =
+			let
+			   val (cases, ac) =
+			      Vector.mapAndFold
+			      (cases, ac, fn ((x, e), ac) =>
+			       let
+				  val make = make x
+				  val (body, ac) = convertJoin (e, ac)
+			       in (make body, ac)
+			       end)
+			in (finish cases, ac)
+			end
+		     fun doit (l, f) = doCases (l, f, fn i => fn e => (i, e))
+		     val (cases, ac) =
+			case cases of
+			   Scases.Char l => doit (l, Dexp.Char)
+			 | Scases.Con cases =>
+			      doCases
+			      (cases, Dexp.Con,
+			       fn Spat.T {con, arg, ...} =>
+			       let
+				  val args =
+				     case (conArg con, arg) of
+					(NONE, NONE) => Vector.new0 ()
+				      | (SOME v, SOME (arg, _)) =>
+					   Vector.new1 (newVar arg, valueType v)
+				      | _ => Error.bug "constructor mismatch"
+			       in fn body => {con = con, args = args, body = body}
+			       end)
+			 | Scases.Int l => doit (l, Dexp.Int)
+			 | Scases.Word l => doit (l, Dexp.Word)
+			 | Scases.Word8 l => doit (l, Dexp.Word8)
+		  in (Dexp.casee
+		      {test = convertVarExp test,
+		       ty = ty, cases = cases, default = default},
 		      ac)
-	       end
-	  | SprimExp.App {func, arg} =>
-	       (apply {func = func, arg = arg, resultVal = v},
-		ac)
+		  end
+	     | SprimExp.ConApp {con = con, arg, ...} =>
+		  simple
+		  (Dexp.conApp
+		   {con = con,
+		    ty = ty,
+		    args = (case (arg, conArg con) of
+			       (NONE, NONE) => Vector.new0 ()
+			     | (SOME arg, SOME conArg) =>
+				  let
+				     val arg = varExpInfo arg
+				     val argVal = VarInfo.value arg
+				     val arg = convertVarInfo arg
+				  in if Value.equals (argVal, conArg)
+					then Vector.new1 arg
+				     else Vector.new1 (coerce (arg, argVal, conArg))
+				  end
+			     | _ => Error.bug "constructor mismatch")})
+	     | SprimExp.Const c => simple (Dexp.const c)
+	     | SprimExp.Handle {try, catch = (catch, _), handler} =>
+		  let
+		     val catchInfo = varInfo catch
+		     val (try, ac) = convertJoin (try, ac)
+		     val catch = (newVarInfo (catch, catchInfo),
+				  varInfoType catchInfo)
+		     val (handler, ac) = convertJoin (handler, ac)
+		  in (Dexp.handlee {try = try, ty = ty,
+				    catch = catch, handler = handler},
+		      ac)
+		  end
+	     | SprimExp.Lambda l =>
+		  let
+		     val info = lambdaInfo l
+		     val ac = convertLambda (l, info, ac)
+		     val {cons, ...} = valueLambdasInfo v
+		  in case Vector.peek (cons, fn {lambda = l', ...} =>
+				       Slambda.equals (l, l')) of
+		     NONE => Error.bug "lambda must exist in its own set"
+		   | SOME {con, ...} =>
+			(Dexp.conApp {con = con, ty = ty,
+				      args = Vector.new1 (lambdaInfoTuple info)},
+			 ac)
+		  end
+	     | SprimExp.PrimApp {prim, targs, args} =>
+		  let
+		     open Prim.Name
+		     fun arg i = Vector.sub (args, i)
+		     val v1 = Vector.new1
+		     val v2 = Vector.new2
+		     val v3 = Vector.new3
+		     fun primApp (targs, args) =
+			Dexp.primApp {args = args,
+				      prim = prim,
+				      targs = targs,
+				      ty = ty}
+		  in
+		     if Prim.mayOverflow prim
+			then simple (Dexp.arith
+				     {args = Vector.map (args, convertVarExp),
+				      overflow = Dexp.raisee (convertVar overflow),
+				      prim = prim,
+				      ty = ty})
+		     else
+			let
+			   datatype z = datatype Prim.Name.t
+			in
+			   simple
+			   (case Prim.name prim of
+			       Array_update =>
+				  let
+				     val a = varExpInfo (arg 0)
+				     val y = varExpInfo (arg 2)
+				     val v = Value.dearray (VarInfo.value a)
+				  in
+				     primApp (v1 (valueType v),
+					      v3 (convertVarInfo a,
+						  convertVarExp (arg 1),
+						  coerce (convertVarInfo y,
+							  VarInfo.value y, v)))
+				  end
+			     | MLton_eq =>
+				  let
+				     val a0 = varExpInfo (arg 0)
+				     val a1 = varExpInfo (arg 1)
+				     fun doit () =
+					primApp (v1 (valueType (VarInfo.value a0)),
+						 v2 (convertVarInfo a0,
+						     convertVarInfo a1))
+				  in
+				     case (Value.dest (VarInfo.value a0),
+					   Value.dest (VarInfo.value a1)) of
+					(Value.Lambdas l, Value.Lambdas l') =>
+					   if Lambdas.equals (l, l')
+					      then doit () 
+					   else Dexp.falsee
+				      | _ => doit ()
+				  end
+			     | MLton_handlesSignals =>
+				  if handlesSignals then Dexp.truee else Dexp.falsee
+			     | Ref_assign =>
+				  let
+				     val r = varExpInfo (arg 0)
+				     val y = varExpInfo (arg 1)
+				     val v = Value.deref (VarInfo.value r)
+				  in
+				     primApp (v1 (valueType v),
+					      v2 (convertVarInfo r,
+						  coerce (convertVarInfo y,
+							  VarInfo.value y, v)))
+				  end
+			     | Ref_ref =>
+				  let
+				     val y = varExpInfo (arg 0)
+				     val v = Value.deref v
+				  in
+				     primApp (v1 (valueType v),
+					      v1 (coerce (convertVarInfo y,
+							  VarInfo.value y, v)))
+				  end
+			     | MLton_serialize =>
+				  let
+				     val y = varExpInfo (arg 0)
+				     val v =
+					Value.serialValue (Vector.sub (targs, 0))
+				  in
+				     primApp (v1 (valueType v),
+					      v1 (coerce (convertVarInfo y,
+							  VarInfo.value y, v)))
+				  end
+			     | _ =>
+				  let
+				     val args = Vector.map (args, varExpInfo)
+				  in
+				     primApp
+				     (Prim.extractTargs
+				      {prim = prim,
+				       args = Vector.map (args, varInfoType),
+				       result = ty,
+				       dearray = Type.dearray,
+				       dearrow = Type.dearrow,
+				       deref = Type.deref,
+				       devector = Type.devector},
+				      Vector.map (args, convertVarInfo))
+				  end)
+			end
+		  end
+	     | SprimExp.Profile e => simple (Dexp.profile e)
+	     | SprimExp.Raise {exn, ...} =>
+		  simple (Dexp.raisee (convertVarExp exn))
+	     | SprimExp.Select {tuple, offset} =>
+		  simple (Dexp.select {tuple = convertVarExp tuple,
+				       offset = offset,
+				       ty = ty})
+	     | SprimExp.Tuple xs =>
+		  simple (Dexp.tuple {exps = Vector.map (xs, convertVarExp),
+				      ty = ty})
+	     | SprimExp.Var y => simple (convertVarExp y)
 	 end) arg
       and convertLambda (lambda: Slambda.t,
 			 info as LambdaInfo.T {frees, name, recs, ...},



1.6       +1 -0      mlton/mlton/closure-convert/globalize.fun

Index: globalize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/globalize.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- globalize.fun	12 Dec 2002 01:14:22 -0000	1.5
+++ globalize.fun	10 Jan 2003 18:36:11 -0000	1.6
@@ -119,6 +119,7 @@
 			     in
 				(global, once)
 			     end
+			| Profile _ => (false, once)
 			| Raise _ => (false, once)
 			| Select {tuple, ...} => (isGlobal tuple, once)
 			| Tuple xs => (areGlobal xs, once)



1.6       +15 -14    mlton/mlton/closure-convert/lambda-free.fun

Index: lambda-free.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/lambda-free.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- lambda-free.fun	12 Dec 2002 01:14:22 -0000	1.5
+++ lambda-free.fun	10 Jan 2003 18:36:11 -0000	1.6
@@ -108,30 +108,31 @@
 	 end
       and primExp (e, s) = 
 	 case e of
-	    Const _ => ()
-	  | Var x => varExp (x, s)
-	  | Tuple xs => varExps (xs, s)
-	  | Select {tuple, ...} => varExp (tuple, s)
+	    App {func, arg} => (varExp (func, s); varExp (arg, s))
+	  | Case {test, cases, default} =>
+	       (varExp (test, s)
+		; Option.app (default, fn (e, _) => exp (e, s))
+		; Cases.foreach' (cases, fn e => exp (e, s),
+				  fn Pat.T {arg, ...} =>
+				  Option.app (arg, fn (x, _) => bind (x, s))))
+	  | ConApp {arg, ...} => varExpOpt (arg, s)
+	  | Const _ => ()
+	  | Handle {try, catch, handler} =>
+	       (exp (try, s); bind (#1 catch, s); exp (handler, s))
 	  | Lambda l =>
 	       let val xs = lambda l
 	       in setFree (l, xs); vars (xs, s)
 	       end
-	  | ConApp {arg, ...} => varExpOpt (arg, s)
 	  | PrimApp {prim, args, ...} => 
 	       (if Prim.mayOverflow prim
 		  then var (overflowVar, s)
 		  else ();
 		varExps (args, s))
-	  | App {func, arg} => (varExp (func, s); varExp (arg, s))
+	  | Profile _ => ()
 	  | Raise {exn, ...} => varExp (exn, s)
-	  | Handle {try, catch, handler} =>
-	       (exp (try, s); bind (#1 catch, s); exp (handler, s))
-	  | Case {test, cases, default} =>
-	       (varExp (test, s)
-		; Option.app (default, fn (e, _) => exp (e, s))
-		; Cases.foreach' (cases, fn e => exp (e, s),
-				  fn Pat.T {arg, ...} =>
-				  Option.app (arg, fn (x, _) => bind (x, s))))
+	  | Select {tuple, ...} => varExp (tuple, s)
+	  | Tuple xs => varExps (xs, s)
+	  | Var x => varExp (x, s)
       and lambda (l: Lambda.t) : Var.t vector =
 	 let val {arg, body, ...} = Lambda.dest l
 	 in newScope (fn s => (bind (arg, s); exp (body, s)))



1.60      +6 -0      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- control.sig	3 Jan 2003 06:14:16 -0000	1.59
+++ control.sig	10 Jan 2003 18:36:11 -0000	1.60
@@ -56,6 +56,9 @@
        | Every
       val gcCheck: gcCheck ref
 
+      datatype handlers = Flow | PushPop | Simple
+      val handlers: handlers ref
+
       datatype host =
 	 Cross of string
        | Self
@@ -196,6 +199,9 @@
       datatype profile = ProfileNone | ProfileAlloc | ProfileTime
       val profile: profile ref
 
+      datatype profileIL = ProfileXML | ProfileSSA
+      val profileIL: profileIL ref
+	 
       val profileStack: bool ref
 
       (* Array bounds checking. *)



1.76      +31 -0     mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- control.sml	3 Jan 2003 06:14:16 -0000	1.75
+++ control.sml	10 Jan 2003 18:36:11 -0000	1.76
@@ -89,6 +89,22 @@
 		       default = Limit,
 		       toString = GcCheck.toString}
 
+structure Handlers =
+   struct
+      datatype t = Flow | PushPop | Simple
+
+      val toString =
+	 fn Flow => "Flow"
+	  | PushPop => "PushPop"
+	  | Simple => "Simple"
+   end
+
+datatype handlers = datatype Handlers.t
+
+val handlers = control {name = "handlers",
+			default = Flow,
+			toString = Handlers.toString}
+
 structure Host =
    struct
       datatype t =
@@ -342,6 +358,21 @@
 		       default = ProfileNone,
 		       toString = Profile.toString}
 
+structure ProfileIL =
+   struct
+      datatype t = ProfileSSA | ProfileXML
+
+      val toString =
+	 fn ProfileSSA => "ProfileSSA"
+	  | ProfileXML => "ProfileXML"
+   end
+
+datatype profileIL = datatype ProfileIL.t
+   
+val profileIL = control {name = "profile IL",
+			 default = ProfileXML,
+			 toString = ProfileIL.toString}
+   
 val profileStack = control {name = "profile stack",
 			    default = false,
 			    toString = Bool.toString}



1.107     +15 -0     mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.106
retrieving revision 1.107
diff -u -r1.106 -r1.107
--- main.sml	3 Jan 2003 06:14:16 -0000	1.106
+++ main.sml	10 Jan 2003 18:36:12 -0000	1.107
@@ -138,6 +138,14 @@
 		       | "first" => First
 		       | "every" => Every
 		       | _ => usage (concat ["invalid -gc-check flag: ", s])))),
+       (Expert, "handlers", " {flow|pushpop|simple}",
+	"how to implement handlers",
+	SpaceString (fn s =>
+		     case s of
+			"flow" => handlers := Flow
+		      | "pushpop" => handlers := PushPop
+		      | "simple" => handlers := Simple
+		      | _ => usage (concat ["invalid -handlers flag: ", s]))),
        (Normal, "host",
 	concat [" {",
 		concat (List.separate (List.map (hostMap (), #host), "|")),
@@ -253,6 +261,13 @@
 		      | "alloc" => ProfileAlloc
 		      | "time" => ProfileTime
 		      | _ => usage (concat ["invalid -profile arg: ", s])))),
+       (Expert, "profile-il", " {xml|ssa}", "where to insert profile exps",
+	SpaceString
+	(fn s =>
+	 case s of
+	    "ssa" => profileIL := ProfileSSA
+	  | "xml" => profileIL := ProfileXML
+	  | _ => usage (concat ["invalid -profile-il arg: ", s]))),
        (Normal, "profile-stack", " {false|true}",
 	"profile the stack",
 	boolRef profileStack),



1.19      +18 -13    mlton/mlton/ssa/analyze.fun

Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- analyze.fun	2 Jan 2003 17:45:20 -0000	1.18
+++ analyze.fun	10 Jan 2003 18:36:13 -0000	1.19
@@ -20,9 +20,11 @@
     select, tuple, useFromTypeOnBinds} =
    let
       val unit = fromType Type.unit
-      fun coerces (from, to) =
-	 Vector.foreach2 (from, to, fn (from, to) =>
-			  coerce {from = from, to = to})
+      fun coerces (msg, from, to) =
+	 if Vector.length from = Vector.length to
+	    then Vector.foreach2 (from, to, fn (from, to) =>
+				  coerce {from = from, to = to})
+	 else Error.bug (concat ["coerces length mismatch: ", msg])
       val {get = value: Var.t -> 'a, set = setValue, ...} =
 	 Property.getSetOnce
 	 (Var.plist,
@@ -60,7 +62,7 @@
 			shouldRaises: 'a vector option): unit =
 	(case t of
 	    Arith {prim, args, overflow, success, ty} =>
-	       (coerces (Vector.new0 (), labelValues overflow)
+	       (coerces ("arith", Vector.new0 (), labelValues overflow)
 		; coerce {from = primApp {prim = prim,
 					  targs = Vector.new0 (),
 					  args = values args,
@@ -71,14 +73,14 @@
 	  | Call {func = f, args, return, ...} =>
 	       let
 		  val {args = formals, raises, returns} = func f
-		  val _ = coerces (values args, formals)
+		  val _ = coerces ("formals", values args, formals)
 		  fun noHandler () =
 		     case (raises, shouldRaises) of
 			(NONE, NONE) => ()
 		      | (NONE, SOME _) => ()
 		      | (SOME _, NONE) => 
 			   Error.bug "raise mismatch"
-		      | (SOME vs, SOME vs') => coerces (vs, vs')
+		      | (SOME vs, SOME vs') => coerces ("noHandler", vs, vs')
 		  datatype z = datatype Return.t
 	       in
 		  case return of
@@ -88,7 +90,7 @@
 			else ()
 		   | NonTail {cont, handler} => 
 		        (Option.app (returns, fn vs =>
-				     coerces (vs, labelValues cont))
+				     coerces ("returns", vs, labelValues cont))
 			 ; (case handler of
 			       Handler.Caller => noHandler ()
 			     | Handler.Dead =>
@@ -100,7 +102,9 @@
 				     val _ =
 				        case raises of
 					   NONE => ()
-					 | SOME vs => coerces (vs, labelValues h)
+					 | SOME vs =>
+					      coerces ("handle", vs,
+						       labelValues h)
 				  in
 				     ()
 				  end))
@@ -113,7 +117,8 @@
 			       | (NONE, SOME _) => ()
 			       | (SOME _, NONE) =>
 				    Error.bug "return mismatch at Tail"
-			       | (SOME vs, SOME vs') => coerces (vs, vs')
+			       | (SOME vs, SOME vs') =>
+				    coerces ("tail", vs, vs')
 			in
 			   ()
 			end
@@ -142,15 +147,15 @@
 		  val _ = Option.app (default, ensureNullary)
 	       in ()
 	       end
-	  | Goto {dst, args} => coerces (values args, labelValues dst)
+	  | Goto {dst, args} => coerces ("goto", values args, labelValues dst)
 	  | Raise xs =>
 	       (case shouldRaises of
 		   NONE => raise Fail "raise mismatch at raise"
-		 | SOME vs => coerces (values xs, vs))
+		 | SOME vs => coerces ("raise", values xs, vs))
 	  | Return xs =>
 	       (case shouldReturns of
 		   NONE => raise Fail "return mismatch at return"
-		 | SOME vs => coerces (values xs, vs))
+		 | SOME vs => coerces ("return", values xs, vs))
 	  | Runtime {prim, args, return} =>
 	       let
 		  val xts = labelArgs return
@@ -230,7 +235,7 @@
 			       (case exn of 
 				   Fail msg => msg
 				 | _ => "")])
-      val _ = coerces (Vector.new0 (), #args (func main))
+      val _ = coerces ("main", Vector.new0 (), #args (func main))
       val _ = Vector.foreach (globals, loopStatement)
       val _ =
 	 List.foreach



1.12      +4 -0      mlton/mlton/ssa/direct-exp.fun

Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- direct-exp.fun	2 Jan 2003 17:45:20 -0000	1.11
+++ direct-exp.fun	10 Jan 2003 18:36:13 -0000	1.12
@@ -47,6 +47,7 @@
 	       targs: Type.t vector,
 	       args: t vector,
 	       ty: Type.t}
+ | Profile of ProfileExp.t
  | Raise of t
  | Runtime of {args: t vector,
 	       prim: Prim.t,
@@ -77,6 +78,7 @@
 val handlee = Handle
 val lett = Let
 val name = Name
+val profile = Profile
 val raisee = Raise
 val select = Select
 val seq = Seq
@@ -186,6 +188,7 @@
        | Name _ => str "Name"
        | PrimApp {prim, targs, args, ty} =>
 	    Prim.layoutApp (prim, args, layout)
+       | Profile e => ProfileExp.layout e
        | Raise e => seq [str "raise ", layout e]
        | Runtime {args, prim, ...} =>
 	    Prim.layoutApp (prim, args, layout)
@@ -532,6 +535,7 @@
 		Cont.sendExp (k, ty, Exp.PrimApp {prim = prim,
 						  targs = targs,
 						  args = xs}))
+	  | Profile e => Cont.sendExp (k, Type.unit, Exp.Profile e)
 	  | Raise e =>
 	       loopf (e, h, fn (x, _) =>
 		      {statements = [],



1.11      +2 -1      mlton/mlton/ssa/direct-exp.sig

Index: direct-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- direct-exp.sig	2 Jan 2003 17:45:20 -0000	1.10
+++ direct-exp.sig	10 Jan 2003 18:36:13 -0000	1.11
@@ -71,7 +71,8 @@
 	   val primApp: {args: t vector,
 			 prim: Prim.t,
 			 targs: Type.t vector, 
-			 ty: Type.t} -> t 
+			 ty: Type.t} -> t
+	   val profile: ProfileExp.t -> t
 	   val raisee: t -> t
 	   val select: {tuple: t, 
 			offset: int, 



1.5       +10 -1     mlton/mlton/ssa/flat-lattice.fun

Index: flat-lattice.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flat-lattice.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- flat-lattice.fun	16 Apr 2002 12:10:53 -0000	1.4
+++ flat-lattice.fun	10 Jan 2003 18:36:13 -0000	1.5
@@ -37,7 +37,7 @@
 fun new () = T {lessThan = ref [],
 		upperBound = ref NONE,
 		value = ref Bottom}
-
+   
 val isBottom =
    fn (T {value = ref Bottom, ...}) => true
     | _ => false
@@ -51,6 +51,11 @@
    fn (T {value = ref Top, ...}) => true
     | _ => false
 
+fun forceTop (T {upperBound, value, ...}): bool =
+   if isSome (!upperBound)
+      then false
+   else (value := Top; true)
+   
 fun up (T {lessThan, upperBound, value, ...}, e: Elt.t): bool =
    let
       fun continue e = List.forall (!lessThan, fn z => up (z, e))
@@ -76,6 +81,10 @@
    fn (T {lessThan, value, ...}, e) =>
    (List.push (lessThan, e)
     ; up (e, !value))
+
+val op <= =
+   Trace.trace2 ("FlatLattice.<=", layout, layout, Bool.layout)
+   (op <=)
 
 fun lowerBound (e, p): bool = up (e, Point p)
 



1.4       +1 -0      mlton/mlton/ssa/flat-lattice.sig

Index: flat-lattice.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flat-lattice.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- flat-lattice.sig	16 Apr 2002 12:10:53 -0000	1.3
+++ flat-lattice.sig	10 Jan 2003 18:36:13 -0000	1.4
@@ -24,6 +24,7 @@
 
       val <= : t * t -> bool
       val forcePoint: t * Point.t -> bool
+      val forceTop: t -> bool
       val layout: t -> Layout.t
       val lowerBound: t * Point.t -> bool
       val new: unit -> t



1.12      +8 -6      mlton/mlton/ssa/flatten.fun

Index: flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flatten.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- flatten.fun	2 Jan 2003 17:45:20 -0000	1.11
+++ flatten.fun	10 Jan 2003 18:36:13 -0000	1.12
@@ -123,8 +123,11 @@
 
       fun doitStatement (Statement.T {var, ty, exp}) =
 	 case exp of
-	    Tuple xs => setVarInfo (valOf var, {rep = Rep.new (),
-						tuple = ref (SOME xs)})
+	    Tuple xs =>
+	       Option.app
+	       (var, fn var =>
+		setVarInfo (var, {rep = Rep.new (),
+				  tuple = ref (SOME xs)}))
 	  | ConApp {con, args} => coerces (args, conArgs con)
 	  | Var x => setVarInfo (valOf var, varInfo x)
 	  | _ => ()
@@ -384,12 +387,9 @@
 			cases = Cases.Con cases,
 			default = default}
 	       end 
-
 	    fun doitTransfer transfer =
 	       case transfer of
-		  Return xs => Return (flattens (xs, valOf returnsReps))
-		| Raise xs => Raise (flattens (xs, valOf raisesReps))
-		| Call {func, args, return} =>
+		  Call {func, args, return} =>
 		     Call {func = func, 
 			   args = flattens (args, funcArgs func),
 			   return = return}
@@ -400,6 +400,8 @@
 		| Goto {dst, args} =>
 		     Goto {dst = dst,
 			   args = flattens (args, labelArgs dst)}
+		| Raise xs => Raise (flattens (xs, valOf raisesReps))
+		| Return xs => Return (flattens (xs, valOf returnsReps))
 		| _ => transfer
 
 	    fun doitBlock (Block.T {label, args, statements, transfer}) =



1.27      +123 -79   mlton/mlton/ssa/shrink.fun

Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- shrink.fun	2 Jan 2003 17:45:21 -0000	1.26
+++ shrink.fun	10 Jan 2003 18:36:13 -0000	1.27
@@ -137,8 +137,10 @@
 		  default: Label.t option}
        | Goto of {dst: t,
 		  args: Positions.t}
-       | Raise of Positions.t
-       | Return of Positions.t
+       | Raise of {args: Positions.t,
+		   canMove: Statement.t list}
+       | Return of {args: Positions.t,
+		    canMove: Statement.t list}
 
       local
 	 fun make f (T r) = f r
@@ -160,11 +162,11 @@
 		  | Goto {dst, args} =>
 		       seq [str "Goto ",
 			    tuple [layout dst, Positions.layout args]]
-		  | Raise ps => seq [str "Raise ", Positions.layout ps]
-		  | Return ps => seq [str "Return ", Positions.layout ps]]
+		  | Raise {args, ...} =>
+		       seq [str "Raise ", Positions.layout args]
+		  | Return {args, ...} =>
+		       seq [str "Return ", Positions.layout args]]
 	 end
-
-
    end
 
 structure State =
@@ -312,9 +314,9 @@
 	    let
 	       val block as Block.T {label, args, statements, transfer, ...} =
 		  Vector.sub (blocks, i)
-	       val _ = Vector.foreach
-		       (args, fn (x, ty) =>
-			setVarInfo (x, VarInfo.new (x, SOME ty)))
+	       val _ =
+		  Vector.foreach (args, fn (x, ty) =>
+				  setVarInfo (x, VarInfo.new (x, SOME ty)))
 	       val _ =
 		  Vector.foreach
 		  (statements, fn s => Exp.foreachVar (Statement.exp s, incVar))
@@ -337,6 +339,32 @@
 				  blockIndex = i,
 				  label = Block.label (Vector.sub (blocks, i))}
 	       fun normal () = doit LabelMeaning.Block
+	       fun rr (xs: Var.t vector, make) =
+		  let
+		     val _ = incVars xs
+		     val n = Vector.length statements
+		     fun loop (i, ac) =
+			if i = n
+			   then
+			      if 0 = Vector.length xs
+				 orelse 0 < Vector.length args
+				 then doit (make {args = extract xs,
+						  canMove = rev ac})
+			      else normal ()
+			else
+			   let
+			      val s as Statement.T {exp, ...} =
+				 Vector.sub (statements, i)
+			   in
+			      if (case exp of
+				     Exp.Profile _ => true
+				   | _ => false)
+				 then loop (i + 1, s :: ac)
+			      else normal ()
+			   end
+		  in
+		     loop (0, [])
+		  end
 	    in
 	       case transfer of
 		  Arith {args, overflow, success, ...} =>
@@ -435,34 +463,20 @@
 					| Goto {dst, args} =>
 					     Goto {dst = dst,
 						   args = extract args}
-					| Raise ps => Raise (extract ps)
-					| Return ps => Return (extract ps)
+					| Raise {args, canMove} =>
+					     Raise {args = extract args,
+						    canMove = canMove}
+					| Return {args, canMove} =>
+					     Return {args = extract args,
+						     canMove = canMove}
 				 in
 				    doit a
 				 end
 			   end
 		     end
-		| Raise xs =>
-		     let
-			val _ = incVars xs
-		     in
-			if 0 = Vector.length statements
-			   andalso (0 = Vector.length xs
-				    orelse 0 < Vector.length args)
-			   then doit (LabelMeaning.Raise (extract xs))
-			else normal ()
-		     end
-		 | Return xs =>
-		      let
-			 val _ = incVars xs
-		      in
-			 if 0 = Vector.length statements
-			    andalso (0 = Vector.length xs
-				     orelse 0 < Vector.length args)
-			    then doit (LabelMeaning.Return (extract xs))
-			 else normal ()
-		      end
-		 | Runtime {args, return, ...} =>
+		| Raise xs => rr (xs, LabelMeaning.Raise)
+		| Return xs => rr (xs, LabelMeaning.Return)
+		| Runtime {args, return, ...} =>
 		     (incVars args
 		      ; incLabel return
 		      ; normal ())
@@ -476,6 +490,10 @@
 	    Trace.trace ("Shrink.indexMeaning", Int.layout, LabelMeaning.layout)
 	    indexMeaning
 	 val labelMeaning = indexMeaning o labelIndex
+	 val labelMeaning =
+	    Trace.trace ("Shrink.labelMeaning",
+			 Label.layout, LabelMeaning.layout)
+	    labelMeaning
 	 val labelIndex' = labelIndex
 	 val labelIndex = LabelMeaning.blockIndex o labelMeaning
 	 fun meaningLabel m =
@@ -703,6 +721,9 @@
 				| Position.Free x => x)
 		   val (statements, transfer) =
 		      let
+			 fun rr ({args, canMove}, make) =
+			    (canMove,
+			     make (Vector.map (args, use o extract)))
 			 datatype z = datatype LabelMeaning.aux
 		      in
 			 case aux of
@@ -711,12 +732,8 @@
 			  | Case _ => simplifyBlock block
 			  | Goto {dst, args} =>
 			       gotoMeaning (dst, Vector.map (args, extract))
-			  | Raise ps =>
-			       ([],
-				Transfer.Raise (Vector.map (ps, use o extract)))
-			  | Return ps =>
-			       ([],
-				Transfer.Return (Vector.map (ps, use o extract)))
+			  | Raise z => rr (z, Transfer.Raise)
+			  | Return z => rr (z, Transfer.Return)
 		      end
 		   val _ =
 		      List.push
@@ -791,34 +808,25 @@
 	     | Bug => ([], Bug)
 	     | Call {func, args, return} =>
 		  let
-		     val return =
+		     val (statements, return) =
 			case return of
 			   Return.NonTail {cont, handler} =>
 			      let
+				 fun isEta (m: LabelMeaning.t,
+					    ps: Position.t vector): bool =
+				    Vector.length ps
+				    = (Vector.length
+				       (Block.args
+					(Vector.sub
+					 (blocks, LabelMeaning.blockIndex m))))
+				    andalso
+				    Vector.foralli
+				    (ps,
+				     fn (i, Position.Formal i') => i = i'
+				      | _ => false)
 				 val m = labelMeaning cont
 				 val i = LabelMeaning.blockIndex m
-				 val isTail =
-				    (case handler of
-					Handler.Caller => true
-				      | Handler.Dead => true
-				      | Handler.Handle _ => false)
-                                    andalso 
-				    (case LabelMeaning.aux m of
-					LabelMeaning.Bug => true
-				      | LabelMeaning.Return ps =>
-					   Vector.length ps =
-					   (Vector.length
-					    (Block.args (Vector.sub (blocks, i))))
-					   andalso
-					   Vector.foralli
-					   (ps,
-					    fn (i, Position.Formal i') => i = i'
-					     | _ => false)
-				      | _ => false)
-			      in
-				 if isTail
-				    then (deleteLabelMeaning m; Return.Tail)
-				 else
+				 fun nonTail () =
 				    let
 				       val _ = forceMeaningBlock m
 				       val handler =
@@ -831,15 +839,48 @@
 					      meaningLabel m
 					   end)
 				    in
-				       Return.NonTail {cont = meaningLabel m,
-						       handler = handler}
+				       ([],
+					Return.NonTail {cont = meaningLabel m,
+							handler = handler})
 				    end
+				 fun tail statements =
+				    (deleteLabelMeaning m
+				     ; (statements, Return.Tail))
+				 fun cont (handlerIsEta: bool) =
+				    case LabelMeaning.aux m of
+				       LabelMeaning.Bug =>
+					  if handlerIsEta
+					     then nonTail ()
+					  else tail []
+				     | LabelMeaning.Return {args, canMove} =>
+					  if isEta (m, args)
+					     then tail canMove
+					  else nonTail ()
+				     | _ => nonTail ()
+
+			      in
+				 case handler of
+				    Handler.Caller => cont false
+				  | Handler.Dead => cont false
+				  | Handler.Handle l =>
+				       let
+					  val m = labelMeaning l
+				       in
+					  case LabelMeaning.aux m of
+					     LabelMeaning.Bug => cont false
+					   | LabelMeaning.Raise {args, ...} =>
+						if isEta (m, args)
+						   then cont true
+						else nonTail ()
+					   | _ => nonTail ()
+				       end
 			      end
-			 | _ => return
+			 | _ => ([], return)
 		  in 
-		     ([], Call {func = func,
-				args = simplifyVars args,
-				return = return})
+		     (statements,
+		      Call {func = func,
+			    args = simplifyVars args,
+			    return = return})
 		  end
 	      | Case {test, cases, default} =>
 		   let
@@ -905,9 +946,13 @@
 						    (Vector.sub (blocks, i)))
 			    | Bug => false
 			    | Goto {args, ...} => Positions.usesFormal args
-			    | Raise ps => Positions.usesFormal ps
-			    | Return ps => Positions.usesFormal ps
+			    | Raise {args, ...} => Positions.usesFormal args
+			    | Return {args, ...} => Positions.usesFormal args
 			    | _ => true
+			fun rr ({args = a, canMove = c},
+				{args = a', canMove = c'}) =
+			   Positions.equals (a, a')
+			   andalso List.equals (c, c', Statement.equals)
 			fun equals (m: t, m': t): bool =
 			   case (aux m, aux m') of
 			      (Block, Block) => blockIndex m = blockIndex m'
@@ -916,8 +961,8 @@
 			       Goto {dst = dst', args = args'}) =>
 				 equals (dst, dst')
 				 andalso Positions.equals (args, args')
-			    | (Raise ps, Raise ps') => Positions.equals (ps, ps')
-			    | (Return ps, Return ps') => Positions.equals (ps, ps')
+			    | (Raise z, Raise z') => rr (z, z')
+			    | (Return z, Return z') => rr (z, z')
 			    | _ => false
 		     end
 		     fun isOk (l: Label.t): bool =
@@ -1033,6 +1078,8 @@
 		   case p of
 		      Position.Formal n => Vector.sub (args, n)
 		    | Position.Free x => varInfo x
+		fun rr ({args, canMove}, make) =
+		   (canMove, make (Vector.map (args, use o extract)))
 		datatype z = datatype LabelMeaning.aux
 	     in
 		case aux of
@@ -1059,10 +1106,8 @@
 			 in
 			    gotoMeaning (dst, Vector.map (args, extract))
 			 end
-		 | Raise ps =>
-		      ([], Transfer.Raise (Vector.map (ps, use o extract)))
-		 | Return ps =>
-		      ([], Transfer.Return (Vector.map (ps, use o extract)))
+		 | Raise z => rr (z, Transfer.Raise)
+		 | Return z => rr (z, Transfer.Return)
 	     end) arg
 	 and evalStatement arg : Statement.t list -> Statement.t list =
 	    traceEvalStatement
@@ -1208,7 +1253,8 @@
                         case DynamicWind.withEscape
 			     (fn escape =>
 			      Vector.foldri
-			      (xs, NONE, fn (i, VarInfo.T {value, ...}, tuple') => 
+			      (xs, NONE,
+			       fn (i, VarInfo.T {value, ...}, tuple') => 
 			       case !value of
 				  SOME (Value.Select {offset, tuple}) =>
 				     if offset = i
@@ -1316,9 +1362,7 @@
       end
 
 val traceShrinkFunction =
-   Trace.trace ("Shrink.shrinkFunction",
-		Func.layout o Function.name,
-		Func.layout o Function.name)
+   Trace.trace ("Shrink.shrinkFunction", Function.layout, Function.layout)
 
 val shrinkFunction =
    fn g =>



1.32      +0 -5      mlton/mlton/ssa/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/sources.cm,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- sources.cm	2 Jan 2003 17:45:21 -0000	1.31
+++ sources.cm	10 Jan 2003 18:36:14 -0000	1.32
@@ -8,9 +8,7 @@
 Group
 
 signature HANDLER
-signature PROFILE_EXP
 signature RETURN
-signature SOURCE_INFO
 signature SSA
 
 functor FlatLattice
@@ -60,7 +58,6 @@
 n-point-lattice.sig
 poly-equal.fun
 poly-equal.sig
-profile-exp.sig
 redundant.fun
 redundant.sig
 redundant-tests.fun
@@ -75,8 +72,6 @@
 simplify.sig
 simplify-types.fun
 simplify-types.sig
-source-info.fun
-source-info.sig
 ssa-tree.fun
 ssa-tree.sig
 ssa.fun



1.52      +28 -38    mlton/mlton/ssa/ssa-tree.fun

Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- ssa-tree.fun	2 Jan 2003 17:45:21 -0000	1.51
+++ ssa-tree.fun	10 Jan 2003 18:36:14 -0000	1.52
@@ -10,8 +10,6 @@
 
 open S
 
-structure SourceInfo = SourceInfo ()
-
 structure Type =
    struct
       local structure T = HashType (S)
@@ -148,36 +146,6 @@
 			  xs)
    end
 
-structure ProfileExp =
-   struct
-      structure SourceInfo = SourceInfo
-
-      datatype t =
-	 Enter of SourceInfo.t
-       | Leave of SourceInfo.t
-
-      val toString =
-	 fn Enter si => concat ["Enter ", SourceInfo.toString si]
-	  | Leave si => concat ["Leave " , SourceInfo.toString si]
-
-      val layout = Layout.str o toString
-
-      val equals =
-	 fn (Enter si, Enter si') => SourceInfo.equals (si, si')
-	  | (Leave si, Leave si') => SourceInfo.equals (si, si')
-	  | _ => false
-
-      local
-	 val newHash = Random.word
-	 val enter = newHash ()
-	 val leave = newHash ()
-      in
-	 val hash =
-	    fn Enter si => Word.xorb (enter, SourceInfo.hash si)
-	     | Leave si => Word.xorb (leave, SourceInfo.hash si)
-      end
-   end
-
 structure Exp =
    struct
       datatype t =
@@ -393,14 +361,31 @@
 
       val toString = Layout.toString o layout
 
+      fun equals (T {exp = e, ty = t, var = v},
+		  T {exp = e', ty = t', var = v'}): bool =
+	 Option.equals (v, v', Var.equals)
+	 andalso Type.equals (t, t')
+	 andalso Exp.equals (e, e')
+
+      local
+	 fun make f x =
+	    T {var = NONE,
+	       ty = Type.unit,
+	       exp = f x}
+      in
+	 val profile = make Exp.Profile
+      end
+
       local
-	 fun make (e: Exp.t) =
+	 fun make f x =
 	    T {var = NONE,
 	       ty = Type.unit,
-	       exp = e}
+	       exp = if !Control.handlers = Control.PushPop
+			then f x
+		     else Exp.unit}
       in
-	 fun handlerPop h = make (Exp.HandlerPop h)
-	 fun handlerPush h = make (Exp.HandlerPush h)
+	 val handlerPop = make Exp.HandlerPop
+	 val handlerPush = make Exp.HandlerPush
       end
 
       fun clear s = Option.app (var s, Var.clear)
@@ -1395,6 +1380,7 @@
 
       fun profile (f: t, sourceInfo): t =
 	 if !Control.profile = Control.ProfileNone
+	    orelse !Control.profileIL <> Control.ProfileSSA
 	    then f
 	 else 
 	 let
@@ -1453,8 +1439,8 @@
 			    let
 			       val xs = Vector.map (ts, fn _ => Var.newNoname ())
 			       val l = Label.newNoname ()
-			       val pop = make (HandlerPop l)
-			       val push = make (HandlerPush l)
+			       val pop = Statement.handlerPop l
+			       val push = Statement.handlerPush l
 			       val _ =
 				  List.push
 				  (extraBlocks,
@@ -1523,6 +1509,10 @@
 	 in
 	    f
 	 end
+
+      val profile =
+	 Trace.trace2 ("Ssa.Function.profile", layout, SourceInfo.layout, layout)
+	 profile
    end
 
 structure Program =



1.43      +2 -4      mlton/mlton/ssa/ssa-tree.sig

Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- ssa-tree.sig	2 Jan 2003 17:45:21 -0000	1.42
+++ ssa-tree.sig	10 Jan 2003 18:36:14 -0000	1.43
@@ -56,8 +56,6 @@
    sig
       include SSA_TREE_STRUCTS
 
-      structure SourceInfo: SOURCE_INFO
-	 
       structure Type:
 	 sig
 	    include HASH_TYPE
@@ -85,8 +83,6 @@
 
       structure Func: HASH_ID
       structure Label: LABEL
-      structure ProfileExp: PROFILE_EXP
-      sharing SourceInfo = ProfileExp.SourceInfo
       
       structure Exp:
 	 sig
@@ -128,11 +124,13 @@
 			       exp: Exp.t}
 
 	    val clear: t -> unit (* clear the var *)
+	    val equals: t * t -> bool
 	    val exp: t -> Exp.t
 	    val handlerPop: Label.t -> t
 	    val handlerPush: Label.t -> t
 	    val layout: t -> Layout.t
 	    val prettifyGlobals: t vector -> (Var.t -> string option)
+	    val profile: ProfileExp.t -> t
 	    val var: t -> Var.t option
 	 end
       



1.21      +25 -1     mlton/mlton/ssa/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- type-check.fun	2 Jan 2003 17:45:21 -0000	1.20
+++ type-check.fun	10 Jan 2003 18:36:15 -0000	1.21
@@ -307,7 +307,7 @@
 	 end
    end
 
-fun checkHandlers (program as Program.T {datatypes, functions, ...}): unit =
+fun checkHandlers (program as Program.T {functions, ...}): unit =
    let
       fun checkFunction (f: Function.t): unit =
 	 let
@@ -425,6 +425,30 @@
    in
       ()
    end
+
+val checkHandlers =
+   fn p =>
+   if !Control.handlers = Control.PushPop
+      then checkHandlers p
+   else let
+	   val Program.T {functions, ...} = p
+	in
+	   List.foreach (functions, fn f =>
+			 let
+			    val {blocks, ...} = Function.dest f
+			 in
+			    Vector.foreach
+			    (blocks, fn Block.T {statements, ...} =>
+			     Vector.foreach
+			     (statements, fn Statement.T {exp, ...} =>
+			      if (case exp of
+				     Exp.HandlerPop _ => true
+				   | Exp.HandlerPush _ => true
+				   | _ => false)
+				 then Error.bug "superfluous HandlerPush/Pop"
+			      else ()))
+			 end)
+	end
 
 val checkHandlers = Control.trace (Control.Pass, "checkHandlers") checkHandlers
 



1.18      +46 -19    mlton/mlton/type-inference/infer.fun

Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- infer.fun	12 Dec 2002 01:14:23 -0000	1.17
+++ infer.fun	10 Jan 2003 18:36:15 -0000	1.18
@@ -527,6 +527,7 @@
 				{tuple = Xexp.monoVar (arg, argType),
 				 components = vars,
 				 body = e}),
+			       bodyType = caseType,
 			       region = region})}
 			 fun finish rename =
 			    Xexp.app
@@ -645,6 +646,7 @@
 						     resultType))]),
 			     caseType = resultType,
 			     region = region})),
+	     bodyType = resultType,
 	     region = region}
 	 end
       fun forceRulesMatch (rs, region) =
@@ -891,9 +893,28 @@
 			   {tyvars = bound (),
 			    decs = (Vector.map
 				    (decs, fn {var, region, rules, ty} =>
-				     {var = var,
-				      ty = Type.toXml (ty, region),
-				      lambda = forceRulesMatch (rules, region)}))}]),
+				     let
+					val {arg, argType, body, bodyType,
+					     ...} =
+					   Xlambda.dest
+					   (forceRulesMatch (rules, region))
+					val body =
+					   Xml.Exp.enterLeave
+					   (body,
+					    bodyType,
+					    SourceInfo.fromRegion region)
+					val lambda =
+					   Xlambda.new
+					   {arg = arg,
+					    argType = argType,
+					    body = body,
+					    bodyType = bodyType,
+					    region = region}
+				     in
+					{var = var,
+					 ty = Type.toXml (ty, region),
+					 lambda = lambda}
+				     end))}]),
 		    env)
 		end
 	   | Cdec.Overload {var, scheme = CoreML.Scheme.T {tyvars, ty}, ovlds} =>
@@ -923,7 +944,6 @@
       (*------------------------------------*)
       (*              inferExp              *)
       (*------------------------------------*)
-
       and inferExp arg: expCode =
 	 traceInferExp
 	 (fn (e, env) =>
@@ -977,18 +997,22 @@
 		   let
 		      val rs as {argType, resultType, rules, ...} =
 			 inferMatch (m, env)
-		   in (fn () =>
+		   in
+		      (fn () =>
 		       let
 			  val {arg, argType, body, ...} =
 			     Xlambda.dest (forceRulesMatch (rs, region))
 			  val resultType = Type.toXml (resultType, region)
+			  val body =
+			     Xml.Exp.enterLeave (body,
+						 resultType,
+						 SourceInfo.fromRegion region)
 		       in
-			  Xexp.lambda
-			  {arg = arg,
-			   argType = argType,
-			   body = Xexp.fromExp (body, resultType),
-			   bodyType = resultType,
-			   region = region}
+			  Xexp.lambda {arg = arg,
+				       argType = argType,
+				       body = Xexp.fromExp (body, resultType),
+				       bodyType = resultType,
+				       region = region}
 		       end,
 		       Type.arrow (argType, resultType),
 		       region)
@@ -1093,7 +1117,15 @@
 		     end
 	 in
 	    case Cexp.node e1 of
-	       Cexp.Con con =>
+	       Cexp.App (e1, e2) =>
+		  let
+		     val e = apply (e1, env, SOME (inferExp (e2, env)))
+		  in
+		     case arg of
+			NONE => e
+		      | SOME e' => applyOne (e, e')
+		  end
+	     | Cexp.Con con =>
 		  let
 		     val {instance, args} = instCon con
 		  in
@@ -1117,7 +1149,8 @@
 		  let
 		     val {instance, args = targs} =
 			instantiatePrim (Prim.scheme prim, region)
-		  in eta (instance, fn (arg, resultType) =>
+		  in
+		     eta (instance, fn (arg, resultType) =>
 			  let
 			     fun constant c =
 				let
@@ -1161,12 +1194,6 @@
 				   (* FIXME -- should use Control.error? *)
 				   Error.bug "primApp mismatch"
 			  end)
-		  end
-	     | Cexp.App (e1, e2) =>
-		  let val e = apply (e1, env, SOME (inferExp (e2, env)))
-		  in case arg of
-		     NONE => e
-		   | SOME e' => applyOne (e, e')
 		  end
 	     | _ =>
 		  let val e1 = inferExp (e1, env)



1.6       +132 -130  mlton/mlton/xml/implement-exceptions.fun

Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- implement-exceptions.fun	12 Dec 2002 01:14:23 -0000	1.5
+++ implement-exceptions.fun	10 Jan 2003 18:36:15 -0000	1.6
@@ -289,143 +289,144 @@
 	    fun makeExp e = Dexp.vall {var = var, exp = e}
 	 in
 	    case exp of
-	    Lambda l => primExp (Lambda (loopLambda l))
-	  | PrimApp {prim, targs, args} =>
-	       let
-		  datatype z = datatype Prim.Name.t
-		  fun assign (var, ty) =
-		     primExp
-		     (PrimApp {prim = Prim.assign,
-			       targs = Vector.new1 ty,
-			       args = Vector.new2 (VarExp.mono var,
-						   Vector.sub (args, 0))})
-	       in
-		  case Prim.name prim of
-		     Exn_extra => makeExp (extra (VarExp.var
-						  (Vector.sub (args, 0))))
-		   | Exn_name =>
-			primExp (App {func = VarExp.mono exnName,
-				      arg = Vector.sub (args, 0)})
-		   | Exn_setExtendExtra => []
-		   | Exn_setInitExtra => []
-		   | Exn_setTopLevelHandler =>
-			assign (topLevelHandler,
-				Type.arrow (Type.exn, Type.unit))
-		   | _ => primExp exp
-	       end
-	  | ConApp {con, arg, ...} =>
-	       (case exconInfo con of
-		   NONE => keep ()
-		 | SOME {make, ...} => makeExp (make arg))
-	  | Handle {try, catch = (catch, ty), handler} =>
-	       primExp (Handle {try = loop try,
-				catch = (catch, ty),
-				handler = loop handler})
-	  | Case {test, cases, default} =>
-	       let
-		  fun normal () =
-		     primExp (Case {cases = Cases.map (cases, loop),
-				    default = Option.map (default, fn (e, r) =>
-							  (loop e, r)),
-				    test = test})
-	       in
-		  case cases of
-		     Cases.Con cases =>
-			if Vector.isEmpty cases
-			   then normal ()
-			else
-			   let
-			      val (Pat.T {con, ...}, _) = Vector.sub (cases, 0)
-			   in
-			      if not (isExcon con)
-				 then normal ()
-			      else (* convert to an exception match *)
-				 let
-				    open Dexp
-				    val defaultVar = Var.newString "default"
-				    fun callDefault () =
-				       app {func = monoVar (defaultVar,
-							    Type.arrow (Type.unit, ty)),
-					    arg = unit (),
-					    ty = ty}
-				    val unit = Var.newString "unit"
-				    val (body, region) =
-				       case default of
-					  NONE =>
-					     Error.bug "no default for exception case"
-					| SOME (e, r) =>
-					     (fromExp (loop e, ty), r)
-				    val decs =
-				       vall
-				       {var = defaultVar,
-					exp = lambda {arg = unit,
-						      argType = Type.unit,
-						      bodyType = ty,
-						      body = body,
-						      region = region}}
-				 in makeExp
-				    (lett
-				     {decs = decs,
-				      body =
-				      extract
-				      (VarExp.var test, ty, fn tuple =>
-				       casee
-				       {test = extractSum tuple,
-					ty = ty,
-					default = SOME (callDefault (), region),
-					cases =
-					Cases.Con
-					(Vector.map
-					 (cases, fn (Pat.T {con, arg, ...}, e) =>
-					  let
-					     val refVar = Var.newNoname ()
-					     val body =
-						iff {test =
-						     equal
-						     (monoVar
-						      (refVar, Type.unitRef),
-						      monoVar
-						      (#refVar (valOf (exconInfo con)),
-						       Type.unitRef)),
-						     ty = ty,
-						     thenn = fromExp (loop e, ty),
-						     elsee = callDefault ()}
-					     fun make (arg, body) = 
-						(Pat.T {con = con,
-							targs = Vector.new0 (),
-							arg = SOME arg},
-						 body)
-					  in case arg of
-					     NONE => make ((refVar, Type.unitRef), body)
-					   | SOME (x, t) =>
-						let
-						   val tuple =
-						      (Var.newNoname (),
-						       Type.tuple (Vector.new2
-								   (Type.unitRef, t)))
-						in make (tuple,
-							 detupleBind
-							 {tuple = monoVar tuple,
-							  components =
-							  Vector.new2 (refVar, x),
-							  body = body})
-						end
-					  end))})})
-				 end
-			   end
-		   | _ => normal ()
-	       end
-          | Raise {exn, filePos} =>
-	       raisee {var = var, ty = ty, exn = exn, filePos = filePos}
-	  | _ => keep ()
+	       Case {test, cases, default} =>
+		  let
+		     fun normal () =
+			primExp (Case {cases = Cases.map (cases, loop),
+				       default = Option.map (default, fn (e, r) =>
+							     (loop e, r)),
+				       test = test})
+		  in
+		     case cases of
+			Cases.Con cases =>
+			   if Vector.isEmpty cases
+			      then normal ()
+			   else
+			      let
+				 val (Pat.T {con, ...}, _) = Vector.sub (cases, 0)
+			      in
+				 if not (isExcon con)
+				    then normal ()
+				 else (* convert to an exception match *)
+				    let
+				       open Dexp
+				       val defaultVar = Var.newString "default"
+				       fun callDefault () =
+					  app {func = monoVar (defaultVar,
+							       Type.arrow (Type.unit, ty)),
+					       arg = unit (),
+					       ty = ty}
+				       val unit = Var.newString "unit"
+				       val (body, region) =
+					  case default of
+					     NONE =>
+						Error.bug "no default for exception case"
+					   | SOME (e, r) =>
+						(fromExp (loop e, ty), r)
+				       val decs =
+					  vall
+					  {var = defaultVar,
+					   exp = lambda {arg = unit,
+							 argType = Type.unit,
+							 bodyType = ty,
+							 body = body,
+							 region = region}}
+				    in makeExp
+				       (lett
+					{decs = decs,
+					 body =
+					 extract
+					 (VarExp.var test, ty, fn tuple =>
+					  casee
+					  {test = extractSum tuple,
+					   ty = ty,
+					   default = SOME (callDefault (), region),
+					   cases =
+					   Cases.Con
+					   (Vector.map
+					    (cases, fn (Pat.T {con, arg, ...}, e) =>
+					     let
+						val refVar = Var.newNoname ()
+						val body =
+						   iff {test =
+							equal
+							(monoVar
+							 (refVar, Type.unitRef),
+							 monoVar
+							 (#refVar (valOf (exconInfo con)),
+							  Type.unitRef)),
+							ty = ty,
+							thenn = fromExp (loop e, ty),
+							elsee = callDefault ()}
+						fun make (arg, body) = 
+						   (Pat.T {con = con,
+							   targs = Vector.new0 (),
+							   arg = SOME arg},
+						    body)
+					     in case arg of
+						NONE => make ((refVar, Type.unitRef), body)
+					      | SOME (x, t) =>
+						   let
+						      val tuple =
+							 (Var.newNoname (),
+							  Type.tuple (Vector.new2
+								      (Type.unitRef, t)))
+						   in make (tuple,
+							    detupleBind
+							    {tuple = monoVar tuple,
+							     components =
+							     Vector.new2 (refVar, x),
+							     body = body})
+						   end
+					     end))})})
+				    end
+			      end
+		      | _ => normal ()
+		  end
+	     | ConApp {con, arg, ...} =>
+		  (case exconInfo con of
+		      NONE => keep ()
+		    | SOME {make, ...} => makeExp (make arg))
+	     | Handle {try, catch = (catch, ty), handler} =>
+		  primExp (Handle {try = loop try,
+				   catch = (catch, ty),
+				   handler = loop handler})
+	     | Lambda l => primExp (Lambda (loopLambda l))
+	     | PrimApp {prim, targs, args} =>
+		  let
+		     datatype z = datatype Prim.Name.t
+		     fun assign (var, ty) =
+			primExp
+			(PrimApp {prim = Prim.assign,
+				  targs = Vector.new1 ty,
+				  args = Vector.new2 (VarExp.mono var,
+						      Vector.sub (args, 0))})
+		  in
+		     case Prim.name prim of
+			Exn_extra => makeExp (extra (VarExp.var
+						     (Vector.sub (args, 0))))
+		      | Exn_name =>
+			   primExp (App {func = VarExp.mono exnName,
+					 arg = Vector.sub (args, 0)})
+		      | Exn_setExtendExtra => primExp (Tuple (Vector.new0 ()))
+		      | Exn_setInitExtra => primExp (Tuple (Vector.new0 ()))
+		      | Exn_setTopLevelHandler =>
+			   assign (topLevelHandler,
+				   Type.arrow (Type.exn, Type.unit))
+		      | _ => primExp exp
+		  end
+	     | Raise {exn, filePos} =>
+		  raisee {var = var, ty = ty, exn = exn, filePos = filePos}
+	     | _ => keep ()
 	 end
       and loopLambda l =
 	 let
-	    val {arg, argType, body, region} = Lambda.dest l
+	    val {arg, argType, body, bodyType, region} = Lambda.dest l
 	 in
 	    Lambda.new {arg = arg,
 			argType = argType,
 			body = loop body,
+			bodyType = bodyType,
 			region = region}
 	 end
       val body =
@@ -500,6 +501,7 @@
 				 default = NONE,
 				 ty = Type.string}))
 			   end,
+			   bodyType = Type.string,
 			   region = Region.bogus})
 		       end}
 	       in



1.7       +26 -24    mlton/mlton/xml/monomorphise.fun

Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- monomorphise.fun	12 Dec 2002 01:14:23 -0000	1.6
+++ monomorphise.fun	10 Jan 2003 18:36:15 -0000	1.7
@@ -355,30 +355,8 @@
 	  end) arg
       and monoPrimExp (e: XprimExp.t): SprimExp.t =
 	 case e of
-	    XprimExp.Const c => SprimExp.Const c
-	  | XprimExp.Var x => SprimExp.Var (monoVarExp x)
-	  | XprimExp.Tuple xs => SprimExp.Tuple (monoVarExps xs)
-	  | XprimExp.Select {tuple, offset} =>
-	       SprimExp.Select {tuple = monoVarExp tuple, offset = offset}
-	  | XprimExp.Lambda l => SprimExp.Lambda (monoLambda l)
-	  | XprimExp.ConApp {con, targs, arg} =>
-	       let val con = monoCon (con, targs)
-	       in SprimExp.ConApp {con = con, targs = Vector.new0 (),
-				   arg = Option.map (arg, monoVarExp)}
-	       end
-	  | XprimExp.PrimApp {prim, targs, args} =>
-	       SprimExp.PrimApp {prim = prim,
-				 targs = monoTypes targs,
-				 args = monoVarExps args}
-	  | XprimExp.App {func, arg} =>
+	    XprimExp.App {func, arg} =>
 	       SprimExp.App {func = monoVarExp func, arg = monoVarExp arg}
-	  | XprimExp.Raise {exn, filePos} =>
-	       SprimExp.Raise {exn = monoVarExp exn,
-			       filePos = filePos}
-	  | XprimExp.Handle {try, catch, handler} =>
-	       SprimExp.Handle {try = monoExp try,
-				catch = renameMono catch,
-				handler = monoExp handler}
 	  | XprimExp.Case {test, cases, default} =>
 	       let
 		  fun doit cases =
@@ -399,14 +377,38 @@
 		   default = Option.map (default, fn (e, r) =>
 					 (monoExp e, r))}
 	       end
+	  | XprimExp.ConApp {con, targs, arg} =>
+	       let val con = monoCon (con, targs)
+	       in SprimExp.ConApp {con = con, targs = Vector.new0 (),
+				   arg = Option.map (arg, monoVarExp)}
+	       end
+	  | XprimExp.Const c => SprimExp.Const c
+	  | XprimExp.Handle {try, catch, handler} =>
+	       SprimExp.Handle {try = monoExp try,
+				catch = renameMono catch,
+				handler = monoExp handler}
+	  | XprimExp.Lambda l => SprimExp.Lambda (monoLambda l)
+	  | XprimExp.PrimApp {prim, targs, args} =>
+	       SprimExp.PrimApp {prim = prim,
+				 targs = monoTypes targs,
+				 args = monoVarExps args}
+	  | XprimExp.Profile e => SprimExp.Profile  e
+	  | XprimExp.Raise {exn, filePos} =>
+	       SprimExp.Raise {exn = monoVarExp exn,
+			       filePos = filePos}
+	  | XprimExp.Select {tuple, offset} =>
+	       SprimExp.Select {tuple = monoVarExp tuple, offset = offset}
+	  | XprimExp.Tuple xs => SprimExp.Tuple (monoVarExps xs)
+	  | XprimExp.Var x => SprimExp.Var (monoVarExp x)
       and monoLambda l: Slambda.t =
 	 let
-	    val {arg, argType, body, region} = Xlambda.dest l
+	    val {arg, argType, body, bodyType, region} = Xlambda.dest l
 	    val (arg, argType) = renameMono (arg, argType)
 	 in
 	    Slambda.new {arg = arg,
 			 argType = argType,
 			 body = monoExp body,
+			 bodyType = monoType bodyType,
 			 region = region}
 	 end
       (*------------------------------------*)



1.8       +63 -49    mlton/mlton/xml/polyvariance.fun

Index: polyvariance.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/polyvariance.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- polyvariance.fun	12 Dec 2002 01:14:23 -0000	1.7
+++ polyvariance.fun	10 Jan 2003 18:36:15 -0000	1.8
@@ -14,7 +14,8 @@
 struct
 
 open S
-open Dec PrimExp
+datatype z = datatype Dec.t
+datatype z = datatype PrimExp.t
    
 structure Type =
    struct
@@ -53,16 +54,21 @@
       and loopPrimExp (e: PrimExp.t, n: int): int =
 	 case e of
 	    Case {cases, default, ...} =>
-	       Cases.fold
-	       (cases,
-		(case default of
-		    NONE => n
-		  | SOME (e, _) => loopExp (e, n)),
-		    fn (e, n) => loopExp (e, n))
+	       let
+		  val n = n + 1
+	       in
+		  Cases.fold
+		  (cases,
+		   (case default of
+		       NONE => n
+		     | SOME (e, _) => loopExp (e, n)),
+		       fn (e, n) => loopExp (e, n))
+	       end
 	  | Handle {try, handler, ...} =>
-	       loopExp (try, loopExp (handler, n))
-	  | Lambda l => loopLambda (l, n)
-	  | _ => n
+	       loopExp (try, loopExp (handler, n + 1))
+	  | Lambda l => loopLambda (l, n + 1)
+	  | Profile _ => n
+	  | _ => n + 1
    in loopExp (body, 0)
       ; size
    end
@@ -122,25 +128,30 @@
 				  let
 				     val loopExp =
 					fn e => loopExp (e, numDuplicates)
-				  in (case exp of
-					 Const _ => ()
-				       | Var x => loopVar x
-				       | Tuple xs => loopVars xs
-				       | Select {tuple, ...} => loopVar tuple
-				       | ConApp {arg, ...} =>
-					    Option.app (arg, loopVar)
-				       | PrimApp {args, ...} => loopVars args
-				       | App {func, arg} =>
-					    (loopVar func; loopVar arg)
-				       | Raise {exn, ...} => loopVar exn
-				       | Case {test, cases, default} =>
-					    (loopVar test
-					     ; Cases.foreach (cases, loopExp)
-					     ; Option.app (default, loopExp o #1))
-				       | Handle {try, handler, ...} =>
-					    (loopExp try; loopExp handler)
-				       | _ => Error.bug "unexpected primExp")
-				     ; loopDecs decs
+				     val _ =
+					case exp of
+					   App {func, arg} =>
+					      (loopVar func; loopVar arg)
+					 | Case {test, cases, default} =>
+					      (loopVar test
+					       ; Cases.foreach (cases, loopExp)
+					       ; (Option.app
+						  (default, loopExp o #1)))
+					 | ConApp {arg, ...} =>
+					      Option.app (arg, loopVar)
+					 | Const _ => ()
+					 | Handle {try, handler, ...} =>
+					      (loopExp try; loopExp handler)
+					 | Lambda _ =>
+					      Error.bug "unexpected Lambda"
+					 | PrimApp {args, ...} => loopVars args
+					 | Profile _ => ()
+					 | Raise {exn, ...} => loopVar exn
+					 | Select {tuple, ...} => loopVar tuple
+					 | Tuple xs => loopVars xs
+					 | Var x => loopVar x
+				  in
+				     loopDecs decs
 				  end)
 		      | Fun {decs = lambdas, ...} =>
 			   let
@@ -258,11 +269,12 @@
 	 end
       and loopLambda (l: Lambda.t): Lambda.t =
 	 let
-	    val {arg, argType, body, region} = Lambda.dest l
+	    val {arg, argType, body, bodyType, region} = Lambda.dest l
 	 in
 	    Lambda.new {arg = bind arg,
 			argType = argType,
 			body = loopExp body,
+			bodyType = bodyType,
 			region = region}
 	 end
       and loopDecs (ds: Dec.t list, result): {decs: Dec.t list,
@@ -295,26 +307,9 @@
 			    let
 			       val exp =
 				  case exp of
-				     Const _ => exp
-				   | Var x => Var (loopVar x)
-				   | Tuple xs => Tuple (loopVars xs)
-				   | Select {tuple, offset} =>
-					Select {tuple = loopVar tuple,
-						offset = offset}
-				   | ConApp {con, targs, arg} =>
-					ConApp {con = con,
-						targs = targs,
-						arg = Option.map (arg, loopVar)}
-				   | PrimApp {prim, targs, args} =>
-					PrimApp {prim = prim,
-						 targs = targs,
-						 args = loopVars args}
-				   | App {func, arg} =>
+				     App {func, arg} =>
 					App {func = loopVar func,
 					     arg = loopVar arg}
-				   | Raise {exn, filePos} =>
-					Raise {exn = loopVar exn,
-					       filePos = filePos}
 				   | Case {test, cases, default} =>
 					let
 					   datatype z = datatype Cases.t
@@ -341,11 +336,30 @@
 						 (default, fn (e, r) =>
 						  (loopExp e, r))}
 					end
+				   | ConApp {con, targs, arg} =>
+					ConApp {con = con,
+						targs = targs,
+						arg = Option.map (arg, loopVar)}
+				   | Const _ => exp
 				   | Handle {try, catch, handler} =>
 					Handle {try = loopExp try,
 						catch = bindVarType catch,
 						handler = loopExp handler}
-				   | _ => Error.bug "unexpected primExp"
+				   | Lambda _ =>
+					Error.bug "unexpected Lambda"
+				   | PrimApp {prim, targs, args} =>
+					PrimApp {prim = prim,
+						 targs = targs,
+						 args = loopVars args}
+				   | Profile _ => exp
+				   | Raise {exn, filePos} =>
+					Raise {exn = loopVar exn,
+					       filePos = filePos}
+				   | Select {tuple, offset} =>
+					Select {tuple = loopVar tuple,
+						offset = offset}
+				   | Tuple xs => Tuple (loopVars xs)
+				   | Var x => Var (loopVar x)
 			       val var = bind var
 			       val {decs, result} = loopDecs (ds, result)
 			    in {decs = (MonoVal {var = var, ty = ty, exp = exp}



1.7       +12 -10    mlton/mlton/xml/scc-funs.fun

Index: scc-funs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/scc-funs.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- scc-funs.fun	12 Dec 2002 01:14:23 -0000	1.6
+++ scc-funs.fun	10 Jan 2003 18:36:15 -0000	1.7
@@ -37,34 +37,36 @@
       fun loopVarExps xs = Vector.foreach (xs, loopVarExp)
       fun loopLambda (l: Lambda.t): Lambda.t =
 	 let
-	    val {arg, argType, body, region} = Lambda.dest l
+	    val {arg, argType, body, bodyType, region} = Lambda.dest l
 	 in
 	    Lambda.new {arg = arg,
 			argType = argType,
 			body = loopExp body,
+			bodyType = bodyType,
 			region = region}
 	 end
       and loopPrimExp (e: PrimExp.t): PrimExp.t =
 	 case e of
-	    Const _ => e
-	  | Var x => (loopVarExp x; e)
-	  | Tuple xs => (loopVarExps xs; e)
-	  | Select {tuple, ...} => (loopVarExp tuple; e)
-	  | Lambda l => Lambda (loopLambda l)
-	  | ConApp {arg, ...} => (Option.app (arg, loopVarExp); e)
-	  | PrimApp {args, ...} => (loopVarExps args; e)
-	  | App {func, arg} => (loopVarExp func; loopVarExp arg; e)
-	  | Raise {exn, ...} => (loopVarExp exn; e)
+	    App {func, arg} => (loopVarExp func; loopVarExp arg; e)
 	  | Case {test, cases, default} =>
 	       (loopVarExp test
 		; Case {cases = Cases.map (cases, loopExp),
 			default = Option.map (default, fn (e, r) =>
 					      (loopExp e, r)),
 			test = test})
+	  | ConApp {arg, ...} => (Option.app (arg, loopVarExp); e)
+	  | Const _ => e
 	  | Handle {try, catch, handler} =>
 	       Handle {try = loopExp try,
 		       catch = catch,
 		       handler = loopExp handler}
+	  | Lambda l => Lambda (loopLambda l)
+	  | PrimApp {args, ...} => (loopVarExps args; e)
+	  | Profile _ => e
+	  | Raise {exn, ...} => (loopVarExp exn; e)
+	  | Select {tuple, ...} => (loopVarExp tuple; e)
+	  | Tuple xs => (loopVarExps xs; e)
+	  | Var x => (loopVarExp x; e)
       and loopExp (e: Exp.t): Exp.t =
 	 let val {decs, result} = Exp.dest e
 	    val decs =



1.11      +116 -113  mlton/mlton/xml/simplify.fun

Index: simplify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- simplify.fun	12 Dec 2002 01:14:23 -0000	1.10
+++ simplify.fun	10 Jan 2003 18:36:15 -0000	1.11
@@ -309,33 +309,78 @@
 	       end
 	 in
 	    case exp of
-	       Const c => nonExpansiveCon (fn () => (), Value.Const c)
-	     | Var x => let val x = varExpInfo x
-			in replaceInfo (var, info, x)
-			   ; VarInfo.inc (x, ~1)
-			   ; rest ()
-			end
-	     | Tuple xs =>
-		  let val xs = varExpInfos xs
-		  in nonExpansiveCon (fn () => VarInfo.deletes xs,
-				      Value.Tuple xs)
-		  end
-	     | Select {tuple, offset} =>
+	       Case {test, cases, default} =>
 		  let
-		     fun normal x = Select {tuple = x, offset = offset}
-		  in case varExpInfo tuple of
-		     VarInfo.Poly x => finish (normal x, rest ())
-		   | VarInfo.Mono {numOccurrences, value, varExp, ...} =>
-			nonExpansive
-			(fn () => inc (numOccurrences, ~1),
-			 fn () =>
-			 case !value of
-			    NONE => SOME (fn () => normal varExp)
-			  | SOME (Value.Tuple vs) => 
-			       (inc (numOccurrences, ~1)
-				; replaceInfo (var, info, Vector.sub (vs, offset))
-				; NONE)
-			  | _ => Error.bug "simplifyMonoVal: Select")
+		     fun match (cases, f): Dec.t list =
+			let
+			   val _ = deleteVarExp test
+			   fun step (i, (c, e), ()) =
+			      if f c
+				 then
+				    (Vector.foreachR (cases, i + 1,
+						      Vector.length cases,
+						      deleteExp o #2)
+				     ; Option.app (default, deleteExp o #1)
+				     ; Vector.Done (expression e))
+			      else (deleteExp e; Vector.Continue ())
+			   fun done () =
+			      case default of
+				 SOME (e, _) => expression e
+			       | NONE => Error.bug "simplifyPrimExp: Case"
+			in Vector.fold' (cases, 0, (), step, done)
+			end
+		     fun normal test =
+			let
+			   (* Eliminate redundant default case. *)
+			   val default =
+			      if isExhaustive cases
+				 then (Option.app (default, deleteExp o #1)
+				       ; NONE)
+			      else Option.map (default, fn (e, r) =>
+					       (simplifyExp e, r))
+			in
+			   expansive
+			   (Case {test = test,
+				  cases = Cases.map (cases, simplifyExp),
+				  default = default})
+			end
+		  in
+		     case varExpInfo test of
+			VarInfo.Poly test => normal test
+		      | VarInfo.Mono {value, varExp, ...} => 
+			   case (cases, !value) of
+			      (Cases.Con cases,
+			       SOME (Value.ConApp {con = c, arg, ...})) =>
+			      let
+				 val match =
+				    fn f =>
+				    match (cases,
+					   fn Pat.T {con = c', arg, ...} =>
+					   Con.equals (c, c')
+					   andalso f arg)
+			      in case arg of
+				 NONE => match Option.isNone
+			       | SOME v =>
+				    match
+				    (fn SOME (x, _) => (replace (x, v); true)
+				  | _ => false)
+			      end
+			     | (_, SOME (Value.Const c)) =>
+				  let
+				     fun doit (l, z) = match (l, fn z' => z = z')
+				  in case (cases, Const.node c) of
+				     (Cases.Char l, Const.Node.Char c) =>
+					doit (l, c)
+				   | (Cases.Int l, Const.Node.Int i) =>
+					doit (l, i)
+				   | (Cases.Word l, Const.Node.Word w) =>
+					doit (l, w)
+				   | (Cases.Word8 l, Const.Node.Word w) =>
+					doit (l, Word8.fromWord w)
+				   | _ => Error.bug "strange case"
+				  end
+			     | (_, NONE) => normal varExp
+			     | _ => Error.bug "simplifyMonoVal"
 		  end
 	     | ConApp {con, targs, arg} =>
 		  if Con.equals (con, Con.overflow)
@@ -352,6 +397,19 @@
 			(fn () => Option.app (arg, VarInfo.delete),
 			 Value.ConApp {con = con, targs = targs, arg = arg})
 		     end			     
+	     | Const c => nonExpansiveCon (fn () => (), Value.Const c)
+	     | Handle {try, catch, handler} =>
+		  expansive (Handle {try = simplifyExp try,
+				     catch = catch,
+				     handler = simplifyExp handler})
+	     | Lambda l =>
+		  let val isInlined = ref false
+		  in nonExpansive
+		     (fn () => if !isInlined then () else deleteLambda l,
+		      fn () => (value := SOME (Value.Lambda {isInlined = isInlined,
+							     lam = l})
+				; SOME (fn () => Lambda (simplifyLambda l))))
+		  end
 	     | PrimApp {prim, args, targs} =>
 		  let
 		     fun make () =
@@ -361,14 +419,37 @@
 			then expansive (make ())
 		     else nonExpansive (fn () => (), fn () => SOME make)
 		  end
-	     | Lambda l =>
-		  let val isInlined = ref false
-		  in nonExpansive
-		     (fn () => if !isInlined then () else deleteLambda l,
-		      fn () => (value := SOME (Value.Lambda {isInlined = isInlined,
-							     lam = l})
-				; SOME (fn () => Lambda (simplifyLambda l))))
+	     | Profile _ => expansive exp
+	     | Raise {exn, filePos} =>
+		  expansive (Raise {exn = simplifyVarExp exn,
+				    filePos = filePos})
+	     | Select {tuple, offset} =>
+		  let
+		     fun normal x = Select {tuple = x, offset = offset}
+		  in case varExpInfo tuple of
+		     VarInfo.Poly x => finish (normal x, rest ())
+		   | VarInfo.Mono {numOccurrences, value, varExp, ...} =>
+			nonExpansive
+			(fn () => inc (numOccurrences, ~1),
+			 fn () =>
+			 case !value of
+			    NONE => SOME (fn () => normal varExp)
+			  | SOME (Value.Tuple vs) => 
+			       (inc (numOccurrences, ~1)
+				; replaceInfo (var, info, Vector.sub (vs, offset))
+				; NONE)
+			  | _ => Error.bug "simplifyMonoVal: Select")
+		  end
+	     | Tuple xs =>
+		  let val xs = varExpInfos xs
+		  in nonExpansiveCon (fn () => VarInfo.deletes xs,
+				      Value.Tuple xs)
 		  end
+	     | Var x => let val x = varExpInfo x
+			in replaceInfo (var, info, x)
+			   ; VarInfo.inc (x, ~1)
+			   ; rest ()
+			end
 	     | App {func, arg} =>
 		  let
 		     val arg = varExpInfo arg
@@ -390,95 +471,17 @@
 			      end
 			 | _ => normal varExp
 		  end
-	     | Raise {exn, filePos} =>
-		  expansive (Raise {exn = simplifyVarExp exn,
-				    filePos = filePos})
-	     | Handle {try, catch, handler} =>
-		  expansive (Handle {try = simplifyExp try,
-				     catch = catch,
-				     handler = simplifyExp handler})
-	     | Case {test, cases, default} =>
-		  let
-		     fun match (cases, f): Dec.t list =
-			let
-			   val _ = deleteVarExp test
-			   fun step (i, (c, e), ()) =
-			      if f c
-				 then
-				    (Vector.foreachR (cases, i + 1,
-						      Vector.length cases,
-						      deleteExp o #2)
-				     ; Option.app (default, deleteExp o #1)
-				     ; Vector.Done (expression e))
-			      else (deleteExp e; Vector.Continue ())
-			   fun done () =
-			      case default of
-				 SOME (e, _) => expression e
-			       | NONE => Error.bug "simplifyPrimExp: Case"
-			in Vector.fold' (cases, 0, (), step, done)
-			end
-		     fun normal test =
-			let
-			   (* Eliminate redundant default case. *)
-			   val default =
-			      if isExhaustive cases
-				 then (Option.app (default, deleteExp o #1)
-				       ; NONE)
-			      else Option.map (default, fn (e, r) =>
-					       (simplifyExp e, r))
-			in
-			   expansive
-			   (Case {test = test,
-				  cases = Cases.map (cases, simplifyExp),
-				  default = default})
-			end
-		  in case varExpInfo test of
-		     VarInfo.Poly test => normal test
-		   | VarInfo.Mono {value, varExp, ...} => 
-			case (cases, !value) of
-			   (Cases.Con cases,
-			    SOME (Value.ConApp {con = c, arg, ...})) =>
-			   let
-			      val match =
-				 fn f =>
-				 match (cases,
-					fn Pat.T {con = c', arg, ...} =>
-					Con.equals (c, c')
-					andalso f arg)
-			   in case arg of
-			      NONE => match Option.isNone
-			    | SOME v =>
-				 match
-				 (fn SOME (x, _) => (replace (x, v); true)
-			       | _ => false)
-			   end
-			  | (_, SOME (Value.Const c)) =>
-			       let
-				  fun doit (l, z) = match (l, fn z' => z = z')
-			       in case (cases, Const.node c) of
-				  (Cases.Char l, Const.Node.Char c) =>
-				     doit (l, c)
-				| (Cases.Int l, Const.Node.Int i) =>
-				     doit (l, i)
-				| (Cases.Word l, Const.Node.Word w) =>
-				     doit (l, w)
-				| (Cases.Word8 l, Const.Node.Word w) =>
-				     doit (l, Word8.fromWord w)
-				| _ => Error.bug "strange case"
-			       end
-			  | (_, NONE) => normal varExp
-			  | _ => Error.bug "simplifyMonoVal"
-		  end
 	 end
       and simplifyLambda l: Lambda.t =
 	 traceSimplifyLambda
 	 (fn l => 
 	  let
-	     val {arg, argType, body, region} = Lambda.dest l
+	     val {arg, argType, body, bodyType, region} = Lambda.dest l
 	  in
 	     Lambda.new {arg = arg,
 			 argType = argType,
 			 body = simplifyExp body,
+			 bodyType = bodyType,
 			 region = region}
 	  end) l
       val _ = countExp body



1.3       +18 -18    mlton/mlton/xml/sources.cm

Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/sources.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.cm	16 Apr 2002 12:10:53 -0000	1.2
+++ sources.cm	10 Jan 2003 18:36:16 -0000	1.3
@@ -23,24 +23,24 @@
 ../control/sources.cm
 ../../lib/mlton/sources.cm
 
-xml-type.sig
-xml-tree.sig
-xml-tree.fun
-xml.sig
-type-check.sig
-type-check.fun
-simplify-types.sig
-simplify-types.fun
-scc-funs.sig
+implement-exceptions.fun
+implement-exceptions.sig
+monomorphise.fun
+monomorphise.sig
+polyvariance.fun
+polyvariance.sig
 scc-funs.fun
-simplify.sig
+scc-funs.sig
+simplify-types.fun
+simplify-types.sig
 simplify.fun
-xml.fun
-sxml.sig
-polyvariance.sig
-polyvariance.fun
+simplify.sig
 sxml-exns.sig
-monomorphise.sig
-monomorphise.fun
-implement-exceptions.sig
-implement-exceptions.fun
+sxml.sig
+type-check.fun
+type-check.sig
+xml-tree.fun
+xml-tree.sig
+xml-type.sig
+xml.fun
+xml.sig



1.7       +58 -52    mlton/mlton/xml/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- type-check.fun	12 Dec 2002 01:14:23 -0000	1.6
+++ type-check.fun	10 Jan 2003 18:36:16 -0000	1.7
@@ -153,56 +153,7 @@
 	       List.fold (es, t, fn (e, t) => checkApp (t, e))
 	 in
 	    case e of
-	       Var x => checkVarExp x
-	     | Const c => Type.ofConst c
-	     | Tuple xs =>
-		  if 1 = Vector.length xs
-		     then error "unary tuple"
-		  else Type.tuple (checkVarExps xs)
-	     | Select {tuple, offset} =>
-		  (case Type.detupleOpt (checkVarExp tuple) of
-		      SOME ts => Vector.sub (ts, offset)
-		    | NONE => error "selection from nontuple")
-	     | Lambda l => checkLambda l
-	     | PrimApp {prim, targs, args} =>
-		  let
-		     val _ = checkTypes targs
-		  in
-		     case Prim.checkApp {prim = prim,
-					 targs = targs,
-					 args = checkVarExps args,
-					 con = Type.con,
-					 equals = Type.equals,
-					 dearrowOpt = Type.dearrowOpt,
-					 detupleOpt = Type.detupleOpt,
-					 isUnit = Type.isUnit
-					 } of
-			NONE => error "bad primapp"
-		      | SOME t => t
-		  end
-	     | ConApp {con, targs, arg} =>
-		  let
-		     val t = checkConExp (con, targs)
-		  in case arg of
-		     NONE => t
-		   | SOME e => checkApp (t, e)
-		  end
-	     | App {func, arg} => checkApp (checkVarExp func, arg)
-	     | Raise {exn, ...} => if isExnType (checkVarExp exn)
-				      then ty
-				   else error "bad raise"
-	     | Handle {try, catch = (catch, catchType), handler, ...} =>
-		  let
-		     val _ = if isExnType catchType
-				then ()
-			     else error "handle with non-exn type for catch"
-		     val ty = checkExp try
-		     val _ = setVar (catch, {tyvars = Vector.new0 (),
-					     ty = catchType})
-		     val ty' = checkExp handler
-		  in if Type.equals (ty, ty') then ty
-		     else error "bad handle"
-		  end
+	       App {func, arg} => checkApp (checkVarExp func, arg)
 	     | Case {test, cases, default} =>
 		  let
 		     val ty = checkVarExp test
@@ -244,14 +195,69 @@
 				    else error "default of wrong type"
 			else error "test and patterns of different types"
 		  end
+	     | ConApp {con, targs, arg} =>
+		  let
+		     val t = checkConExp (con, targs)
+		  in case arg of
+		     NONE => t
+		   | SOME e => checkApp (t, e)
+		  end
+	     | Const c => Type.ofConst c
+	     | Handle {try, catch = (catch, catchType), handler, ...} =>
+		  let
+		     val _ = if isExnType catchType
+				then ()
+			     else error "handle with non-exn type for catch"
+		     val ty = checkExp try
+		     val _ = setVar (catch, {tyvars = Vector.new0 (),
+					     ty = catchType})
+		     val ty' = checkExp handler
+		  in if Type.equals (ty, ty') then ty
+		     else error "bad handle"
+		  end
+	     | Lambda l => checkLambda l
+	     | PrimApp {prim, targs, args} =>
+		  let
+		     val _ = checkTypes targs
+		  in
+		     case Prim.checkApp {prim = prim,
+					 targs = targs,
+					 args = checkVarExps args,
+					 con = Type.con,
+					 equals = Type.equals,
+					 dearrowOpt = Type.dearrowOpt,
+					 detupleOpt = Type.detupleOpt,
+					 isUnit = Type.isUnit
+					 } of
+			NONE => error "bad primapp"
+		      | SOME t => t
+		  end
+	     | Profile _ => Type.unit
+	     | Raise {exn, ...} => if isExnType (checkVarExp exn)
+				      then ty
+				   else error "bad raise"
+	     | Select {tuple, offset} =>
+		  (case Type.detupleOpt (checkVarExp tuple) of
+		      SOME ts => Vector.sub (ts, offset)
+		    | NONE => error "selection from nontuple")
+	     | Tuple xs =>
+		  if 1 = Vector.length xs
+		     then error "unary tuple"
+		  else Type.tuple (checkVarExps xs)
+	     | Var x => checkVarExp x
 	 end) arg
       and checkLambda l: Type.t =
 	 let
-	    val {arg, argType, body, ...} = Lambda.dest l
+	    val {arg, argType, body, bodyType, ...} = Lambda.dest l
 	    val _ = checkType argType
 	    val _ = setVar (arg, {tyvars = Vector.new0 (), ty = argType})
+	    val _ =
+	       if Type.equals (bodyType, checkExp body)
+		  then ()
+	       else Type.error ("lambda body of wrong type",
+				Lambda.layout l)
 	 in
-	    Type.arrow (argType, checkExp body)
+	    Type.arrow (argType, bodyType)
 	 end
       and checkDec d =
 	 let



1.12      +93 -40    mlton/mlton/xml/xml-tree.fun

Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- xml-tree.fun	12 Dec 2002 01:14:23 -0000	1.11
+++ xml-tree.fun	10 Jan 2003 18:36:16 -0000	1.12
@@ -125,6 +125,7 @@
   | PrimApp of {prim: Prim.t,
 		targs: Type.t vector,
 		args: VarExp.t vector}
+  | Profile of ProfileExp.t
   | Raise of {exn: VarExp.t,
 	      filePos: string}
   | Select of {tuple: VarExp.t,
@@ -148,6 +149,7 @@
 and lambda = Lam of {arg: Var.t,
 		     argType: Type.t,
 		     body: exp,
+		     bodyType: Type.t,
 		     plist: PropertyList.t,
 		     region: Region.t}
 
@@ -200,40 +202,7 @@
    end
 and primExpToAst e : Aexp.t =
    case e of
-      Const c => Const.toAstExp c
-    | Var x => VarExp.toAst x
-    | Tuple xs => Aexp.tuple (Vector.map (xs, VarExp.toAst))
-    | Select {tuple, offset} =>
-	 Aexp.select {tuple = VarExp.toAst tuple,
-		      offset = offset}
-    | Lambda lambda => Aexp.fnn (lambdaToAst lambda)
-    | ConApp {con, arg, ...} =>
-	 let val con = Aexp.con (Con.toAst con)
-	 in case arg of
-	    NONE => con
-	  | SOME e => Aexp.app (con, VarExp.toAst e)
-	 end
-    | PrimApp {prim, args, ...} =>
-	 let
-	    val p = Aexp.longvid (Ast.Longvid.short
-				  (Ast.Longvid.Id.fromString
-				   (Prim.toString prim,
-				    Region.bogus)))
-	 in
-	    case Prim.numArgs prim of
-	       NONE => p
-	     | SOME _ => Aexp.app (p, Aexp.tuple (Vector.map
-						  (args, VarExp.toAst)))
-	 end
-    | App {func, arg} => Aexp.app (VarExp.toAst func, VarExp.toAst arg)
-    | Raise {exn, filePos} => Aexp.raisee {exn = VarExp.toAst exn,
-					   filePos = filePos}
-    | Handle {try, catch, handler} =>
-	 Aexp.handlee
-	 (expToAst try,
-	  Amatch.T {filePos = "",
-		    rules = Vector.new1 (Apat.var (Var.toAst (#1 catch)),
-					 expToAst handler)})
+      App {func, arg} => Aexp.app (VarExp.toAst func, VarExp.toAst arg)
     | Case {test, cases, default, ...} =>
 	 let
 	    fun doit (l, f) =
@@ -260,6 +229,52 @@
 			Amatch.T {rules = cases,
 				  filePos = ""})
 	 end
+    | ConApp {con, arg, ...} =>
+	 let val con = Aexp.con (Con.toAst con)
+	 in case arg of
+	    NONE => con
+	  | SOME e => Aexp.app (con, VarExp.toAst e)
+	 end
+    | Const c => Const.toAstExp c
+    | Handle {try, catch, handler} =>
+	 Aexp.handlee
+	 (expToAst try,
+	  Amatch.T {filePos = "",
+		    rules = Vector.new1 (Apat.var (Var.toAst (#1 catch)),
+					 expToAst handler)})
+    | Lambda lambda => Aexp.fnn (lambdaToAst lambda)
+    | PrimApp {prim, args, ...} =>
+	 let
+	    val p = Aexp.longvid (Ast.Longvid.short
+				  (Ast.Longvid.Id.fromString
+				   (Prim.toString prim,
+				    Region.bogus)))
+	 in
+	    case Prim.numArgs prim of
+	       NONE => p
+	     | SOME _ => Aexp.app (p, Aexp.tuple (Vector.map
+						  (args, VarExp.toAst)))
+	 end
+    | Profile s =>
+	 let
+	    val (oper, si) =
+	       case s of
+		  ProfileExp.Enter si => ("ProfileEnter", si)
+		| ProfileExp.Leave si => ("ProfileLeave", si)
+	 in
+	    Aexp.app
+	    (Aexp.var (Ast.Var.fromString (oper, Region.bogus)),
+	     Aexp.const (Ast.Const.makeRegion
+			 (Ast.Const.String (SourceInfo.toString si),
+			  Region.bogus)))
+	 end
+    | Raise {exn, filePos} => Aexp.raisee {exn = VarExp.toAst exn,
+					   filePos = filePos}
+    | Select {tuple, offset} =>
+	 Aexp.select {tuple = VarExp.toAst tuple,
+		      offset = offset}
+    | Tuple xs => Aexp.tuple (Vector.map (xs, VarExp.toAst))
+    | Var x => VarExp.toAst x
 
 and lambdaToAst (Lam {arg, body, argType, ...}): Amatch.t =
    Amatch.T
@@ -324,6 +339,40 @@
       val toAst = expToAst
       val layout = Ast.Exp.layout o toAst
 
+      fun enterLeave (e: t, ty: Type.t, si: SourceInfo.t): t =
+	 if !Control.profile = Control.ProfileNone
+	    orelse !Control.profileIL <> Control.ProfileXML
+	    then e
+	 else
+	 let
+	    datatype z = datatype Dec.t
+	    datatype z = datatype PrimExp.t
+	    fun prof f =
+	       MonoVal {exp = Profile (f si),
+			ty = Type.unit,
+			var = Var.newNoname ()}
+	    val exn = Var.newNoname ()
+	    val res = Var.newNoname ()
+	    val handler =
+	       new {decs = [prof ProfileExp.Leave,
+			    MonoVal {exp = Raise {exn = VarExp.mono exn,
+						  filePos = ""},
+				     ty = ty,
+				     var = res}],
+		    result = VarExp.mono res}
+	    val {decs, result} = dest e
+	    val decs =
+	       List.concat [[prof ProfileExp.Enter],
+			    decs,
+			    [prof ProfileExp.Leave]]
+	    val try = new {decs = decs, result = result}
+	 in
+	    fromPrimExp (Handle {catch = (exn, Type.exn),
+				 handler = handler,
+				 try = try},
+			 ty)
+	 end
+
       (*------------------------------------*)
       (*              foreach               *)
       (*------------------------------------*)
@@ -350,6 +399,7 @@
 		    | Select {tuple, ...} => handleVarExp tuple
 		    | Lambda lambda => loopLambda lambda
 		    | PrimApp {args, ...} => handleVarExps args
+		    | Profile _ => ()
 		    | ConApp {arg, ...} => (case arg of
 					       NONE => ()
 					     | SOME x => handleVarExp x)
@@ -493,15 +543,18 @@
 	 val region = make #region
       end
 
-      fun new {arg, argType, body, region} =
+      fun new {arg, argType, body, bodyType, region} =
 	 Lam {arg = arg,
 	      argType = argType,
 	      body = body,
+	      bodyType = bodyType,
 	      plist = PropertyList.new (),
 	      region = region}
 
-      fun dest (Lam {arg, argType, body, region, ...}) =
-	 {arg = arg, argType = argType, body = body, region = region}
+      fun dest (Lam {arg, argType, body, bodyType, region, ...}) =
+	 {arg = arg, argType = argType,
+	  body = body, bodyType = bodyType,
+	  region = region}
 	 
       fun plist (Lam {plist, ...}) = plist
 	 
@@ -537,7 +590,7 @@
 	 end
 
       type t = Cont.t -> Exp.t
-
+	 
       fun send (e: t, k: Cont.t): Exp.t = e k
 
       fun toExp e = send (e, Cont.id)
@@ -700,14 +753,14 @@
 	       Exp.prefix (send (body, k),
 			   Dec.MonoVal {var = var, ty = ty, exp = exp}))
 	 
-
       fun lambda {arg, argType, body, bodyType, region} =
 	 simple (Lambda (Lambda.new {arg = arg,
 				     argType = argType,
 				     body = toExp body,
+				     bodyType = bodyType,
 				     region = region}),
 		 Type.arrow (argType, bodyType))
-
+      
       fun detupleGen (e: PrimExp.t,
 		      t: Type.t,
 		      components: Var.t vector,



1.8       +28 -24    mlton/mlton/xml/xml-tree.sig

Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- xml-tree.sig	12 Dec 2002 01:14:23 -0000	1.7
+++ xml-tree.sig	10 Jan 2003 18:36:16 -0000	1.8
@@ -54,12 +54,14 @@
 	    val dest: t -> {arg: Var.t,
 			    argType: Type.t,
 			    body: exp,
+			    bodyType: Type.t,
 			    region: Region.t}
 	    val equals: t * t -> bool
 	    val layout: t -> Layout.t
 	    val new: {arg: Var.t,
 		      argType: Type.t,
 		      body: exp,
+		      bodyType: Type.t,
 		      region: Region.t} -> t
 	    val plist: t -> PropertyList.t
 	    val region: t -> Region.t
@@ -83,27 +85,28 @@
 	 sig
 	    type exp = Lambda.exp
 	    datatype t =
-	       App of {func: VarExp.t,
-		       arg: VarExp.t}
-	     | Case of {test: VarExp.t,
-			cases: exp Cases.t,
-			default: (exp * Region.t) option}
-	     | ConApp of {con: Con.t,
-			  targs: Type.t vector,
-			  arg: VarExp.t option}
+	       App of {arg: VarExp.t,
+		       func: VarExp.t}
+	     | Case of {cases: exp Cases.t,
+			default: (exp * Region.t) option,
+			test: VarExp.t}
+	     | ConApp of {arg: VarExp.t option,
+			  con: Con.t,
+			  targs: Type.t vector}
 	     | Const of Const.t
-	     | Handle of {try: exp,
-			  (* catch binds the exception in the handler. *)
+	     | Handle of {(* catch binds the exception in the handler. *)
 			  catch: Var.t * Type.t,
-			  handler: exp}
+			  handler: exp,
+			  try: exp}
 	     | Lambda of Lambda.t
-	     | PrimApp of {prim: Prim.t,
-			   targs: Type.t vector,
-			   args: VarExp.t vector}
+	     | PrimApp of {args: VarExp.t vector,
+			   prim: Prim.t,
+			   targs: Type.t vector}
+	     | Profile of ProfileExp.t
 	     | Raise of {exn: VarExp.t,
 			 filePos: string}
-	     | Select of {tuple: VarExp.t,
-			  offset: int}
+	     | Select of {offset: int,
+			  tuple: VarExp.t}
 	     | Tuple of VarExp.t vector
 	     | Var of VarExp.t
 
@@ -117,17 +120,17 @@
 	    datatype t =
 	       Exception of {con: Con.t,
 			     arg: Type.t option}
-	     | Fun of {tyvars: Tyvar.t vector,
-		       decs: {var: Var.t,
+	     | Fun of {decs: {lambda: Lambda.t,
 			      ty: Type.t,
-			      lambda: Lambda.t} vector}
-	     | MonoVal of {var: Var.t,
+			      var: Var.t} vector,
+		       tyvars: Tyvar.t vector}
+	     | MonoVal of {exp: PrimExp.t,
 			   ty: Type.t,
-			   exp: PrimExp.t}
-	     | PolyVal of {var: Var.t,
-			   tyvars: Tyvar.t vector,
+			   var: Var.t}
+	     | PolyVal of {exp: exp,
 			   ty: Type.t,
-			   exp: exp}
+			   tyvars: Tyvar.t vector,
+			   var: Var.t}
 
 	    val toAst: t -> Ast.Dec.t
 	    val layout: t -> Layout.t
@@ -140,6 +143,7 @@
 	    val clear: t -> unit
 	    val decs: t -> Dec.t list
 	    val dest: t -> {decs: Dec.t list, result: VarExp.t}
+	    val enterLeave: t * Type.t * SourceInfo.t -> t
 	    (* foreach {exp, handleExp, handleBoundVar, handleVarExp}
 	     * applies handleExp to each subexpresison of e (including e)
 	     * applies handleBoundVar to each variable bound in e





-------------------------------------------------------
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