[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