[MLton-commit] r6764
Matthew Fluet
fluet at mlton.org
Tue Aug 19 15:16:05 PDT 2008
Unify removeUnused optimization pass for SSA and SSA2 ILs.
----------------------------------------------------------------------
U mlton/trunk/mlton/ssa/remove-unused.fun
U mlton/trunk/mlton/ssa/remove-unused.sig
U mlton/trunk/mlton/ssa/remove-unused2.fun
U mlton/trunk/mlton/ssa/remove-unused2.sig
A mlton/trunk/regression/rem-unused.1.ok
A mlton/trunk/regression/rem-unused.1.sml
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/ssa/remove-unused.fun
===================================================================
--- mlton/trunk/mlton/ssa/remove-unused.fun 2008-08-19 22:15:58 UTC (rev 6763)
+++ mlton/trunk/mlton/ssa/remove-unused.fun 2008-08-19 22:16:03 UTC (rev 6764)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -6,313 +6,374 @@
* See the file MLton-LICENSE for details.
*)
-functor RemoveUnused (S: REMOVE_UNUSED_STRUCTS): REMOVE_UNUSED =
+functor RemoveUnused (S: REMOVE_UNUSED_STRUCTS): REMOVE_UNUSED =
struct
+type int = Int.t
+
open S
open Exp Transfer
-type int = Int.t
-
structure Used =
- struct
- structure L = TwoPointLattice (val bottom = "unused"
- val top = "used")
- open L
- val use = makeTop
- val isUsed = isTop
- val whenUsed = addHandler
- end
+ struct
+ structure L = TwoPointLattice (val bottom = "unused"
+ val top = "used")
+ open L
+ val use = makeTop
+ val isUsed = isTop
+ val whenUsed = addHandler
+ end
structure Coned =
- struct
- structure L = TwoPointLattice (val bottom = "not coned"
- val top = "coned")
- open L
- val con = makeTop
- val isConed = isTop
- val whenConed = addHandler
- end
+ struct
+ structure L = TwoPointLattice (val bottom = "not coned"
+ val top = "coned")
+ open L
+ val con = makeTop
+ val isConed = isTop
+ val whenConed = addHandler
+ end
structure Deconed =
- struct
- structure L = TwoPointLattice (val bottom = "not deconed"
- val top = "deconed")
- open L
- val decon = makeTop
- val isDeconed = isTop
- end
+ struct
+ structure L = TwoPointLattice (val bottom = "not deconed"
+ val top = "deconed")
+ open L
+ val decon = makeTop
+ val isDeconed = isTop
+ end
structure MayReturn =
- struct
- structure L = TwoPointLattice (val bottom = "does not return"
- val top = "may return")
- open L
- val return = makeTop
- val mayReturn = isTop
- val whenReturns = addHandler
- end
+ struct
+ structure L = TwoPointLattice (val bottom = "does not return"
+ val top = "may return")
+ open L
+ val return = makeTop
+ val mayReturn = isTop
+ val whenReturns = addHandler
+ end
structure MayRaise =
- struct
- structure L = TwoPointLattice (val bottom = "does not raise"
- val top = "may raise")
- open L
- val raisee = makeTop
- val mayRaise = isTop
- val whenRaises = addHandler
- end
+ struct
+ structure L = TwoPointLattice (val bottom = "does not raise"
+ val top = "may raise")
+ open L
+ val raisee = makeTop
+ val mayRaise = isTop
+ val whenRaises = addHandler
+ end
structure VarInfo =
struct
- datatype t = T of {used: Used.t}
+ datatype t = T of {ty: Type.t,
+ used: Used.t}
- fun layout (T {used, ...}) = Used.layout used
+ fun layout (T {used, ...}) = Used.layout used
- local
- fun make f (T r) = f r
- in
- val used = make #used
- end
+ local
+ fun make f (T r) = f r
+ in
+ val ty = make #ty
+ val used = make #used
+ end
- fun new (): t = T {used = Used.new ()}
+ fun new (ty : Type.t): t = T {ty = ty,
+ used = Used.new ()}
- val use = Used.use o used
- val isUsed = Used.isUsed o used
- fun whenUsed (vi, th) = Used.whenUsed (used vi, th)
+ val use = Used.use o used
+ val isUsed = Used.isUsed o used
+ fun whenUsed (vi, th) = Used.whenUsed (used vi, th)
end
-structure TypeInfo =
- struct
- datatype t = T of {deconed: bool ref}
+structure ConInfo =
+ struct
+ datatype t = T of {args: (VarInfo.t * Type.t) vector,
+ coned: Coned.t,
+ deconed: Deconed.t,
+ dummy: {con: Con.t, args: Type.t vector,
+ exp: Exp.t}}
- local
- fun make f (T r) = f r
- fun make' f = (make f, ! o (make f))
- in
- val (deconed', _) = make' #deconed
- end
+ fun layout (T {args, coned, deconed, ...}) =
+ Layout.record [("args", Vector.layout (VarInfo.layout o #1) args),
+ ("coned", Coned.layout coned),
+ ("deconed", Deconed.layout deconed)]
- fun new (): t = T {deconed = ref false}
- end
+ local
+ fun make f (T r) = f r
+ in
+ val args = make #args
+ val coned = make #coned
+ val deconed = make #deconed
+ val dummy = make #dummy
+ end
-structure TyconInfo =
- struct
- datatype t = T of {cons: {con: Con.t, args: Type.t vector} vector,
- numCons: int ref}
+ val con = Coned.con o coned
+ val isConed = Coned.isConed o coned
+ fun whenConed (ci, th) = Coned.whenConed (coned ci, th)
- local
- fun make f (T r) = f r
- fun make' f = (make f, ! o (make f))
- in
- val cons = make #cons
- val (numCons', numCons) = make' #numCons
- end
+ val decon = Deconed.decon o deconed
+ val isDeconed = Deconed.isDeconed o deconed
- fun new {cons: {con: Con.t, args: Type.t vector} vector}: t
- = T {cons = cons,
- numCons = ref ~1}
- end
+ fun new {args: Type.t vector,
+ dummy: {con: Con.t, args: Type.t vector
+ , exp: Exp.t}}: t =
+ T {args = Vector.map (args, fn ty => (VarInfo.new ty, ty)),
+ coned = Coned.new (),
+ deconed = Deconed.new (),
+ dummy = dummy}
+ end
-structure ConInfo =
- struct
- datatype t = T of {args: (VarInfo.t * Type.t) vector,
- coned: Coned.t,
- deconed: Deconed.t,
- dummy: Exp.t option ref,
- tycon: Tycon.t}
+structure TyconInfo =
+ struct
+ datatype t = T of {cons: Con.t vector,
+ dummy: {con: Con.t, args: Type.t vector},
+ numCons: int ref,
+ used: Used.t}
- fun layout (T {args, coned, deconed, ...})
- = Layout.record [("args", Vector.layout (VarInfo.layout o #1) args),
- ("coned", Coned.layout coned),
- ("deconed", Deconed.layout deconed)]
+ fun layout (T {used, ...}) =
+ Layout.record [("used", Used.layout used)]
- local
- fun make f (T r) = f r
- in
- val args = make #args
- val coned = make #coned
- val deconed = make #deconed
- val dummy = make #dummy
- val tycon = make #tycon
- end
+ local
+ fun make f (T r) = f r
+ fun make' f = (make f, ! o (make f))
+ in
+ val cons = make #cons
+ val dummy = make #dummy
+ val (numCons', numCons) = make' #numCons
+ val used = make #used
+ end
- val con = Coned.con o coned
- val isConed = Coned.isConed o coned
- fun whenConed (ci, th) = Coned.whenConed (coned ci, th)
+ fun new {cons: Con.t vector,
+ dummy: {con: Con.t, args: Type.t vector}}: t =
+ T {cons = cons,
+ dummy = dummy,
+ numCons = ref ~1,
+ used = Used.new ()}
+ end
- val decon = Deconed.decon o deconed
- val isDeconed = Deconed.isDeconed o deconed
+structure TypeInfo =
+ struct
+ datatype t = T of {deconed: bool ref,
+ simplify: Type.t option ref,
+ used: bool ref}
- fun new {args: Type.t vector, tycon: Tycon.t}: t
- = T {args = Vector.map (args, fn t => (VarInfo.new (), t)),
- coned = Coned.new (),
- deconed = Deconed.new (),
- dummy = ref NONE,
- tycon = tycon}
- end
+ local
+ fun make f (T r) = f r
+ fun make' f = (make f, ! o (make f))
+ in
+ val (deconed', _) = make' #deconed
+ val (simplify', _) = make' #simplify
+ val (used', _) = make' #used
+ end
+ fun new (): t = T {deconed = ref false,
+ simplify = ref NONE,
+ used = ref false}
+ end
+
structure FuncInfo =
- struct
- datatype t = T of {args: (VarInfo.t * Type.t) vector,
- bugLabel: Label.t option ref,
- mayRaise: MayRaise.t,
- mayReturn: MayReturn.t,
- raiseLabel: Label.t option ref,
- raises: (VarInfo.t * Type.t) vector option,
- returnLabel: Label.t option ref,
- returns: (VarInfo.t * Type.t) vector option,
- used: Used.t,
- wrappers: Block.t list ref}
+ struct
+ datatype t = T of {args: (VarInfo.t * Type.t) vector,
+ bugLabel: Label.t option ref,
+ mayRaise: MayRaise.t,
+ mayReturn: MayReturn.t,
+ raiseLabel: Label.t option ref,
+ raises: (VarInfo.t * Type.t) vector option,
+ returnLabel: Label.t option ref,
+ returns: (VarInfo.t * Type.t) vector option,
+ used: Used.t,
+ wrappers: Block.t list ref}
- fun layout (T {args,
- mayRaise, mayReturn,
- raises, returns,
- used,
- ...})
- = Layout.record [("args", Vector.layout
- (Layout.tuple2 (VarInfo.layout, Type.layout))
- args),
- ("mayRaise", MayRaise.layout mayRaise),
- ("mayReturn", MayReturn.layout mayReturn),
- ("raises", Option.layout
- (Vector.layout
- (Layout.tuple2 (VarInfo.layout, Type.layout)))
- raises),
- ("returns", Option.layout
- (Vector.layout
+ fun layout (T {args,
+ mayRaise, mayReturn,
+ raises, returns,
+ used,
+ ...}) =
+ Layout.record [("args", Vector.layout
+ (Layout.tuple2 (VarInfo.layout, Type.layout))
+ args),
+ ("mayRaise", MayRaise.layout mayRaise),
+ ("mayReturn", MayReturn.layout mayReturn),
+ ("raises", Option.layout
+ (Vector.layout
(Layout.tuple2 (VarInfo.layout, Type.layout)))
- returns),
- ("used", Used.layout used)]
+ raises),
+ ("returns", Option.layout
+ (Vector.layout
+ (Layout.tuple2 (VarInfo.layout, Type.layout)))
+ returns),
+ ("used", Used.layout used)]
- local
- fun make f (T r) = f r
- fun make' f = (make f, ! o (make f))
- in
- val args = make #args
- val mayRaise' = make #mayRaise
- val mayReturn' = make #mayReturn
- val raiseLabel = make #raiseLabel
- val raises = make #raises
- val returnLabel = make #returnLabel
- val returns = make #returns
- val used = make #used
- val (wrappers', wrappers) = make' #wrappers
- end
+ local
+ fun make f (T r) = f r
+ fun make' f = (make f, ! o (make f))
+ in
+ val args = make #args
+ val mayRaise' = make #mayRaise
+ val mayReturn' = make #mayReturn
+ val raiseLabel = make #raiseLabel
+ val raises = make #raises
+ val returnLabel = make #returnLabel
+ val returns = make #returns
+ val used = make #used
+ val (wrappers', wrappers) = make' #wrappers
+ end
- val raisee = MayRaise.raisee o mayRaise'
- val mayRaise = MayRaise.mayRaise o mayRaise'
- fun whenRaises (fi, th) = MayRaise.whenRaises (mayRaise' fi, th)
- fun flowRaises (fi, fi') = MayRaise.<= (mayRaise' fi, mayRaise' fi')
+ val raisee = MayRaise.raisee o mayRaise'
+ val mayRaise = MayRaise.mayRaise o mayRaise'
+ fun whenRaises (fi, th) = MayRaise.whenRaises (mayRaise' fi, th)
+ fun flowRaises (fi, fi') = MayRaise.<= (mayRaise' fi, mayRaise' fi')
- val return = MayReturn.return o mayReturn'
- fun whenReturns (fi, th) = MayReturn.whenReturns (mayReturn' fi, th)
- val mayReturn = MayReturn.mayReturn o mayReturn'
- fun flowReturns (fi, fi') = MayReturn.<= (mayReturn' fi, mayReturn' fi')
+ val return = MayReturn.return o mayReturn'
+ fun whenReturns (fi, th) = MayReturn.whenReturns (mayReturn' fi, th)
+ val mayReturn = MayReturn.mayReturn o mayReturn'
+ fun flowReturns (fi, fi') = MayReturn.<= (mayReturn' fi, mayReturn' fi')
- val use = Used.use o used
- val isUsed = Used.isUsed o used
- fun whenUsed (fi, th) = Used.whenUsed (used fi, th)
+ val use = Used.use o used
+ val isUsed = Used.isUsed o used
+ fun whenUsed (fi, th) = Used.whenUsed (used fi, th)
- fun new {args: (VarInfo.t * Type.t) vector,
- raises: (VarInfo.t * Type.t) vector option,
- returns: (VarInfo.t * Type.t) vector option}: t
- = T {args = args,
- bugLabel = ref NONE,
- mayRaise = MayRaise.new (),
- mayReturn = MayReturn.new (),
- raiseLabel = ref NONE,
- raises = raises,
- returnLabel = ref NONE,
- returns = returns,
- used = Used.new (),
- wrappers = ref []}
- end
+ fun new {args: (VarInfo.t * Type.t) vector,
+ raises: (VarInfo.t * Type.t) vector option,
+ returns: (VarInfo.t * Type.t) vector option}: t =
+ T {args = args,
+ bugLabel = ref NONE,
+ mayRaise = MayRaise.new (),
+ mayReturn = MayReturn.new (),
+ raiseLabel = ref NONE,
+ raises = raises,
+ returnLabel = ref NONE,
+ returns = returns,
+ used = Used.new (),
+ wrappers = ref []}
+ end
structure LabelInfo =
- struct
- datatype t = T of {args: (VarInfo.t * Type.t) vector,
- func: FuncInfo.t,
- used: Used.t,
- wrappers: (Type.t vector * Label.t) list ref}
+ struct
+ datatype t = T of {args: (VarInfo.t * Type.t) vector,
+ func: FuncInfo.t,
+ used: Used.t,
+ wrappers: (Type.t vector * Label.t) list ref}
- fun layout (T {args, used, ...})
- = Layout.record [("args", Vector.layout (VarInfo.layout o #1) args),
- ("used", Used.layout used)]
+ fun layout (T {args, used, ...}) =
+ Layout.record [("args", Vector.layout (VarInfo.layout o #1) args),
+ ("used", Used.layout used)]
- fun new {args: (VarInfo.t * Type.t) vector, func: FuncInfo.t}: t
- = T {args = args,
- func = func,
- used = Used.new (),
- wrappers = ref []}
+ fun new {args: (VarInfo.t * Type.t) vector, func: FuncInfo.t}: t =
+ T {args = args,
+ func = func,
+ used = Used.new (),
+ wrappers = ref []}
- local
- fun make f (T r) = f r
- fun make' f = (make f, ! o (make f))
- in
- val args = make #args
- val func = make #func
- val used = make #used
- val (wrappers', wrappers) = make' #wrappers
- end
+ local
+ fun make f (T r) = f r
+ fun make' f = (make f, ! o (make f))
+ in
+ val args = make #args
+ val func = make #func
+ val used = make #used
+ val (wrappers', wrappers) = make' #wrappers
+ end
- val use = Used.use o used
- val isUsed = Used.isUsed o used
- fun whenUsed (li, th) = Used.whenUsed (used li, th)
- end
+ val use = Used.use o used
+ val isUsed = Used.isUsed o used
+ fun whenUsed (li, th) = Used.whenUsed (used li, th)
+ end
-fun remove (Program.T {datatypes, globals, functions, main})
- = let
- val {get = varInfo: Var.t -> VarInfo.t, ...}
- = Property.get
- (Var.plist,
- Property.initFun (fn _ => VarInfo.new ()))
- val {get = typeInfo: Type.t -> TypeInfo.t,
- destroy, ...}
- = Property.destGet
- (Type.plist,
- Property.initFun (fn _ => TypeInfo.new ()))
+fun remove (Program.T {datatypes, globals, functions, main}) =
+ let
+ val {get = conInfo: Con.t -> ConInfo.t,
+ set = setConInfo, ...} =
+ Property.getSetOnce
+ (Con.plist,
+ Property.initRaise ("RemoveUnused.conInfo", Con.layout))
+ fun newConInfo (con, args, dummy) =
+ setConInfo (con, ConInfo.new {args = args, dummy = dummy})
val {get = tyconInfo: Tycon.t -> TyconInfo.t,
- set = setTyconInfo, ...}
- = Property.getSetOnce
- (Tycon.plist,
- Property.initRaise ("RemovedUnused.tyconInfo", Tycon.layout))
+ set = setTyconInfo, ...} =
+ Property.getSetOnce
+ (Tycon.plist,
+ Property.initRaise ("RemoveUnused.tyconInfo", Tycon.layout))
+ fun newTyconInfo (tycon, cons, dummy) =
+ setTyconInfo (tycon, TyconInfo.new {cons = cons, dummy = dummy})
- val {get = conInfo: Con.t -> ConInfo.t,
- set = setConInfo, ...}
- = Property.getSetOnce
- (Con.plist,
- Property.initRaise ("RemoveUnused.conInfo", Con.layout))
- fun newConInfo (con, args, tycon)
- = setConInfo (con, ConInfo.new {args = args, tycon = tycon})
+ val {get = typeInfo: Type.t -> TypeInfo.t,
+ destroy, ...} =
+ Property.destGet
+ (Type.plist,
+ Property.initFun (fn _ => TypeInfo.new ()))
- val {get = labelInfo: Label.t -> LabelInfo.t,
- set = setLabelInfo, ...}
- = Property.getSetOnce
- (Label.plist,
- Property.initRaise ("RemoveUnused.labelInfo", Label.layout))
+ val {get = varInfo: Var.t -> VarInfo.t,
+ set = setVarInfo, ...} =
+ Property.getSetOnce
+ (Var.plist,
+ Property.initRaise ("RemoveUnused.varInfo", Var.layout))
+ fun newVarInfo (var, ty) =
+ setVarInfo (var, VarInfo.new ty)
- val {get = funcInfo: Func.t -> FuncInfo.t,
- set = setFuncInfo, ...}
- = Property.getSetOnce
- (Func.plist,
- Property.initRaise ("RemoveUnused.funcInfo", Func.layout))
+ val {get = labelInfo: Label.t -> LabelInfo.t,
+ set = setLabelInfo, ...} =
+ Property.getSetOnce
+ (Label.plist,
+ Property.initRaise ("RemoveUnused.labelInfo", Label.layout))
+ val {get = funcInfo: Func.t -> FuncInfo.t,
+ set = setFuncInfo, ...} =
+ Property.getSetOnce
+ (Func.plist,
+ Property.initRaise ("RemoveUnused.funcInfo", Func.layout))
+
+ val usedTycon = TyconInfo.used o tyconInfo
+ val useTycon = Used.use o usedTycon
+ fun visitTycon (tycon: Tycon.t) = useTycon tycon
+ val isUsedTycon = Used.isUsed o usedTycon
+
+ fun visitType (ty: Type.t) =
+ let
+ val ti = typeInfo ty
+ val used = TypeInfo.used' ti
+ in
+ if !used
+ then ()
+ else let
+ val () = used := true
+ datatype z = datatype Type.dest
+ val () =
+ case Type.dest ty of
+ Array ty => visitType ty
+ | Datatype tycon => visitTycon tycon
+ | Ref ty => visitType ty
+ | Tuple tys => Vector.foreach (tys, visitType)
+ | Vector ty => visitType ty
+ | Weak ty => visitType ty
+ | _ => ()
+ in
+ ()
+ end
+ end
+ val visitTypeTh = fn ty => fn () => visitType ty
+
+ val tyVar = VarInfo.ty o varInfo
val usedVar = VarInfo.used o varInfo
val useVar = Used.use o usedVar
- fun flowVarInfoTyVarInfoTy ((vi, _), (vi', _))
- = Used.<= (VarInfo.used vi, VarInfo.used vi')
- fun flowVarInfoTysVarInfoTys (xs, ys)
- = Vector.foreach2 (xs, ys, flowVarInfoTyVarInfoTy)
- fun flowVarInfoTyVar ((vi, _), x)
- = Used.<= (VarInfo.used vi, usedVar x)
- fun flowVarInfoTysVars (xs, ys)
- = Vector.foreach2 (xs, ys, flowVarInfoTyVar)
val isUsedVar = Used.isUsed o usedVar
+ val whenUsedVar = fn (var, th) => VarInfo.whenUsed (varInfo var, th)
+ fun flowVarInfoTyVarInfoTy ((vi, _), (vi', _)) =
+ Used.<= (VarInfo.used vi, VarInfo.used vi')
+ fun flowVarInfoTysVarInfoTys (xs, ys) =
+ Vector.foreach2 (xs, ys, flowVarInfoTyVarInfoTy)
+ fun flowVarInfoTyVar ((vi, _), x) =
+ Used.<= (VarInfo.used vi, usedVar x)
+ fun flowVarInfoTysVars (xs, ys) =
+ Vector.foreach2 (xs, ys, flowVarInfoTyVar)
+ val newVarInfo = fn (var, ty) =>
+ (newVarInfo (var, ty)
+ ; whenUsedVar (var, visitTypeTh ty))
+
val visitLabelInfo = LabelInfo.use
val visitLabelInfoTh = fn li => fn () => visitLabelInfo li
val visitLabel = visitLabelInfo o labelInfo
@@ -322,440 +383,440 @@
fun visitVar (x: Var.t) = useVar x
fun visitVars (xs: Var.t Vector.t) = Vector.foreach (xs, visitVar)
- fun visitExp (e: Exp.t)
- = case e
- of ConApp {con, args}
- => let
+ fun visitExp (e: Exp.t) =
+ case e of
+ ConApp {con, args} =>
+ let
val ci = conInfo con
- val _ = ConInfo.con ci
- val _ = flowVarInfoTysVars (ConInfo.args ci, args)
- in
+ val () = ConInfo.con ci
+ val () = flowVarInfoTysVars (ConInfo.args ci, args)
+ in
()
- end
- | PrimApp {prim, targs, args}
- => let
- val _ = visitVars args
+ end
+ | Const _ => ()
+ | PrimApp {prim, args, ...} =>
+ let
+ val () = visitVars args
datatype z = datatype Type.dest
- fun decon t
- = let
- val ti = typeInfo t
+ fun deconType (ty: Type.t) =
+ let
+ val ti = typeInfo ty
val deconed = TypeInfo.deconed' ti
- in
+ in
if !deconed
- then ()
- else (deconed := true;
- case Type.dest t
- of Datatype t
- => Vector.foreach
- (TyconInfo.cons (tyconInfo t),
- fn {con, ...} =>
- let
- val ci = conInfo con
- val _ = ConInfo.decon ci
- val _
- = Vector.foreach
- (ConInfo.args ci, fn (x, t) =>
- (VarInfo.use x; decon t))
- in
- ()
- end)
- | Tuple ts => Vector.foreach (ts, decon)
- | Vector t => decon t
- | _ => ())
- end
- in
- case (Prim.name prim, Vector.length targs)
- of (Prim.Name.MLton_eq, 1)
- (* MLton_eq may be used on datatypes used as enums. *)
- => decon (Vector.sub (targs, 0))
- | (Prim.Name.MLton_equal, 1)
- (* MLton_equal will be expanded by poly-equal into uses
- * of constructors as patterns.
- *)
- => decon (Vector.sub (targs, 0))
- | (Prim.Name.MLton_hash, 1)
- (* MLton_hash will be expanded by poly-hash into uses
- * of constructors as patterns.
- *)
- => decon (Vector.sub (targs, 0))
+ then ()
+ else let
+ val () = deconed := true
+ val () =
+ case Type.dest ty of
+ Datatype t =>
+ Vector.foreach
+ (TyconInfo.cons (tyconInfo t),
+ fn con => deconCon con)
+ | Tuple ts => Vector.foreach (ts, deconType)
+ | Vector t => deconType t
+ | _ => ()
+ in
+ ()
+ end
+ end
+ and deconCon con =
+ let
+ val ci = conInfo con
+ val () = ConInfo.decon ci
+ val () =
+ Vector.foreach
+ (ConInfo.args ci, fn (x, t) =>
+ (VarInfo.use x
+ ; deconType t))
+ in
+ ()
+ end
+ val () =
+ case Prim.name prim of
+ Prim.Name.MLton_eq =>
+ (* MLton_eq may be used on datatypes used as enums. *)
+ deconType (tyVar (Vector.sub (args, 0)))
+ | Prim.Name.MLton_equal =>
+ (* MLton_equal will be expanded by poly-equal into uses
+ * of constructors as patterns.
+ *)
+ deconType (tyVar (Vector.sub (args, 0)))
+ | Prim.Name.MLton_hash =>
+ (* MLton_hash will be expanded by poly-hash into uses
+ * of constructors as patterns.
+ *)
+ deconType (tyVar (Vector.sub (args, 0)))
(*
- | (Prim.Name.MLton_size, 1)
- => decon (Vector.sub (targs, 0))
+ | Prim.Name.MLton_size =>
+ deconType (tyVar (Vector.sub (args, 0)))
*)
- | _ => ()
- end
- | Select {tuple, ...} => visitVar tuple
- | Tuple xs => visitVars xs
- | Var x => visitVar x
- | _ => ()
+ | _ => ()
+ in
+ ()
+ end
+ | Profile _ => ()
+ | Select {tuple, ...} => visitVar tuple
+ | Tuple xs => visitVars xs
+ | Var x => visitVar x
val visitExpTh = fn e => fn () => visitExp e
- fun maybeVisitVarExp (var, exp)
- = Option.app (var, fn var => VarInfo.whenUsed (varInfo var, visitExpTh exp))
- fun visitStatement (Statement.T {exp, var, ...})
- = if Exp.maySideEffect exp
- then visitExp exp
- else maybeVisitVarExp (var, exp)
- fun visitTransfer (t: Transfer.t, fi: FuncInfo.t)
- = case t
- of Arith {args, overflow, success, ...}
- => (visitVars args;
- visitLabel overflow;
- visitLabel success)
- | Bug => ()
- | Call {func, args, return}
- => let
+ fun maybeVisitVarExp (var, exp) =
+ Option.app (var, fn var =>
+ VarInfo.whenUsed (varInfo var, visitExpTh exp))
+ fun visitStatement (Statement.T {exp, var, ty, ...}) =
+ (Option.app (var, fn var => newVarInfo (var, ty))
+ ; if Exp.maySideEffect exp
+ then (visitType ty
+ ; visitExp exp)
+ else maybeVisitVarExp (var, exp))
+ fun visitTransfer (t: Transfer.t, fi: FuncInfo.t) =
+ case t of
+ Arith {args, overflow, success, ty, ...} =>
+ (visitVars args
+ ; visitLabel overflow
+ ; visitLabel success
+ ; visitType ty)
+ | Bug => ()
+ | Call {args, func, return} =>
+ let
datatype u = None
| Caller
| Some of Label.t
- val (cont, handler)
- = case return
- of Return.Dead => (None, None)
- | Return.NonTail {cont, handler}
- => (Some cont,
- case handler of
- Handler.Caller => Caller
- | Handler.Dead => None
- | Handler.Handle h => Some h)
- | Return.Tail => (Caller, Caller)
+ val (cont, handler) =
+ case return of
+ Return.Dead => (None, None)
+ | Return.NonTail {cont, handler} =>
+ (Some cont,
+ case handler of
+ Handler.Caller => Caller
+ | Handler.Dead => None
+ | Handler.Handle h => Some h)
+ | Return.Tail => (Caller, Caller)
val fi' = funcInfo func
- in
- flowVarInfoTysVars (FuncInfo.args fi', args);
- case cont
- of None => ()
- | Caller
- => (case (FuncInfo.returns fi, FuncInfo.returns fi')
- of (SOME xts, SOME xts')
- => flowVarInfoTysVarInfoTys (xts, xts')
- | _ => ();
- FuncInfo.flowReturns (fi', fi))
- | Some l
- => let
- val li = labelInfo l
- in
- Option.app
- (FuncInfo.returns fi', fn xts =>
- flowVarInfoTysVarInfoTys
- (LabelInfo.args li, xts));
- FuncInfo.whenReturns (fi', visitLabelInfoTh li)
- end;
- case handler
- of None => ()
- | Caller
- => (case (FuncInfo.raises fi, FuncInfo.raises fi')
- of (SOME xts, SOME xts')
- => flowVarInfoTysVarInfoTys (xts, xts')
- | _ => ();
- FuncInfo.flowRaises (fi', fi))
- | Some l
- => let
- val li = labelInfo l
- in
- Option.app
- (FuncInfo.raises fi', fn xts =>
- flowVarInfoTysVarInfoTys
- (LabelInfo.args li, xts));
- FuncInfo.whenRaises (fi', visitLabelInfoTh li)
- end;
- visitFuncInfo fi'
- end
- | Case {test, cases, default}
- => let
- val _ = visitVar test
- in
+ val () = flowVarInfoTysVars (FuncInfo.args fi', args)
+ val () =
+ case cont of
+ None => ()
+ | Caller =>
+ let
+ val () =
+ case (FuncInfo.returns fi,
+ FuncInfo.returns fi') of
+ (SOME xts, SOME xts') =>
+ flowVarInfoTysVarInfoTys (xts, xts')
+ | _ => ()
+ val () = FuncInfo.flowReturns (fi', fi)
+ in
+ ()
+ end
+ | Some l =>
+ let
+ val li = labelInfo l
+ val () =
+ Option.app
+ (FuncInfo.returns fi', fn xts =>
+ flowVarInfoTysVarInfoTys
+ (LabelInfo.args li, xts))
+ val () =
+ FuncInfo.whenReturns
+ (fi', visitLabelInfoTh li)
+ in
+ ()
+ end
+ val () =
+ case handler of
+ None => ()
+ | Caller =>
+ let
+ val () =
+ case (FuncInfo.raises fi,
+ FuncInfo.raises fi') of
+ (SOME xts, SOME xts') =>
+ flowVarInfoTysVarInfoTys (xts, xts')
+ | _ => ()
+ val () = FuncInfo.flowRaises (fi', fi)
+ in
+ ()
+ end
+ | Some l =>
+ let
+ val li = labelInfo l
+ val () =
+ Option.app
+ (FuncInfo.raises fi', fn xts =>
+ flowVarInfoTysVarInfoTys
+ (LabelInfo.args li, xts))
+ val () =
+ FuncInfo.whenRaises (fi', visitLabelInfoTh li)
+ in
+ ()
+ end
+ val () = visitFuncInfo fi'
+ in
+ ()
+ end
+ | Case {test, cases, default} =>
+ let
+ val () = visitVar test
+ in
case cases of
Cases.Word (_, cs) =>
(Vector.foreach (cs, visitLabel o #2)
; Option.app (default, visitLabel))
- | Cases.Con cases
- => if Vector.length cases = 0
- then Option.app (default, visitLabel)
- else let
- val _
- = Vector.foreach
- (cases, fn (con, l) =>
- let
- val ci = conInfo con
- val _ = ConInfo.decon ci
- val li = labelInfo l
- val _
- = flowVarInfoTysVarInfoTys
- (LabelInfo.args li, ConInfo.args ci)
- val _
- = ConInfo.whenConed
- (ci, fn () => visitLabelInfo li)
- in
- ()
- end)
- val cons
- = TyconInfo.cons
- (tyconInfo
- (ConInfo.tycon
- (conInfo (#1 (Vector.sub (cases, 0))))))
- in
- case default
- of NONE => ()
- | SOME l
- => let
- val li = labelInfo l
- in
- Vector.foreach
- (cons, fn {con, ...} =>
- if Vector.exists
- (cases, fn (c, _) =>
- Con.equals(c, con))
- then ()
- else ConInfo.whenConed
- (conInfo con, fn () =>
- visitLabelInfo li))
- end
- end
- end
- | Goto {dst, args} =>
- let
- val li = labelInfo dst
- val _ = flowVarInfoTysVars (LabelInfo.args li, args)
- val _ = visitLabelInfo li
- in
- ()
- end
- | Raise xs
- => (FuncInfo.raisee fi;
- flowVarInfoTysVars (valOf (FuncInfo.raises fi), xs))
- | Return xs
- => (FuncInfo.return fi;
- flowVarInfoTysVars (valOf (FuncInfo.returns fi), xs))
- | Runtime {args, return, ...}
- => (visitVars args;
- visitLabel return)
-
- val visitTransfer
- = Trace.trace ("RemoveUnused.visitTransfer",
- Layout.tuple2 (Transfer.layout, FuncInfo.layout),
- Unit.layout)
- visitTransfer
+ | Cases.Con cases =>
+ if Vector.length cases = 0
+ then Option.app (default, visitLabel)
+ else let
+ val () =
+ Vector.foreach
+ (cases, fn (con, l) =>
+ let
+ val ci = conInfo con
+ val () = ConInfo.decon ci
+ val li = labelInfo l
+ val () =
+ flowVarInfoTysVarInfoTys
+ (LabelInfo.args li, ConInfo.args ci)
+ val () =
+ ConInfo.whenConed
+ (ci, visitLabelTh l)
+ in
+ ()
+ end)
+ val tycon =
+ case Type.dest (tyVar test) of
+ Type.Datatype tycon => tycon
+ | _ => Error.bug "RemoveUnused.visitTransfer: Case:non-Datatype"
+ val cons = TyconInfo.cons (tyconInfo tycon)
+ in
+ case default of
+ NONE => ()
+ | SOME l =>
+ Vector.foreach
+ (cons, fn con =>
+ if Vector.exists
+ (cases, fn (c, _) =>
+ Con.equals(c, con))
+ then ()
+ else
+ ConInfo.whenConed
+ (conInfo con, visitLabelTh l))
+ end
+ end
+ | Goto {dst, args} =>
+ let
+ val li = labelInfo dst
+ val () = flowVarInfoTysVars (LabelInfo.args li, args)
+ val () = visitLabelInfo li
+ in
+ ()
+ end
+ | Raise xs =>
+ (FuncInfo.raisee fi
+ ; flowVarInfoTysVars (valOf (FuncInfo.raises fi), xs))
+ | Return xs =>
+ (FuncInfo.return fi
+ ; flowVarInfoTysVars (valOf (FuncInfo.returns fi), xs))
+ | Runtime {args, return, ...} =>
+ (visitVars args
+ ; visitLabel return)
fun visitBlock (Block.T {statements, transfer, ...}, fi: FuncInfo.t) =
(Vector.foreach (statements, visitStatement)
; visitTransfer (transfer, fi))
+ val visitBlockTh = fn (b, fi) => fn () => visitBlock (b, fi)
(* Visit all reachable expressions. *)
- val _ = Vector.foreach
- (datatypes, fn Datatype.T {tycon, cons} =>
- (setTyconInfo (tycon, TyconInfo.new {cons = cons});
- Vector.foreach (cons, fn {con, args} =>
- newConInfo (con, args, tycon))))
- val _ = let
- fun doit c
- = let
- val ci = conInfo c
- val _ = ConInfo.con ci
- val _ = ConInfo.decon ci
+ val () =
+ Vector.foreach
+ (datatypes, fn Datatype.T {tycon, cons} =>
+ let
+ val dummyCon = Con.newString "dummy"
+ val dummyArgs = Vector.new0 ()
+ val dummy = {con = dummyCon, args = dummyArgs}
+ val () =
+ newTyconInfo
+ (tycon, Vector.map (cons, fn {con, ...} => con), dummy)
+ val dummyExp = ConApp {args = Vector.new0 (),
+ con = dummyCon}
+ val dummy = {con = dummyCon, args = dummyArgs, exp = dummyExp}
+ val () =
+ Vector.foreach
+ (cons, fn {con, args} =>
+ newConInfo (con, args, dummy))
+ in
+ ()
+ end)
+ val () =
+ let
+ fun doitCon c =
+ let
+ val ci = conInfo c
+ in
+ ConInfo.con ci
+ ; ConInfo.decon ci
+ end
+ in
+ useTycon Tycon.bool
+ ; doitCon Con.truee
+ ; doitCon Con.falsee
+ end
+ val () =
+ Vector.foreach (globals, visitStatement)
+ val () =
+ List.foreach
+ (functions, fn function =>
+ let
+ val {name, args, raises, returns, start, blocks, ...} =
+ Function.dest function
+ val () = Vector.foreach (args, newVarInfo)
+ local
+ fun doitVarTys vts =
+ Vector.map (vts, fn (x, t) => (varInfo x, t))
+ fun doitTys ts =
+ Vector.map (ts, fn t => (VarInfo.new t, t))
+ fun doitTys' ts =
+ Option.map (ts, doitTys)
+ in
+ val fi =
+ FuncInfo.new
+ {args = doitVarTys args,
+ raises = doitTys' raises,
+ returns = doitTys' returns}
+ end
+ val () = setFuncInfo (name, fi)
+ val () = FuncInfo.whenUsed (fi, visitLabelTh start)
+ val () =
+ Vector.foreach
+ (blocks, fn block as Block.T {label, args, ...} =>
+ let
+ val () = Vector.foreach (args, newVarInfo)
+ local
+ fun doitVarTys vts =
+ Vector.map (vts, fn (x, t) => (varInfo x, t))
in
- ()
+ val li =
+ LabelInfo.new
+ {args = doitVarTys args,
+ func = fi}
end
- in
- doit Con.truee ; doit Con.falsee
- end
- val _ = Vector.foreach
- (globals, visitStatement)
- val _ = List.foreach
- (functions, fn function =>
- let
- val {name, args, raises, returns, start, blocks, ...}
- = Function.dest function
- local
- fun doitVarTys vts
- = Vector.map (vts, fn (x, t) => (varInfo x, t))
- fun doitTys ts
- = Vector.map (ts, fn t => (VarInfo.new (), t))
- fun doitTys' ts
- = Option.map (ts, doitTys)
+ val () = setLabelInfo (label, li)
+ val () = LabelInfo.whenUsed (li, visitBlockTh (block, fi))
in
- val fi = FuncInfo.new
- {args = doitVarTys args,
- raises = doitTys' raises,
- returns = doitTys' returns}
- end
- val _ = setFuncInfo (name, fi)
- val _ = FuncInfo.whenUsed
- (fi, visitLabelTh start)
- val _
- = Vector.foreach
- (blocks, fn block as Block.T {label, args, ...} =>
- let
- local
- fun doitVarTys vts
- = Vector.map (vts, fn (x, t) => (varInfo x, t))
- in
- val li
- = LabelInfo.new
- {args = doitVarTys args,
- func = fi}
- end
- val _ = setLabelInfo (label, li)
- val _ = LabelInfo.whenUsed
- (li, fn () => visitBlock (block, fi))
- in
- ()
- end)
- in
- ()
- end)
- val _ = visitFunc main
+ ()
+ end)
+ in
+ ()
+ end)
+ val () = visitFunc main
(* Diagnostics *)
- val _ = Control.diagnostics
- (fn display =>
- let open Layout
- in
+ val () =
+ Control.diagnostics
+ (fn display =>
+ let open Layout
+ in
+ Vector.foreach
+ (datatypes, fn Datatype.T {tycon, cons} =>
+ display (seq [Tycon.layout tycon,
+ str ": ",
+ TyconInfo.layout (tyconInfo tycon),
+ str ": ",
+ Vector.layout
+ (fn {con, ...} =>
+ seq [Con.layout con,
+ str " ",
+ ConInfo.layout (conInfo con)])
+ cons]));
+ display (str "\n");
+ List.foreach
+ (functions, fn f =>
+ let
+ val {name, blocks, ...} = Function.dest f
+ in
+ display (seq [Func.layout name,
+ str ": ",
+ FuncInfo.layout (funcInfo name)]);
Vector.foreach
- (datatypes, fn Datatype.T {tycon, cons} =>
- display (seq [Tycon.layout tycon,
+ (blocks, fn Block.T {label, ...} =>
+ display (seq [Label.layout label,
str ": ",
- Vector.layout
- (fn {con, ...} =>
- seq [Con.layout con,
- str " ",
- ConInfo.layout (conInfo con)])
- cons]));
- display (str "\n");
- List.foreach
- (functions, fn f =>
- let
- val {name, blocks, ...} = Function.dest f
- in
- display (seq [Func.layout name,
- str ": ",
- FuncInfo.layout (funcInfo name)]);
- Vector.foreach
- (blocks, fn Block.T {label, ...} =>
- display (seq [Label.layout label,
- str ": ",
- LabelInfo.layout (labelInfo label)]));
- display (str "\n")
- end)
- end)
+ LabelInfo.layout (labelInfo label)]));
+ display (str "\n")
+ end)
+ end)
(* Analysis is done, Now build the resulting program. *)
- val datatypes
- = Vector.map
- (datatypes, fn Datatype.T {tycon, cons} =>
- let
- val r: Exp.t option ref = ref NONE
- val cons
- = Vector.keepAllMap
- (cons, fn {con, ...} =>
- let
- val c = conInfo con
- in
- case (ConInfo.isConed c, ConInfo.isDeconed c)
- of (false, _) => NONE
- | (true, true)
- => SOME {con = con,
- args = Vector.keepAllMap
- (ConInfo.args c, fn (x, t) =>
- if VarInfo.isUsed x
- then SOME t
- else NONE)}
- | (true, false)
- => let
- val (e, res)
- = case !r
- of NONE
- => let
- val c = Con.newString "dummy"
- val targs = Vector.new0 ()
- val args = Vector.new0 ()
- val e = ConApp {con = c,
- args = args}
- in
- r := SOME e ;
- newConInfo (c, targs, tycon) ;
- (e, SOME {con = c,
- args = targs})
- end
- | SOME e => (e, NONE)
- val _ = ConInfo.dummy c := SOME e
- in
- res
- end
- end)
- val num = Vector.length cons
- val _ = TyconInfo.numCons' (tyconInfo tycon) := num
- (* If there are no constructors used, we still need to keep around
- * the type, which may appear in places. Do so with a single
- * bogus nullary constructor.
- *)
- val cons =
- if 0 = num
- then Vector.new1 {args = Vector.new0 (),
- con = Con.newNoname ()}
- else cons
- in
- Datatype.T {tycon = tycon, cons = cons}
- end)
-
fun getWrapperLabel (l: Label.t,
- args: (VarInfo.t * Type.t) vector)
- = let
+ args: (VarInfo.t * Type.t) vector) =
+ let
val li = labelInfo l
- in
+ in
if Vector.forall2 (args, LabelInfo.args li, fn ((x, _), (y, _)) =>
VarInfo.isUsed x = VarInfo.isUsed y)
- then l
- else let
- val tys
- = Vector.keepAllMap (args, fn (x, ty) =>
- if VarInfo.isUsed x
- then SOME ty
- else NONE)
- in
- case List.peek
- (LabelInfo.wrappers li, fn (args', _) =>
- Vector.length args' = Vector.length tys
- andalso
- Vector.forall2 (args', tys, fn (ty', ty) =>
- Type.equals (ty', ty)))
- of SOME (_, l') => l'
- | NONE
- => let
- val l' = Label.newNoname ()
- val (args', args'')
- = Vector.unzip
- (Vector.map2
- (args, LabelInfo.args li, fn ((x, ty), (y, _)) =>
- let
- val z = Var.newNoname ()
- in
- (if VarInfo.isUsed x then SOME (z, ty) else NONE,
- if VarInfo.isUsed y then SOME z else NONE)
- end))
- val args' = Vector.keepAllMap (args', fn x => x)
- val (_, tys') = Vector.unzip args'
- val args'' = Vector.keepAllMap (args'', fn x => x)
- val block = Block.T {label = l',
- args = args',
- statements = Vector.new0 (),
- transfer = Goto {dst = l,
- args = args''}}
- val _ = List.push (LabelInfo.wrappers' li, (tys', l'))
- val _ = List.push (FuncInfo.wrappers' (LabelInfo.func li),
- block)
- in
- l'
- end
- end
- end
+ then l
+ else let
+ val tys =
+ Vector.keepAllMap (args, fn (x, ty) =>
+ if VarInfo.isUsed x
+ then SOME ty
+ else NONE)
+ in
+ case List.peek
+ (LabelInfo.wrappers li, fn (args', _) =>
+ Vector.length args' = Vector.length tys
+ andalso
+ Vector.forall2 (args', tys, fn (ty', ty) =>
+ Type.equals (ty', ty))) of
+ NONE =>
+ let
+ val liArgs = LabelInfo.args li
+ val l' = Label.newNoname ()
+ val (args', args'') =
+ Vector.unzip
+ (Vector.map2
+ (args, liArgs, fn ((x, ty), (y, _)) =>
+ let
+ val z = Var.newNoname ()
+ in
+ (if VarInfo.isUsed x
+ then SOME (z, ty) else NONE,
+ if VarInfo.isUsed y
+ then SOME z else NONE)
+ end))
+ val args' =
+ Vector.keepAllMap (args', fn x => x)
+ val (_, tys') = Vector.unzip args'
+ val args'' =
+ Vector.keepAllMap (args'', fn x => x)
+ val block =
+ Block.T {label = l',
+ args = args',
+ statements = Vector.new0 (),
+ transfer = Goto {dst = l,
+ args = args''}}
+ val () =
+ List.push (LabelInfo.wrappers' li,
+ (tys', l'))
+ val () =
+ List.push (FuncInfo.wrappers' (LabelInfo.func li),
+ block)
+ in
+ l'
+ end
+ | SOME (_, l') => l'
+ end
+ end
val getConWrapperLabel = getWrapperLabel
val getContWrapperLabel = getWrapperLabel
val getHandlerWrapperLabel = getWrapperLabel
- fun getOriginalWrapperLabel l
- = getWrapperLabel
- (l, Vector.map (LabelInfo.args (labelInfo l), fn (_, t) =>
- let
- val x = VarInfo.new ()
- val _ = VarInfo.use x
- in
+ fun getOriginalWrapperLabel l =
+ getWrapperLabel
+ (l, Vector.map (LabelInfo.args (labelInfo l), fn (_, t) =>
+ let
+ val x = VarInfo.new t
+ val () = VarInfo.use x
+ in
(x, t)
- end))
+ end))
val getArithOverflowWrapperLabel = getOriginalWrapperLabel
val getArithSuccessWrapperLabel = getOriginalWrapperLabel
val getRuntimeWrapperLabel = getOriginalWrapperLabel
@@ -769,377 +830,444 @@
args = Vector.new0 (),
statements = Vector.new0 (),
transfer = Bug}
- val _ = List.push (FuncInfo.wrappers' fi, block)
+ val () = List.push (FuncInfo.wrappers' fi, block)
in
l
end
- fun getReturnFunc (fi: FuncInfo.t): Label.t
- = let
+ fun getReturnFunc (fi: FuncInfo.t): Label.t =
+ let
val r = FuncInfo.returnLabel fi
- in
- case !r
- of SOME l => l
- | NONE
- => let
- val l = Label.newNoname ()
- val returns = valOf (FuncInfo.returns fi)
- val args
- = Vector.keepAllMap
+ in
+ case !r of
+ NONE =>
+ let
+ val l = Label.newNoname ()
+ val returns = valOf (FuncInfo.returns fi)
+ val args =
+ Vector.keepAllMap
(returns, fn (vi, ty) =>
if VarInfo.isUsed vi
- then SOME (Var.newNoname (), ty)
- else NONE)
- val xs = Vector.map (args, #1)
- val block = Block.T {label = l,
- args = args,
- statements = Vector.new0 (),
- transfer = Return xs}
- val _ = r := SOME l
- val _ = List.push (FuncInfo.wrappers' fi, block)
- val _ = setLabelInfo (l, LabelInfo.new {func = fi,
- args = returns})
+ then SOME (Var.newNoname (), ty)
+ else NONE)
+ val xs = Vector.map (args, #1)
+ val block = Block.T {label = l,
+ args = args,
+ statements = Vector.new0 (),
+ transfer = Return xs}
+ val () = r := SOME l
+ val () = List.push (FuncInfo.wrappers' fi, block)
+ val () = setLabelInfo (l, LabelInfo.new {func = fi,
+ args = returns})
in
- l
+ l
end
- end
- fun getReturnContFunc (fi, args) = getWrapperLabel (getReturnFunc fi, args)
- fun getRaiseFunc (fi: FuncInfo.t): Label.t
- = let
+ | SOME l => l
+ end
+ fun getReturnContFunc (fi, args) =
+ getWrapperLabel (getReturnFunc fi, args)
+ fun getRaiseFunc (fi: FuncInfo.t): Label.t =
+ let
val r = FuncInfo.raiseLabel fi
- in
- case !r
- of SOME l => l
- | NONE
- => let
- val l = Label.newNoname ()
- val raises = valOf (FuncInfo.raises fi)
- val args
- = Vector.keepAllMap
+ in
+ case !r of
+ NONE =>
+ let
+ val l = Label.newNoname ()
+ val raises = valOf (FuncInfo.raises fi)
+ val args =
+ Vector.keepAllMap
(raises, fn (vi, ty) =>
if VarInfo.isUsed vi
- then SOME (Var.newNoname (), ty)
- else NONE)
- val xs = Vector.map (args, #1)
- val block = Block.T {label = l,
- args = args,
- statements = Vector.new0 (),
- transfer = Raise xs}
- val _ = r := SOME l
- val _ = List.push (FuncInfo.wrappers' fi, block)
- val _ = setLabelInfo (l, LabelInfo.new {func = fi,
- args = raises})
+ then SOME (Var.newNoname (), ty)
+ else NONE)
+ val xs = Vector.map (args, #1)
+ val block = Block.T {label = l,
+ args = args,
+ statements = Vector.new0 (),
+ transfer = Raise xs}
+ val () = r := SOME l
+ val () = List.push (FuncInfo.wrappers' fi, block)
+ val () = setLabelInfo (l, LabelInfo.new {func = fi,
+ args = raises})
in
- l
+ l
end
- end
- fun getRaiseHandlerFunc (fi, args) = getWrapperLabel (getRaiseFunc fi, args)
+ | SOME l => l
+ end
+ fun getRaiseHandlerFunc (fi, args) =
+ getWrapperLabel (getRaiseFunc fi, args)
- fun simplifyExp (e: Exp.t): Exp.t
- = case e
- of ConApp {con, args
More information about the MLton-commit
mailing list