[MLton-commit] r6763
Matthew Fluet
fluet at mlton.org
Tue Aug 19 15:15:59 PDT 2008
Don't reallocate blocks and functions that aren't changed.
----------------------------------------------------------------------
U mlton/trunk/mlton/ssa/poly-equal.fun
U mlton/trunk/mlton/ssa/poly-hash.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/ssa/poly-equal.fun
===================================================================
--- mlton/trunk/mlton/ssa/poly-equal.fun 2008-08-19 22:15:51 UTC (rev 6762)
+++ mlton/trunk/mlton/ssa/poly-equal.fun 2008-08-19 22:15:58 UTC (rev 6763)
@@ -82,7 +82,12 @@
fun polyEqual (Program.T {datatypes, globals, functions, main}) =
let
- val shrink = shrinkFunction {globals = globals}
+ val {get = funcInfo: Func.t -> {hasEqual: bool},
+ set = setFuncInfo, ...} =
+ Property.getSet (Func.plist, Property.initConst {hasEqual = false})
+ val {get = labelInfo: Label.t -> {hasEqual: bool},
+ set = setLabelInfo, ...} =
+ Property.getSet (Label.plist, Property.initConst {hasEqual = false})
val {get = varInfo: Var.t -> {isConst: bool},
set = setVarInfo, ...} =
Property.getSetOnce (Var.plist, Property.initConst {isConst = false})
@@ -91,39 +96,32 @@
args: Type.t vector} vector},
set = setTyconInfo, ...} =
Property.getSetOnce
- (Tycon.plist, Property.initRaise ("PolyEqual.info", Tycon.layout))
+ (Tycon.plist, Property.initRaise ("PolyEqual.tyconInfo", Tycon.layout))
val isEnum = #isEnum o tyconInfo
val tyconCons = #cons o tyconInfo
- val _ =
- Vector.foreach
- (datatypes, fn Datatype.T {tycon, cons} =>
- setTyconInfo (tycon,
- {isEnum = Vector.forall (cons, fn {args, ...} =>
- Vector.isEmpty args),
- cons = cons}))
- val newFunctions: Function.t list ref = ref []
- val {get = getEqualFunc: Tycon.t -> Func.t option,
- set = setEqualFunc, ...} =
+ val {get = getTyconEqualFunc: Tycon.t -> Func.t option,
+ set = setTyconEqualFunc, ...} =
Property.getSet (Tycon.plist, Property.initConst NONE)
- val {get = getVectorEqualFunc: Type.t -> Func.t option,
+ val {get = getVectorEqualFunc: Type.t -> Func.t option,
set = setVectorEqualFunc,
destroy = destroyVectorEqualFunc} =
Property.destGetSet (Type.plist, Property.initConst NONE)
val returns = SOME (Vector.new1 Type.bool)
val seqIndexWordSize = WordSize.seqIndex ()
val seqIndexTy = Type.word seqIndexWordSize
+ val newFunctions: Function.t list ref = ref []
fun newFunction z =
List.push (newFunctions,
- Function.profile (shrink (Function.new z),
+ Function.profile (Function.new z,
SourceInfo.polyEqual))
- fun equalFunc (tycon: Tycon.t): Func.t =
- case getEqualFunc tycon of
+ fun equalTyconFunc (tycon: Tycon.t): Func.t =
+ case getTyconEqualFunc tycon of
SOME f => f
| NONE =>
let
val name =
Func.newString (concat ["equal_", Tycon.originalName tycon])
- val _ = setEqualFunc (tycon, SOME name)
+ val _ = setTyconEqualFunc (tycon, SOME name)
val ty = Type.datatypee tycon
val arg1 = (Var.newNoname (), ty)
val arg2 = (Var.newNoname (), ty)
@@ -316,7 +314,7 @@
| Type.Datatype tycon =>
if isEnum tycon orelse hasConstArg ()
then eq ()
- else Dexp.call {func = equalFunc tycon,
+ else Dexp.call {func = equalTyconFunc tycon,
args = Vector.new2 (dx1, dx2),
ty = Type.bool}
| Type.IntInf =>
@@ -365,9 +363,20 @@
| Type.Weak _ => eq ()
| Type.Word ws => prim (Prim.wordEqual ws, Vector.new0 ())
end
- fun loopBind (Statement.T {exp, var, ...}) =
+
+ val _ =
+ Vector.foreach
+ (datatypes, fn Datatype.T {tycon, cons} =>
+ setTyconInfo (tycon,
+ {isEnum = Vector.forall (cons, fn {args, ...} =>
+ Vector.isEmpty args),
+ cons = cons}))
+ fun setBind (Statement.T {exp, var, ...}) =
let
- fun const () = setVarInfo (valOf var, {isConst = true})
+ fun const () =
+ case var of
+ NONE => ()
+ | SOME x => setVarInfo (x, {isConst = true})
in
case exp of
Const c =>
@@ -382,17 +391,41 @@
if Vector.isEmpty args then const () else ()
| _ => ()
end
- val _ = Vector.foreach (globals, loopBind)
+ val _ = Vector.foreach (globals, setBind)
+ val () =
+ List.foreach
+ (functions, fn f =>
+ let
+ val {name, blocks, ...} = Function.dest f
+ in
+ Vector.foreach
+ (blocks, fn Block.T {label, statements, ...} =>
+ let
+ fun setHasEqual () =
+ (setFuncInfo (name, {hasEqual = true})
+ ; setLabelInfo (label, {hasEqual = true}))
+ in
+ Vector.foreach
+ (statements, fn stmt as Statement.T {exp, ...} =>
+ (setBind stmt;
+ case exp of
+ PrimApp {prim, ...} =>
+ (case Prim.name prim of
+ Prim.Name.MLton_eq => setHasEqual ()
+ | Prim.Name.MLton_equal => setHasEqual ()
+ | _ => ())
+ | _ => ()))
+ end)
+ end)
fun doit blocks =
let
- val _ =
- Vector.foreach
- (blocks, fn Block.T {statements, ...} =>
- Vector.foreach (statements, loopBind))
val blocks =
Vector.fold
(blocks, [],
- fn (Block.T {label, args, statements, transfer}, blocks) =>
+ fn (block as Block.T {label, args, statements, transfer}, blocks) =>
+ if not (#hasEqual (labelInfo label))
+ then block::blocks
+ else
let
fun finish ({label, args, statements}, transfer) =
Block.T {label = label,
@@ -510,19 +543,24 @@
Vector.fromList blocks
end
val functions =
- List.revMap
+ List.revMap
(functions, fn f =>
let
val {args, blocks, mayInline, name, raises, returns, start} =
Function.dest f
+ val f =
+ if #hasEqual (funcInfo name)
+ then Function.new {args = args,
+ blocks = doit blocks,
+ mayInline = mayInline,
+ name = name,
+ raises = raises,
+ returns = returns,
+ start = start}
+ else f
+ val () = Function.clear f
in
- shrink (Function.new {args = args,
- blocks = doit blocks,
- mayInline = mayInline,
- name = name,
- raises = raises,
- returns = returns,
- start = start})
+ f
end)
val program =
Program.T {datatypes = datatypes,
Modified: mlton/trunk/mlton/ssa/poly-hash.fun
===================================================================
--- mlton/trunk/mlton/ssa/poly-hash.fun 2008-08-19 22:15:51 UTC (rev 6762)
+++ mlton/trunk/mlton/ssa/poly-hash.fun 2008-08-19 22:15:58 UTC (rev 6763)
@@ -347,19 +347,18 @@
fun polyHash (Program.T {datatypes, globals, functions, main}) =
let
- val shrink = shrinkFunction {globals = globals}
+ val {get = funcInfo: Func.t -> {hasHash: bool},
+ set = setFuncInfo, ...} =
+ Property.getSet (Func.plist, Property.initConst {hasHash = false})
+ val {get = labelInfo: Label.t -> {hasHash: bool},
+ set = setLabelInfo, ...} =
+ Property.getSet (Label.plist, Property.initConst {hasHash = false})
val {get = tyconInfo: Tycon.t -> {cons: {con: Con.t,
args: Type.t vector} vector},
set = setTyconInfo, ...} =
Property.getSetOnce
(Tycon.plist, Property.initRaise ("PolyHash.info", Tycon.layout))
val tyconCons = #cons o tyconInfo
- val _ =
- Vector.foreach
- (datatypes, fn Datatype.T {tycon, cons} =>
- setTyconInfo (tycon,
- {cons = cons}))
- val newFunctions: Function.t list ref = ref []
val {get = getHashFunc: Type.t -> Func.t option,
set = setHashFunc,
destroy = destroyHashFunc} =
@@ -374,9 +373,10 @@
val returns = SOME (Vector.new1 Hash.stateTy)
val seqIndexWordSize = WordSize.seqIndex ()
val seqIndexTy = Type.word seqIndexWordSize
+ val newFunctions: Function.t list ref = ref []
fun newFunction z =
List.push (newFunctions,
- Function.profile (shrink (Function.new z),
+ Function.profile (Function.new z,
SourceInfo.polyHash))
fun hashTyconFunc (tycon: Tycon.t): Func.t =
case getTyconHashFunc tycon of
@@ -763,12 +763,44 @@
in
name
end
+
+ val _ =
+ Vector.foreach
+ (datatypes, fn Datatype.T {tycon, cons} =>
+ setTyconInfo (tycon,
+ {cons = cons}))
+ val () =
+ List.foreach
+ (functions, fn f =>
+ let
+ val {name, blocks, ...} = Function.dest f
+ in
+ Vector.foreach
+ (blocks, fn Block.T {label, statements, ...} =>
+ let
+ fun setHasHash () =
+ (setFuncInfo (name, {hasHash = true})
+ ; setLabelInfo (label, {hasHash = true}))
+ in
+ Vector.foreach
+ (statements, fn Statement.T {exp, ...} =>
+ (case exp of
+ PrimApp {prim, ...} =>
+ (case Prim.name prim of
+ Prim.Name.MLton_hash => setHasHash ()
+ | _ => ())
+ | _ => ()))
+ end)
+ end)
fun doit blocks =
let
val blocks =
Vector.fold
(blocks, [],
- fn (Block.T {label, args, statements, transfer}, blocks) =>
+ fn (block as Block.T {label, args, statements, transfer}, blocks) =>
+ if not (#hasHash (labelInfo label))
+ then block::blocks
+ else
let
fun finish ({label, args, statements}, transfer) =
Block.T {label = label,
@@ -825,14 +857,19 @@
let
val {args, blocks, mayInline, name, raises, returns, start} =
Function.dest f
+ val f =
+ if #hasHash (funcInfo name)
+ then Function.new {args = args,
+ blocks = doit blocks,
+ mayInline = mayInline,
+ name = name,
+ raises = raises,
+ returns = returns,
+ start = start}
+ else f
+ val () = Function.clear f
in
- shrink (Function.new {args = args,
- blocks = doit blocks,
- mayInline = mayInline,
- name = name,
- raises = raises,
- returns = returns,
- start = start})
+ f
end)
val program =
Program.T {datatypes = datatypes,
More information about the MLton-commit
mailing list