[hcoop/debian/mlton.git] / mlton / xml / simplify-types.fun

(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-2000 NEC Research Institute.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

functor SimplifyTypes (S: SIMPLIFY_TYPES_STRUCTS): SIMPLIFY_TYPES = 
struct

open S
structure I = Input
structure O = Output
open I.Atoms

structure PowerSetLat =
   struct
      datatype t = T of {isIn: bool ref,
                         whenIn: (unit -> unit) list ref} vector

      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 {get = tyconInfo: Tycon.t -> {used: PowerSetLat.t} option,
           set = setTyconInfo, ...} =
         Property.getSetOnce (Tycon.plist, Property.initConst NONE)
      val _ =
         Vector.foreach
         (datatypes, fn {tycon, tyvars, ...} =>
          setTyconInfo (tycon,
                        SOME {used = PowerSetLat.new (Vector.length tyvars)}))
      val _ =
         Vector.foreach
         (datatypes, fn {cons, tycon, tyvars} =>
          let
             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)
      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
         (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)
      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 (_, 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 
         ("SimplifyTypes.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 
         ("SimplifyTypes.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.make {decs = List.map (decs, fixDec),
                        result = fixVarExp result}
         end
      and fixLambda (l: I.Lambda.t): O.Lambda.t =
         let
            val {arg, argType, body, mayInline} = I.Lambda.dest l
         in
            O.Lambda.make {arg = arg,
                           argType = fixType argType,
                           body = fixExp body,
                           mayInline = mayInline}
         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
                  val cases =
                     case cases of
                        I.Cases.Con v =>
                           O.Cases.Con (Vector.map (v, fn (p, e) =>
                                                    (fixPat p, fixExp e)))
                      | I.Cases.Word (s, v) =>
                           O.Cases.Word
                           (s, Vector.map (v, fn (c, e) => (c, fixExp e)))
               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.map (prim, fixType),
                                  targs = Vector.map (targs, fixType)}
          | I.PrimExp.Profile e => O.PrimExp.Profile e
          | I.PrimExp.Raise {exn, extend} =>
               O.PrimExp.Raise {exn = fixVarExp exn,
                                extend = extend}
          | 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
      O.Program.T {datatypes = datatypes,
                   body = body,
                   overflow = overflow}
   end

end
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
	2	* Jagannathan, and Stephen Weeks.
	3	* Copyright (C) 1997-2000 NEC Research Institute.
	4	*
	5	* MLton is released under a BSD-style license.
	6	* See the file MLton-LICENSE for details.
	7	*)
	8
	9	functor SimplifyTypes (S: SIMPLIFY_TYPES_STRUCTS): SIMPLIFY_TYPES =
	10	struct
	11
	12	open S
	13	structure I = Input
	14	structure O = Output
	15	open I.Atoms
	16
	17	structure PowerSetLat =
	18	struct
	19	datatype t = T of {isIn: bool ref,
	20	whenIn: (unit -> unit) list ref} vector
	21
	22	fun isIn (T v, i) =
	23	! (#isIn (Vector.sub (v, i)))
	24
	25	fun new (size: int) = T (Vector.tabulate (size, fn _ =>
	26	{isIn = ref false,
	27	whenIn = ref []}))
	28
	29	fun add (T v, i) =
	30	let
	31	val {isIn, whenIn, ...} = Vector.sub (v, i)
	32	in
	33	if !isIn
	34	then ()
	35	else (isIn := true
	36	; List.foreach (!whenIn, fn f => f ()))
	37	end
	38
	39	fun whenIn (T v, i, f) =
	40	let
	41	val {isIn, whenIn, ...} = Vector.sub (v, i)
	42	in
	43	if !isIn
	44	then f ()
	45	else List.push (whenIn, f)
	46	end
	47	end
	48
	49	fun simplifyTypes (I.Program.T {body, datatypes, overflow}) =
	50	let
	51	val {get = tyconInfo: Tycon.t -> {used: PowerSetLat.t} option,
	52	set = setTyconInfo, ...} =
	53	Property.getSetOnce (Tycon.plist, Property.initConst NONE)
	54	val _ =
	55	Vector.foreach
	56	(datatypes, fn {tycon, tyvars, ...} =>
	57	setTyconInfo (tycon,
	58	SOME {used = PowerSetLat.new (Vector.length tyvars)}))
	59	val _ =
	60	Vector.foreach
	61	(datatypes, fn {cons, tycon, tyvars} =>
	62	let
	63	val {get = tyvarIndex, set = setTyvarIndex, rem, ...} =
	64	Property.getSet
65	(Tyvar.plist, Property.initRaise ("index", Tyvar.layout))
66	val _ = Vector.foreachi (tyvars, fn (i, a) => setTyvarIndex (a, i))
67	val {used, ...} = valOf (tyconInfo tycon)
68	val {destroy, hom} =
69	I.Type.makeHom
70	{con = (fn (_, tc, ts) =>
71	fn () =>
72	case tyconInfo tc of
73	NONE => Vector.foreach (ts, fn t => t ())
74	\| SOME {used, ...} =>
75	Vector.foreachi
76	(ts, fn (i, t) =>
77	PowerSetLat.whenIn (used, i, t))),
78	var = (fn (_, a) =>
79	let
80	val i = tyvarIndex a
81	in
82	fn () => PowerSetLat.add (used, i)
83	end)}
84	val _ =
85	Vector.foreach
86	(cons, fn {arg, ...} =>
87	case arg of
88	NONE => ()
89	\| SOME t => hom t ())
90	val _ = Vector.foreach (tyvars, rem)
91	val _ = destroy ()
92	in
93	()
94	end)
95	val {get = tyconKeep: Tycon.t -> bool vector option,
96	set = setTyconKeep, ...} =
97	Property.getSetOnce (Tycon.plist, Property.initConst NONE)
98	val {get = conKeep: Con.t -> bool vector option,
99	set = setConKeep, ...} =
100	Property.getSetOnce (Con.plist, Property.initConst NONE)
101	val _ =
102	Vector.foreach
103	(datatypes, fn {cons, tycon, tyvars} =>
104	let
105	val {used, ...} = valOf (tyconInfo tycon)
106	val v =
107	Vector.tabulate
108	(Vector.length tyvars, fn i => PowerSetLat.isIn (used, i))
109	val _ = Vector.foreach (cons, fn {con, ...} =>
110	setConKeep (con, SOME v))
111	val u =
112	if Vector.forall (v, fn b => b)
113	then NONE
114	else SOME v
115	val _ = setTyconKeep (tycon, u)
116	in
117	()
118	end)
119	fun keep (v: 'a vector, bv: bool vector): 'a vector =
120	Vector.keepAllMapi (v, fn (i, a) =>
121	if Vector.sub (bv, i)
122	then SOME a
123	else NONE)
124	val {get = tyvarIsUsed: Tyvar.t -> bool ref, ...} =
125	Property.get (Tyvar.plist, Property.initFun (fn _ => ref false))
126	(* There is some mesiness with promises here for two reasons:
127	* 1. The thunk is to make sure that even though we are using a type
128	* homomorphism, a type variable is only marked as used if it appears
129	* in the output.
130	* 2. The promise is do avoid computing the same output multiple times.
131	* This is necessary because the type homomorphism only memoizes the
132	* mapping from type to thunk, not the thunk's output.
133	*)
134	val {hom = fixType: I.Type.t -> unit -> O.Type.t, ...} =
135	I.Type.makeHom
136	{con = (fn (_, tc, ts) =>
137	Promise.lazy
138	(fn () =>
139	let
140	val ts =
141	case tyconKeep tc of
142	NONE => ts
143	\| SOME bv => keep (ts, bv)
144	val ts = Vector.map (ts, fn t => t ())
145	in
146	O.Type.con (tc, ts)
147	end)),
148	var = (fn (_, a) =>
149	Promise.lazy
150	(fn () => (tyvarIsUsed a := true; O.Type.var a)))}
151	val fixType = fn t => fixType t ()
152	val fixType =
153	Trace.trace
154	("SimplifyTypes.fixType", I.Type.layout, O.Type.layout)
155	fixType
156	val tyvarIsUsed = ! o tyvarIsUsed
157	val datatypes =
158	Vector.map (datatypes, fn {cons, tycon, tyvars} =>
159	{cons = Vector.map (cons, fn {arg, con} =>
160	{arg = Option.map (arg, fixType),
161	con = con}),
162	tycon = tycon,
163	tyvars = (case tyconKeep tycon of
164	NONE => tyvars
165	\| SOME bv => keep (tyvars, bv))})
166	val {get = varKeep: Var.t -> bool vector option,
167	set = setVarKeep, ...} =
168	Property.getSetOnce (Var.plist, Property.initConst NONE)
169	fun fixVarExp (I.VarExp.T {targs, var}): O.VarExp.t =
170	let
171	val targs =
172	case varKeep var of
173	NONE => targs
174	\| SOME bv => keep (targs, bv)
175	in
176	O.VarExp.T {targs = Vector.map (targs, fixType),
177	var = var}
178	end
179	val fixVarExp =
180	Trace.trace
181	("SimplifyTypes.fixVarExp", I.VarExp.layout, O.VarExp.layout)
182	fixVarExp
183	fun fixConTargs (con: Con.t, targs: I.Type.t vector): O.Type.t vector =
184	let
185	val targs =
186	case conKeep con of
187	NONE => targs
188	\| SOME bv => keep (targs, bv)
189	in
190	Vector.map (targs, fixType)
191	end
192	fun fixPat (I.Pat.T {arg, con, targs}): O.Pat.t =
193	O.Pat.T {arg = Option.map (arg, fn (x, t) => (x, fixType t)),
194	con = con,
195	targs = fixConTargs (con, targs)}
196	fun fixDec (d: I.Dec.t): O.Dec.t =
197	case d of
198	I.Dec.Exception {arg, con} =>
199	O.Dec.Exception {arg = Option.map (arg, fixType),
200	con = con}
201	\| I.Dec.Fun {decs, tyvars} =>
202	let
203	val decs =
204	Vector.map (decs, fn {lambda, ty, var} =>
205	{lambda = fixLambda lambda,
206	ty = fixType ty,
207	var = var})
208	val bv = Vector.map (tyvars, tyvarIsUsed)
209	val tyvars = keep (tyvars, bv)
210	val _ =
211	Vector.foreach
212	(decs, fn {var, ...} => setVarKeep (var, SOME bv))
213	in
214	O.Dec.Fun {decs = decs,
215	tyvars = tyvars}
216	end
217	\| I.Dec.MonoVal {exp, ty, var} =>
218	O.Dec.MonoVal {exp = fixPrimExp exp,
219	ty = fixType ty,
220	var = var}
221	\| I.Dec.PolyVal {exp, ty, tyvars, var} =>
222	let
223	val exp = fixExp exp
224	val ty = fixType ty
225	val bv = Vector.map (tyvars, tyvarIsUsed)
226	val _ = setVarKeep (var, SOME bv)
227	in
228	O.Dec.PolyVal {exp = exp,
229	ty = ty,
230	tyvars = keep (tyvars, bv),
231	var = var}
232	end
233	and fixExp (e: I.Exp.t): O.Exp.t =
234	let
235	val {decs, result} = I.Exp.dest e
236	in
237	O.Exp.make {decs = List.map (decs, fixDec),
238	result = fixVarExp result}
239	end
240	and fixLambda (l: I.Lambda.t): O.Lambda.t =
241	let
242	val {arg, argType, body, mayInline} = I.Lambda.dest l
243	in
244	O.Lambda.make {arg = arg,
245	argType = fixType argType,
246	body = fixExp body,
247	mayInline = mayInline}
248	end
249	and fixPrimExp (e: I.PrimExp.t): O.PrimExp.t =
250	case e of
251	I.PrimExp.App {arg, func} => O.PrimExp.App {arg = fixVarExp arg,
252	func = fixVarExp func}
253	\| I.PrimExp.Case {cases, default, test} =>
254	let
255	val cases =
256	case cases of
257	I.Cases.Con v =>
258	O.Cases.Con (Vector.map (v, fn (p, e) =>
259	(fixPat p, fixExp e)))
260	\| I.Cases.Word (s, v) =>
261	O.Cases.Word
262	(s, Vector.map (v, fn (c, e) => (c, fixExp e)))
263	in
264	O.PrimExp.Case {cases = cases,
265	default = Option.map (default, fn (e, r) =>
266	(fixExp e, r)),
267	test = fixVarExp test}
268	end
269	\| I.PrimExp.ConApp {arg, con, targs} =>
270	O.PrimExp.ConApp {arg = Option.map (arg, fixVarExp),
271	con = con,
272	targs = fixConTargs (con, targs)}
273	\| I.PrimExp.Const c => O.PrimExp.Const c
274	\| I.PrimExp.Handle {catch = (x, t), handler, try} =>
275	O.PrimExp.Handle {catch = (x, fixType t),
276	handler = fixExp handler,
277	try = fixExp try}
278	\| I.PrimExp.Lambda l => O.PrimExp.Lambda (fixLambda l)
279	\| I.PrimExp.PrimApp {args, prim, targs} =>
280	O.PrimExp.PrimApp {args = Vector.map (args, fixVarExp),
281	prim = Prim.map (prim, fixType),
282	targs = Vector.map (targs, fixType)}
283	\| I.PrimExp.Profile e => O.PrimExp.Profile e
284	\| I.PrimExp.Raise {exn, extend} =>
285	O.PrimExp.Raise {exn = fixVarExp exn,
286	extend = extend}
287	\| I.PrimExp.Select {offset, tuple} =>
288	O.PrimExp.Select {offset = offset,
289	tuple = fixVarExp tuple}
290	\| I.PrimExp.Tuple xs => O.PrimExp.Tuple (Vector.map (xs, fixVarExp))
291	\| I.PrimExp.Var x => O.PrimExp.Var (fixVarExp x)
292	val body = fixExp body
293	in
294	O.Program.T {datatypes = datatypes,
295	body = body,
296	overflow = overflow}
297	end
298
299	end