1 (* Copyright (C) 2009 Matthew Fluet.
2 * Copyright (C) 1999-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 (* This pass must happen before polymorphic equality is implemented because
11 * 1. it will make polymorphic equality faster because some types are simpler
12 * 2. it removes uses of polymorphic equality that must return true
14 * This pass computes a "cardinality" of each datatype, which is an
15 * abstraction of the number of values of the datatype.
16 * Zero means the datatype has no values (except for bottom).
17 * One means the datatype has one values (except for bottom).
18 * Many means the datatype has many values.
20 * This pass removes all datatypes whose cardinality is Zero or One
22 * components of tuples
25 * which are such datatypes.
27 * This pass marks constructors as one of
28 * Useless: it never appears in a ConApp.
29 * Transparent: it is the only variant in its datatype
30 * and its argument type does not contain any uses of
31 * Tycon.array or Tycon.vector.
33 * This pass also removes Useless and Transparent constructors.
35 * We must keep track of Transparent constructors whose argument type
36 * uses Tycon.array because of datatypes like the following:
37 * datatype t = T of t array
38 * Such a datatype has Cardinality.Many, but we cannot eliminate
39 * the datatype and replace the lhs by the rhs, i.e. we must keep the
41 * Must do similar things for vectors.
43 * Also, to eliminate as many Transparent constructors as possible, for
44 * something like the following,
45 * datatype t = T of u array
46 * and u = U of t vector
47 * we (arbitrarily) expand one of the datatypes first.
48 * The result will be something like
49 * datatype u = U of u array array
50 * where all uses of t are replaced by u array.
53 functor SimplifyTypes (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
58 structure Cardinality =
60 datatype t = Zero | One | Many
68 val equals: t * t -> bool = op =
87 fn Useless => "useless"
88 | Transparent => "transparent"
91 val layout = Layout.str o toString
103 in fn Bugg => str "Bug"
104 | Delete => str "Delete"
105 | Keep x => seq [str "Keep ", layoutX x]
109 fun transform (Program.T {datatypes, globals, functions, main}) =
111 val {get = conInfo: Con.t -> {rep: ConRep.t ref,
112 args: Type.t vector},
113 set = setConInfo, ...} =
115 (Con.plist, Property.initRaise ("SimplifyTypes.conInfo", Con.layout))
117 Trace.trace ("SimplifyTypes.conInfo",
120 Layout.record [("rep", ConRep.layout (!rep)),
121 ("args", Vector.layout Type.layout args)])
123 val conRep = ! o #rep o conInfo
124 val conArgs = #args o conInfo
125 fun setConRep (con, r) = #rep (conInfo con) := r
128 ("SimplifyTypes.setConRep", Con.layout, ConRep.layout, Unit.layout)
130 val conIsUseful = ConRep.isUseful o conRep
133 ("SimplifyTypes.conIsUseful", Con.layout, Bool.layout)
135 (* Initialize conInfo *)
138 (datatypes, fn Datatype.T {cons, ...} =>
139 Vector.foreach (cons, fn {con, args} =>
140 setConInfo (con, {rep = ref ConRep.Useless,
142 val {get = tyconReplacement: Tycon.t -> Type.t option,
143 set = setTyconReplacement, ...} =
144 Property.getSet (Tycon.plist, Property.initConst NONE)
145 val setTyconReplacement = fn (c, t) => setTyconReplacement (c, SOME t)
146 val {get = tyconInfo: Tycon.t -> {
147 cardinality: Cardinality.t ref,
153 (* tycons whose cardinality depends on mine *)
154 dependents: Tycon.t list ref,
155 isOnWorklist: bool ref
157 set = setTyconInfo, ...} =
159 (Tycon.plist, Property.initRaise ("SimplifyTypes.tyconInfo", Tycon.layout))
162 fun make sel = (! o sel o tyconInfo,
163 fn (t, x) => sel (tyconInfo t) := x)
165 val (tyconNumCons, setTyconNumCons) = make #numCons
166 val (tyconCardinality, _) = make #cardinality
170 (datatypes, fn Datatype.T {tycon, cons} =>
171 setTyconInfo (tycon, {
172 cardinality = ref Cardinality.Zero,
176 isOnWorklist = ref false
178 (* Tentatively mark all constructors appearing in a ConApp as Useful
179 * (some may later be marked as Transparent).
183 fun handleStatement (Statement.T {exp, ...}) =
185 ConApp {con, ...} => setConRep (con, ConRep.Useful)
187 (* Booleans are special because they are generated by primitives. *)
189 List.foreach ([Con.truee, Con.falsee], fn c =>
190 setConRep (c, ConRep.Useful))
191 val _ = Vector.foreach (globals, handleStatement)
195 (Function.blocks f, fn Block.T {statements, ...} =>
196 Vector.foreach (statements, handleStatement)))
200 (* Remove useless constructors from datatypes.
201 * Remove datatypes which have no cons.
205 (datatypes, fn Datatype.T {tycon, cons} =>
207 val cons = Vector.keepAll (cons, conIsUseful o #con)
209 if Vector.isEmpty cons
210 then (setTyconReplacement (tycon, Type.unit)
212 else (#cons (tyconInfo tycon) := cons
213 ; SOME (Datatype.T {tycon = tycon, cons = cons}))
215 (* Build the dependents for each tycon. *)
218 (datatypes, fn Datatype.T {tycon, cons} =>
220 datatype z = datatype Type.dest
221 val {get = setTypeDependents, destroy = destroyTypeDependents} =
225 (fn (t, setTypeDependents) =>
227 Array t => setTypeDependents t
230 List.push (#dependents (tyconInfo tycon'), tycon)
233 | Ref t => setTypeDependents t
235 | Tuple ts => Vector.foreach (ts, setTypeDependents)
236 | Vector t => setTypeDependents t
237 | Weak t => setTypeDependents t
240 Vector.foreach (cons, fn {args, ...} =>
241 Vector.foreach (args, setTypeDependents))
242 val _ = destroyTypeDependents ()
251 (datatypes, fn Datatype.T {tycon, ...} =>
252 display (seq [str "dependents of ",
255 List.layout Tycon.layout
256 (!(#dependents (tyconInfo tycon)))]))
259 local open Type Cardinality
261 fun typeCardinality t =
263 Datatype tycon => tyconCardinality tycon
264 | Ref t => pointerCardinality t
265 | Tuple ts => tupleCardinality ts
266 | Weak t => pointerCardinality t
268 and pointerCardinality (t: Type.t) =
269 case typeCardinality t of
272 and tupleCardinality (ts: Type.t vector) =
275 (Vector.foreach (ts, fn t =>
276 let val c = typeCardinality t
280 | Zero => escape Zero
284 fun conCardinality {args, con = _} = tupleCardinality args
285 (* Compute the tycon cardinalities with a fixed point,
286 * initially assuming every datatype tycon cardinality is Zero.
290 (* list of datatype tycons whose cardinality has not yet stabilized *)
293 (datatypes, [], fn (Datatype.T {tycon, ...}, ac) =>
301 val {cons, cardinality, dependents, isOnWorklist,
302 ...} = tyconInfo tycon
306 let datatype z = datatype Cardinality.t
308 (!cons, Zero, fn (c, ac) =>
309 case conCardinality c of
312 Many => Error.bug "SimplifyTypes.simplify: Many"
317 in isOnWorklist := false
318 ; if Cardinality.equals (c, !cardinality)
320 else (cardinality := c
322 (!dependents, fn tycon =>
324 val {isOnWorklist, ...} =
328 else (isOnWorklist := true
329 ; List.push (worklist, tycon))
341 (datatypes, fn Datatype.T {tycon, ...} =>
342 display (seq [str "cardinality of ",
345 Cardinality.layout (tyconCardinality tycon)]))
347 fun transparent (tycon, con, args) =
348 (setTyconReplacement (tycon, Type.tuple args)
349 ; setConRep (con, ConRep.Transparent)
350 ; setTyconNumCons (tycon, 1))
351 (* "unary" is datatypes with one constructor whose rhs contains an
352 * array (or vector) type.
353 * For datatypes with one variant not containing an array type, eliminate
356 fun containsArrayOrVector (ty: Type.t): bool =
358 datatype z = datatype Type.dest
363 | Tuple ts => Vector.exists (ts, loop)
369 val (datatypes, unary) =
371 (datatypes, ([], []), fn (Datatype.T {tycon, cons}, (datatypes, unary)) =>
373 (* remove all cons with zero cardinality and mark them as useless *)
376 (cons, fn c as {con, ...} =>
377 case conCardinality c of
378 Cardinality.Zero => (setConRep (con, ConRep.Useless)
381 in case Vector.length cons of
382 0 => (setTyconNumCons (tycon, 0)
383 ; setTyconReplacement (tycon, Type.unit)
384 ; (datatypes, unary))
387 val {con, args} = Vector.first cons
389 if Vector.exists (args, containsArrayOrVector)
391 {tycon = tycon, con = con, args = args} :: unary)
392 else (transparent (tycon, con, args)
393 ; (datatypes, unary))
395 | _ => (Datatype.T {tycon = tycon, cons = cons} :: datatypes,
398 fun containsTycon (ty: Type.t, tyc: Tycon.t): bool =
400 datatype z = datatype Type.dest
401 val {get = containsTycon, destroy = destroyContainsTycon} =
405 (fn (t, containsTycon) =>
407 Array t => containsTycon t
409 (case tyconReplacement tyc' of
410 NONE => Tycon.equals (tyc, tyc')
411 | SOME t => containsTycon t)
412 | Tuple ts => Vector.exists (ts, containsTycon)
413 | Ref t => containsTycon t
414 | Vector t => containsTycon t
415 | Weak t => containsTycon t
417 val res = containsTycon ty
418 val () = destroyContainsTycon ()
421 (* Keep the circular transparent tycons, ditch the rest. *)
424 (unary, datatypes, fn ({tycon, con, args}, accum) =>
425 if Vector.exists (args, fn arg => containsTycon (arg, tycon))
426 then Datatype.T {tycon = tycon,
427 cons = Vector.new1 {con = con, args = args}}
429 else (transparent (tycon, con, args)
431 fun makeKeepSimplifyTypes simplifyType ts =
432 Vector.keepAllMap (ts, fn t =>
434 val t = simplifyType t
440 val {get = simplifyType, destroy = destroySimplifyType} =
444 (fn (t, simplifyType) =>
446 val keepSimplifyTypes = makeKeepSimplifyTypes simplifyType
449 Array t => array (simplifyType t)
451 (case tyconReplacement tycon of
454 val t = simplifyType t
455 val _ = setTyconReplacement (tycon, t)
460 | Ref t => reff (simplifyType t)
461 | Tuple ts => Type.tuple (keepSimplifyTypes ts)
462 | Vector t => vector (simplifyType t)
463 | Weak t => weak (simplifyType t)
467 Trace.trace ("SimplifyTypes.simplifyType", Type.layout, Type.layout)
469 fun simplifyTypes ts = Vector.map (ts, simplifyType)
470 val keepSimplifyTypes = makeKeepSimplifyTypes simplifyType
471 (* Simplify constructor argument types. *)
474 (datatypes, fn Datatype.T {tycon, cons} =>
475 (setTyconNumCons (tycon, Vector.length cons)
476 ; Datatype.T {tycon = tycon,
477 cons = Vector.map (cons, fn {con, args} =>
479 args = keepSimplifyTypes args})}))
480 val unitVar = Var.newNoname ()
481 val {get = varInfo: Var.t -> Type.t, set = setVarInfo, ...} =
483 (Var.plist, Property.initRaise ("varInfo", Var.layout))
484 fun simplifyVarType (x: Var.t, t: Type.t): Type.t =
487 fun simplifyMaybeVarType (x: Var.t option, t: Type.t): Type.t =
489 SOME x => simplifyVarType (x, t)
490 | NONE => simplifyType t
491 val oldVarType = varInfo
492 val newVarType = simplifyType o oldVarType
493 fun simplifyVar (x: Var.t): Var.t =
494 if Type.isUnit (newVarType x)
497 val varIsUseless = Type.isUnit o newVarType
498 fun removeUselessVars xs = Vector.keepAll (xs, not o varIsUseless)
501 val xs = removeUselessVars xs
502 in if 1 = Vector.length xs
503 then Var (Vector.first xs)
506 fun simplifyFormals xts =
509 let val t = simplifyVarType (x, t)
514 val typeIsUseful = not o Type.isUnit o simplifyType
515 datatype result = datatype Result.t
516 fun simplifyExp (e: Exp.t): Exp.t result =
518 ConApp {con, args} =>
520 ConRep.Transparent => Keep (tuple args)
522 Keep (ConApp {con = con,
523 args = removeUselessVars args})
524 | ConRep.Useless => Bugg)
525 | PrimApp {prim, targs, args} =>
529 PrimApp {prim = prim,
530 targs = simplifyTypes targs,
531 args = Vector.map (args, simplifyVar)}
533 if 2 = Vector.length args
535 if varIsUseless (Vector.first args)
536 then ConApp {con = Con.truee,
537 args = Vector.new0 ()}
539 else Error.bug "SimplifyTypes.simplifyExp: strange eq/equal PrimApp"
541 in case Prim.name prim of
543 | MLton_equal => equal ()
546 | Select {tuple, offset} =>
548 val ts = Type.deTuple (oldVarType tuple)
550 (ts, 0, (offset, 0), fn (pos, t, (n, offset)) =>
555 andalso not (Vector.existsR
556 (ts, pos + 1, Vector.length ts,
559 else Select {tuple = tuple,
561 else Vector.Continue (n - 1,
565 fn _ => Error.bug "SimplifyTypes.simplifyExp: Select:newOffset")
567 | Tuple xs => Keep (tuple xs)
570 Trace.trace ("SimplifyTypes.simplifyExp",
571 Exp.layout, Result.layout Exp.layout)
573 fun simplifyTransfer (t : Transfer.t): Statement.t vector * Transfer.t =
575 Arith {prim, args, overflow, success, ty} =>
576 (Vector.new0 (), Arith {prim = prim,
577 args = Vector.map (args, simplifyVar),
581 | Bug => (Vector.new0 (), t)
582 | Call {func, args, return} =>
584 Call {func = func, return = return,
585 args = removeUselessVars args})
586 | Case {test, cases = Cases.Con cases, default} =>
589 Vector.keepAll (cases, fn (con, _) =>
590 not (ConRep.isUseless (conRep con)))
592 case (Vector.length cases, default) of
594 | (0, SOME l) => SOME l
596 if n = tyconNumCons (Type.deDatatype (oldVarType test))
602 cases = Cases.Con cases,
604 in case (Vector.length cases, default) of
605 (0, NONE) => (Vector.new0 (), Bug)
607 (Vector.new0 (), Goto {dst = l, args = Vector.new0 ()})
610 val (con, l) = Vector.first cases
612 if ConRep.isUseful (conRep con)
614 (* This case can occur because an array or vector
615 * tycon was kept around.
618 else (* The type has become a tuple. Do the selects. *)
620 val ts = keepSimplifyTypes (conArgs con)
622 if 1 = Vector.length ts
623 then (Vector.new1 test, Vector.new0 ())
628 let val x = Var.newNoname ()
633 exp = Select {tuple = test,
636 in (stmts, Goto {dst = l, args = args})
641 | Case _ => (Vector.new0 (), t)
642 | Goto {dst, args} =>
643 (Vector.new0 (), Goto {dst = dst, args = removeUselessVars args})
644 | Raise xs => (Vector.new0 (), Raise (removeUselessVars xs))
645 | Return xs => (Vector.new0 (), Return (removeUselessVars xs))
646 | Runtime {prim, args, return} =>
647 (Vector.new0 (), Runtime {prim = prim,
648 args = Vector.map (args, simplifyVar),
650 val simplifyTransfer =
652 ("SimplifyTypes.simplifyTransfer", Transfer.layout,
653 Layout.tuple2 (Vector.layout Statement.layout, Transfer.layout))
655 fun simplifyStatement (Statement.T {var, ty, exp}) =
657 val ty = simplifyMaybeVarType (var, ty)
659 (* It is wrong to omit calling simplifyExp when var = NONE because
660 * targs in a PrimApp may still need to be simplified.
662 if not (Type.isUnit ty)
663 orelse Exp.maySideEffect exp
668 (case simplifyExp exp of
672 Keep (Statement.T {var = var, ty = ty, exp = exp}))
675 fun simplifyBlock (Block.T {label, args, statements, transfer}) =
677 val args = simplifyFormals args
680 (statements, 0, [], fn (_, statement, statements) =>
681 case simplifyStatement statement of
682 Bugg => Vector.Done NONE
683 | Delete => Vector.Continue statements
684 | Keep s => Vector.Continue (s :: statements),
685 SOME o Vector.fromListRev)
688 NONE => Block.T {label = label,
690 statements = Vector.new0 (),
694 val (stmts, transfer) = simplifyTransfer transfer
695 val statements = Vector.concat [statements, stmts]
697 Block.T {label = label,
699 statements = statements,
703 fun simplifyFunction f =
705 val {args, mayInline, name, raises, returns, start, ...} =
707 val args = simplifyFormals args
710 Function.dfs (f, fn block =>
711 (List.push (blocks, simplifyBlock block)
713 val returns = Option.map (returns, keepSimplifyTypes)
714 val raises = Option.map (raises, keepSimplifyTypes)
716 Function.new {args = args,
717 blocks = Vector.fromList (!blocks),
718 mayInline = mayInline,
726 [Vector.new1 (Statement.T {var = SOME unitVar,
729 Vector.keepAllMap (globals, fn s =>
730 case simplifyStatement s of
731 Bugg => Error.bug "SimplifyTypes.globals: bind can't fail"
734 val shrink = shrinkFunction {globals = globals}
735 val functions = List.revMap (functions, shrink o simplifyFunction)
737 Program.T {datatypes = datatypes,
739 functions = functions,
741 val _ = destroySimplifyType ()
742 val _ = Program.clearTop program