[MLton-devel] cvs commit: elimination of unused type arguments

Stephen Weeks MLton@mlton.org
Mon, 24 Feb 2003 18:50:45 -0800


sweeks      03/02/24 18:50:45

  Modified:    mlton/main compile.sml
               mlton/xml simplify-types.fun simplify-types.sig
                        type-check.fun xml-tree.sig xml.fun xml.sig
  Log:
  Added a pass that runs on XML before monomorphisation and eliminates
  unused type arguments.  It first computes a simple fixpoint on all the
  datatype declarations to determine which datatype tycon args are
  actually used.  Then it does a single pass over the program to
  determine which polymorphic declaration type variables are used, and
  rewrites types to eliminate unused type arguments.
  
  This pass should eliminate any spurious duplication that
  monomorphisation might perform due to phantom types.  If you're able
  to find a program that it misses, let me know.

Revision  Changes    Path
1.49      +8 -0      mlton/mlton/main/compile.sml

Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- compile.sml	23 Jan 2003 03:34:38 -0000	1.48
+++ compile.sml	25 Feb 2003 02:50:43 -0000	1.49
@@ -397,6 +397,14 @@
 	  display = Control.Layout Xml.Program.layout,
 	  typeCheck = Xml.typeCheck,
 	  simplify = Xml.simplify}
+      val xml =
+	 Control.passTypeCheck
+	 {name = "simplifyTypes",
+	  suffix = "xml",
+	  style = Control.ML,
+	  thunk = fn () => Xml.simplifyTypes xml,
+	  display = Control.Layout Xml.Program.layout,
+	  typeCheck = Xml.typeCheck}
       val _ = Control.message (Control.Detail, fn () =>
 			       Xml.Program.layoutStats xml)
       val sxml =



1.6       +269 -88   mlton/mlton/xml/simplify-types.fun

Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- simplify-types.fun	12 Feb 2003 05:11:29 -0000	1.5
+++ simplify-types.fun	25 Feb 2003 02:50:44 -0000	1.6
@@ -9,106 +9,287 @@
 struct
 
 open S
+structure I = Input
+structure O = Output
+open I.Atoms
 
-structure Graph = DirectedGraph
-structure Node = Graph.Node
+structure PowerSetLat =
+   struct
+      datatype t = T of {isIn: bool ref,
+			 whenIn: (unit -> unit) list ref} vector
 
-fun simplifyTypes (p as Program.T {datatypes, body, ...}) =
+      fun isIn (T v, i) =
+	 ! (#isIn (Vector.sub (v, i)))
+
+      fun new (size: int) = T (Vector.tabulate (size, fn _ =>
+						{isIn = ref false,
+						 whenIn = ref []}))
+
+      fun add (T v, i) =
+	 let
+	    val {isIn, whenIn, ...} = Vector.sub (v, i)
+	 in
+	    if !isIn
+	       then ()
+	    else (isIn := true
+		  ; List.foreach (!whenIn, fn f => f ()))
+	 end
+
+      fun whenIn (T v, i, f) =
+	 let
+	    val {isIn, whenIn, ...} = Vector.sub (v, i)
+	 in
+	    if !isIn
+	       then f ()
+	    else List.push (whenIn, f)
+	 end
+   end
+
+fun simplifyTypes (I.Program.T {body, datatypes, overflow}) =
    let
-      val g = Graph.new ()
-      val {get = tyconInfo: Tycon.t -> {node: unit Node.t,
-					isOneVariantArrow: bool ref,
-					cons: {con: Con.t,
-					       arg: Type.t option
-					       } vector
-					} option,
-	   set = setTyconInfo, destroy = destroyTycon} =
-	 Property.destGetSetOnce (Tycon.plist, Property.initConst NONE)
-      val {get = nodeTycon, set = setNodeTycon, ...} =
-	 Property.getSetOnce (Node.plist,
-			      Property.initRaise ("tycon", Node.layout))
+      val {get = tyconInfo: Tycon.t -> {used: PowerSetLat.t} option,
+	   set = setTyconInfo, ...} =
+	 Property.getSetOnce (Tycon.plist, Property.initConst NONE)
       val _ =
 	 Vector.foreach
-	 (datatypes, fn {tycon, cons, ...} =>
-	  let val node = Graph.newNode g
-	  in setTyconInfo (tycon, SOME {node = node,
-					isOneVariantArrow = ref false,
-					cons = cons})
-	     ; setNodeTycon (node, tycon)
-	  end)
-      val _ = 
+	 (datatypes, fn {cons, tycon, tyvars} =>
+	  setTyconInfo (tycon,
+			SOME {used = PowerSetLat.new (Vector.length tyvars)}))
+      val _ =
 	 Vector.foreach
-	 (datatypes, fn {tycon, cons, ...} =>
+	 (datatypes, fn {cons, tycon, tyvars} =>
 	  let
-	     val {node = from, ...} = valOf (tyconInfo tycon)
-	     fun loop (t: Type.t): unit =
-		case Type.dest t of
-		   Type.Var _ => ()
-		 | Type.Con (tycon', ts) =>
-		      (if Tycon.equals (tycon, tycon')
-			  then (case tyconInfo tycon' of
-				   NONE => ()
-				 | SOME {node = to, ...} =>
-				      (Graph.addEdge (g, {from = from,
-							  to = to})
-				       ; ()))
-		       else ()
-			  ; Vector.foreach (ts, loop))
-	  in Vector.foreach (cons, fn {arg, ...} =>
-			     case arg of
-				NONE => ()
-			      | SOME t => loop t)
+	     val {get = tyvarIndex, set = setTyvarIndex, rem, ...} =
+		Property.getSet
+		(Tyvar.plist, Property.initRaise ("index", Tyvar.layout))
+	     val _ = Vector.foreachi (tyvars, fn (i, a) => setTyvarIndex (a, i))
+	     val {used, ...} = valOf (tyconInfo tycon)
+	     val {destroy, hom} =
+		I.Type.makeHom
+		{con = (fn (_, tc, ts) =>
+			fn () =>
+			case tyconInfo tc of
+			   NONE => Vector.foreach (ts, fn t => t ())
+			 | SOME {used, ...} =>
+			      Vector.foreachi
+			      (ts, fn (i, t) =>
+			       PowerSetLat.whenIn (used, i, t))),
+		 var = (fn (_, a) =>
+			let
+			   val i = tyvarIndex a
+			in
+			   fn () => PowerSetLat.add (used, i)
+			end)}
+	     val _ =
+		Vector.foreach
+		(cons, fn {arg, ...} =>
+		 case arg of
+		    NONE => ()
+		  | SOME t => hom t ())
+	     val _ = Vector.foreach (tyvars, rem)
+	     val _ = destroy ()
+	  in
+	     ()
 	  end)
-      fun num (datatypes, p) =
-	 List.fold (datatypes, 0, fn (d, n) => if p d then n + 1 else n)
-      val numDatatypes = Vector.length datatypes
-      val arrowDatatypes =
-	 Vector.keepAll
-	 (datatypes, fn {cons, ...} =>
-	  Vector.exists (cons, fn {arg, ...} =>
-			 case arg of
-			    NONE => false
-			  | SOME t =>
-			       Type.containsTycon (t, Atoms.Tycon.arrow)))
-      val numArrowDatatypes = Vector.length arrowDatatypes
-      val oneVariantArrows = Vector.keepAll (arrowDatatypes, fn {cons, ...} =>
-					     1 = Vector.length cons)
-      val numOneVariantArrows = Vector.length oneVariantArrows
+      val {get = tyconKeep: Tycon.t -> bool vector option,
+	   set = setTyconKeep, ...} =
+	 Property.getSetOnce (Tycon.plist, Property.initConst NONE)
+      val {get = conKeep: Con.t -> bool vector option,
+	   set = setConKeep, ...} =
+	 Property.getSetOnce (Con.plist, Property.initConst NONE)
       val _ =
 	 Vector.foreach
-	 (oneVariantArrows, fn {tycon, ...} =>
-	  let val {isOneVariantArrow, ...} = valOf (tyconInfo tycon)
-	  in isOneVariantArrow := true
-	  end)
-      val components = Graph.stronglyConnectedComponents g
-      val numEliminable =
-	 List.fold
-	 (components, 0, fn (nodes, n) =>
-	  case nodes of
-	     [node] =>
-		if Node.hasEdge {from = node, to = node}
-		   then n
-		else
-		   let
-		      val {isOneVariantArrow, ...} =
-			 valOf (tyconInfo (nodeTycon node))
-		   in if !isOneVariantArrow
-			 then n + 1
-		      else n
-		   end
-	   | _ => n)
-      val _ =
-	 Control.message
-	 (Control.Detail, fn () =>
-	  let open Layout
-	  in align [seq [str "datatypes: ", Int.layout numDatatypes],
-		    seq [str "-> datatypes: ", Int.layout numArrowDatatypes],
-		    seq [str "one variants: ", Int.layout numOneVariantArrows],
-		    seq [str "eliminable: ", Int.layout numEliminable]]
+	 (datatypes, fn {cons, tycon, tyvars} =>
+	  let
+	     val {used, ...} = valOf (tyconInfo tycon)
+	     val v =
+		Vector.tabulate
+		(Vector.length tyvars, fn i => PowerSetLat.isIn (used, i))
+	     val _ = Vector.foreach (cons, fn {con, ...} =>
+				     setConKeep (con, SOME v))
+	     val u =
+		if Vector.forall (v, fn b => b)
+		   then NONE
+		else SOME v
+	     val _ = setTyconKeep (tycon, u)
+	  in
+	     ()
 	  end)
-      val _ = destroyTycon ()
+      fun keep (v: 'a vector, bv: bool vector): 'a vector =
+	 Vector.keepAllMapi (v, fn (i, a) =>
+			     if Vector.sub (bv, i)
+				then SOME a
+			     else NONE)
+      val {get = tyvarIsUsed: Tyvar.t -> bool ref, ...} =
+	 Property.get (Tyvar.plist, Property.initFun (fn _ => ref false))
+      (* There is some mesiness with promises here for two reasons:
+       * 1. The thunk is to make sure that even though we are using a type
+       *    homomorphism, a type variable is only marked as used if it appears
+       *    in the output.
+       * 2. The promise is do avoid computing the same output multiple times.
+       *    This is necessary because the type homomorphism only memoizes the
+       *    mapping from type to thunk, *not* the thunk's output.
+       *)
+      val {hom = fixType: I.Type.t -> unit -> O.Type.t, ...} =
+	 I.Type.makeHom
+	 {con = (fn (t, tc, ts) =>
+		 Promise.lazy
+		 (fn () =>
+		  let
+		     val ts =
+			case tyconKeep tc of
+			   NONE => ts
+			 | SOME bv => keep (ts, bv)
+		     val ts = Vector.map (ts, fn t => t ())
+		  in
+		     O.Type.con (tc, ts)
+		  end)),
+	  var = (fn (_, a) =>
+		 Promise.lazy
+		 (fn () => (tyvarIsUsed a := true; O.Type.var a)))}
+      val fixType = fn t => fixType t ()
+      val fixType =
+	 Trace.trace ("fixType", I.Type.layout, O.Type.layout) fixType
+      val tyvarIsUsed = ! o tyvarIsUsed
+      val datatypes =
+	 Vector.map (datatypes, fn {cons, tycon, tyvars} =>
+		     {cons = Vector.map (cons, fn {arg, con} =>
+					 {arg = Option.map (arg, fixType),
+					  con = con}),
+		      tycon = tycon,
+		      tyvars = (case tyconKeep tycon of
+				   NONE => tyvars
+				 | SOME bv => keep (tyvars, bv))})
+      val {get = varKeep: Var.t -> bool vector option,
+	   set = setVarKeep, ...} =
+	 Property.getSetOnce (Var.plist, Property.initConst NONE)
+      fun fixVarExp (I.VarExp.T {targs, var}): O.VarExp.t =
+	 let
+	    val targs =
+	       case varKeep var of
+		  NONE => targs
+		| SOME bv => keep (targs, bv)
+	 in
+	    O.VarExp.T {targs = Vector.map (targs, fixType),
+			var = var}
+	 end
+      val fixVarExp =
+	 Trace.trace ("fixVarExp", I.VarExp.layout, O.VarExp.layout) fixVarExp
+      fun fixConTargs (con: Con.t, targs: I.Type.t vector): O.Type.t vector =
+	 let
+	    val targs =
+	       case conKeep con of
+		  NONE => targs
+		| SOME bv => keep (targs, bv)
+	 in
+	    Vector.map (targs, fixType)
+	 end
+      fun fixPat (I.Pat.T {arg, con, targs}): O.Pat.t =
+	 O.Pat.T {arg = Option.map (arg, fn (x, t) => (x, fixType t)),
+		  con = con,
+		  targs = fixConTargs (con, targs)}
+      fun fixDec (d: I.Dec.t): O.Dec.t =
+	 case d of
+	    I.Dec.Exception {arg, con} =>
+	       O.Dec.Exception {arg = Option.map (arg, fixType),
+				con = con}
+	  | I.Dec.Fun {decs, tyvars} =>
+	       let
+		  val decs =
+		     Vector.map (decs, fn {lambda, ty, var} =>
+				 {lambda = fixLambda lambda,
+				  ty = fixType ty,
+				  var = var})
+		  val bv = Vector.map (tyvars, tyvarIsUsed)
+		  val tyvars = keep (tyvars, bv)
+		  val _ =
+		     Vector.foreach
+		     (decs, fn {var, ...} => setVarKeep (var, SOME bv))
+	       in
+		  O.Dec.Fun {decs = decs,
+			     tyvars = tyvars}
+	       end
+	  | I.Dec.MonoVal {exp, ty, var} =>
+	       O.Dec.MonoVal {exp = fixPrimExp exp,
+			      ty = fixType ty,
+			      var = var}
+	  | I.Dec.PolyVal {exp, ty, tyvars, var} =>
+	       let
+		  val exp = fixExp exp
+		  val ty = fixType ty
+		  val bv = Vector.map (tyvars, tyvarIsUsed)
+		  val _ = setVarKeep (var, SOME bv)
+	       in
+		  O.Dec.PolyVal {exp = exp,
+				 ty = ty,
+				 tyvars = keep (tyvars, bv),
+				 var = var}
+	       end
+      and fixExp (e: I.Exp.t): O.Exp.t =
+	 let
+	    val {decs, result} = I.Exp.dest e
+	 in
+	    O.Exp.new {decs = List.map (decs, fixDec),
+		       result = fixVarExp result}
+	 end
+      and fixLambda (l: I.Lambda.t): O.Lambda.t =
+	 let
+	    val {arg, argType, body} = I.Lambda.dest l
+	 in
+	    O.Lambda.new {arg = arg,
+			  argType = fixType argType,
+			  body = fixExp body}
+	 end
+      and fixPrimExp (e: I.PrimExp.t): O.PrimExp.t =
+	 case e of
+	    I.PrimExp.App {arg, func} => O.PrimExp.App {arg = fixVarExp arg,
+							func = fixVarExp func}
+	  | I.PrimExp.Case {cases, default, test} =>
+	       let
+		  fun doit v = Vector.map (v, fn (c, e) => (c, fixExp e))
+		  val cases =
+		     case cases of
+			I.Cases.Char v => O.Cases.Char (doit v)
+		      | I.Cases.Con v =>
+			   O.Cases.Con (Vector.map (v, fn (p, e) =>
+						    (fixPat p, fixExp e)))
+		      | I.Cases.Int v => O.Cases.Int (doit v)
+		      | I.Cases.Word v => O.Cases.Word (doit v)
+		      | I.Cases.Word8 v => O.Cases.Word8 (doit v)
+	       in
+		  O.PrimExp.Case {cases = cases,
+				  default = Option.map (default, fn (e, r) =>
+							(fixExp e, r)),
+				  test = fixVarExp test}
+	       end
+	  | I.PrimExp.ConApp {arg, con, targs} =>
+	       O.PrimExp.ConApp {arg = Option.map (arg, fixVarExp),
+				 con = con,
+				 targs = fixConTargs (con, targs)}
+	  | I.PrimExp.Const c => O.PrimExp.Const c
+	  | I.PrimExp.Handle {catch = (x, t), handler, try} =>
+	       O.PrimExp.Handle {catch = (x, fixType t),
+				 handler = fixExp handler,
+				 try = fixExp try}
+	  | I.PrimExp.Lambda l => O.PrimExp.Lambda (fixLambda l)
+	  | I.PrimExp.PrimApp {args, prim, targs} =>
+	       O.PrimExp.PrimApp {args = Vector.map (args, fixVarExp),
+				  prim = prim,
+				  targs = Vector.map (targs, fixType)}
+	  | I.PrimExp.Profile e => O.PrimExp.Profile e
+	  | I.PrimExp.Raise {exn, filePos} =>
+	       O.PrimExp.Raise {exn = fixVarExp exn,
+				filePos = filePos}
+	  | I.PrimExp.Select {offset, tuple} =>
+	       O.PrimExp.Select {offset = offset,
+				 tuple = fixVarExp tuple}
+	  | I.PrimExp.Tuple xs => O.PrimExp.Tuple (Vector.map (xs, fixVarExp))
+	  | I.PrimExp.Var x => O.PrimExp.Var (fixVarExp x)
+      val body = fixExp body
    in
-      p
+      O.Program.T {datatypes = datatypes,
+		   body = body,
+		   overflow = overflow}
    end
 
 end



1.3       +7 -2      mlton/mlton/xml/simplify-types.sig

Index: simplify-types.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- simplify-types.sig	10 Apr 2002 07:02:21 -0000	1.2
+++ simplify-types.sig	25 Feb 2003 02:50:44 -0000	1.3
@@ -5,14 +5,19 @@
  * MLton is released under the GNU General Public License (GPL).
  * Please see the file MLton-LICENSE for license information.
  *)
+
+type int = Int.t
+   
 signature SIMPLIFY_TYPES_STRUCTS = 
    sig
-      include XML_TREE
+      structure Input: XML_TREE
+      structure Output: XML_TREE
+      sharing Input.Atoms = Output.Atoms
    end
 
 signature SIMPLIFY_TYPES = 
    sig
       include SIMPLIFY_TYPES_STRUCTS
       
-      val simplifyTypes: Program.t -> Program.t
+      val simplifyTypes: Input.Program.t -> Output.Program.t
    end



1.9       +5 -2      mlton/mlton/xml/type-check.fun

Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- type-check.fun	10 Jan 2003 20:09:04 -0000	1.8
+++ type-check.fun	25 Feb 2003 02:50:44 -0000	1.9
@@ -124,7 +124,9 @@
 	  let val {decs, result} = Exp.dest exp
 	  in List.foreach (decs, checkDec)
 	     ; checkVarExp result
-	  end) arg
+	  end handle e => (Layout.outputl (Exp.layout exp, Out.error)
+			   ; raise e))
+	 arg
       and checkPrimExp arg: Type.t =
 	 traceCheckPrimExp
 	 (fn (e: PrimExp.t, ty: Type.t) => 
@@ -282,7 +284,8 @@
 		   ; Vector.foreach (decs, fn {ty, lambda, ...} =>
 				     check (ty, checkLambda lambda))
 		   ; unbindTyvars tyvars)
-	 end
+	 end handle e => (Layout.outputl (Dec.layout d, Out.error)
+			  ; raise e)
       val _ =
 	 Vector.foreach
 	 (datatypes, fn {tycon, tyvars, cons} =>



1.11      +8 -12     mlton/mlton/xml/xml-tree.sig

Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- xml-tree.sig	10 Jan 2003 20:52:52 -0000	1.10
+++ xml-tree.sig	25 Feb 2003 02:50:44 -0000	1.11
@@ -30,9 +30,9 @@
 	 
       structure Pat:
 	 sig
-	    datatype t = T of {con: Con.t,
-			       targs: Type.t vector,
-			       arg: (Var.t * Type.t) option}
+	    datatype t = T of {arg: (Var.t * Type.t) option,
+			       con: Con.t,
+			       targs: Type.t vector}
 	 
 	    val falsee: t
 	    val truee: t
@@ -111,8 +111,8 @@
 	    type exp = Lambda.exp
 	       
 	    datatype t =
-	       Exception of {con: Con.t,
-			     arg: Type.t option}
+	       Exception of {arg: Type.t option,
+			     con: Con.t}
 	     | Fun of {decs: {lambda: Lambda.t,
 			      ty: Type.t,
 			      var: Var.t} vector,
@@ -225,14 +225,10 @@
       structure Program:
 	 sig
 	    datatype t =
-	       T of {datatypes: {
+	       T of {datatypes: {cons: {arg: Type.t option,
+					con: Con.t} vector,
 				 tycon: Tycon.t,
-				 tyvars: Tyvar.t vector,
-				 cons: {
-					con: Con.t,
-					arg: Type.t option
-					} vector
-				 } vector,
+				 tyvars: Tyvar.t vector} vector,
 		     body: Exp.t,
 		     (* overflow is SOME only after exceptions have been
 		      * implemented.



1.3       +4 -7      mlton/mlton/xml/xml.fun

Index: xml.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- xml.fun	10 Apr 2002 07:02:21 -0000	1.2
+++ xml.fun	25 Feb 2003 02:50:44 -0000	1.3
@@ -13,15 +13,12 @@
       structure TypeCheck = TypeCheck (structure XmlTree = XmlTree)
       val typeCheck = TypeCheck.typeCheck
 
-      structure SimplifyTypes = SimplifyTypes (open XmlTree)
+      structure SimplifyTypes = SimplifyTypes (structure Input = XmlTree
+					       structure Output = XmlTree)
 
       structure SccFuns = SccFuns (open XmlTree)
 
       structure Simplify = Simplify (structure XmlTree = XmlTree)
-      val simplify =
-	 Simplify.simplify
-(* SimplifyTypes doesn't do anything yet.
- *       o SimplifyTypes.simplifyTypes
- *)
-	 o SccFuns.sccFuns
+      val simplify = Simplify.simplify o SccFuns.sccFuns
+      val simplifyTypes = SimplifyTypes.simplifyTypes
    end



1.3       +1 -0      mlton/mlton/xml/xml.sig

Index: xml.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- xml.sig	10 Apr 2002 07:02:21 -0000	1.2
+++ xml.sig	25 Feb 2003 02:50:44 -0000	1.3
@@ -15,5 +15,6 @@
       include XML_TREE
 
       val simplify: Program.t -> Program.t
+      val simplifyTypes: Program.t -> Program.t
       val typeCheck: Program.t -> unit
    end





-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel