[MLton-commit] r5780
Matthew Fluet
fluet at mlton.org
Thu Jul 19 14:00:41 PDT 2007
Regularize the treatment of some simplify passes.
- move SSA and SSA2 IL profiling into separate modules. In the
future, it would be useful to provide better IL profiling, for
example, using loop forests (which would help identify hot loops).
- run orderFunctions after adding profiling to ILs
- emit .pre.rssa and .post.rssa files for RSSA simplify
----------------------------------------------------------------------
U mlton/trunk/mlton/backend/backend.fun
A mlton/trunk/mlton/backend/implement-profiling.fun
A mlton/trunk/mlton/backend/implement-profiling.sig
D mlton/trunk/mlton/backend/profile.fun
D mlton/trunk/mlton/backend/profile.sig
U mlton/trunk/mlton/backend/rssa.fun
U mlton/trunk/mlton/backend/rssa.sig
U mlton/trunk/mlton/backend/sources.cm
U mlton/trunk/mlton/backend/sources.mlb
U mlton/trunk/mlton/control/control-flags.sig
U mlton/trunk/mlton/control/control-flags.sml
U mlton/trunk/mlton/ssa/prepasses.fun
U mlton/trunk/mlton/ssa/prepasses.sig
U mlton/trunk/mlton/ssa/prepasses2.fun
U mlton/trunk/mlton/ssa/prepasses2.sig
A mlton/trunk/mlton/ssa/profile.fun
A mlton/trunk/mlton/ssa/profile.sig
A mlton/trunk/mlton/ssa/profile2.fun
A mlton/trunk/mlton/ssa/profile2.sig
U mlton/trunk/mlton/ssa/shrink.fun
U mlton/trunk/mlton/ssa/simplify.fun
U mlton/trunk/mlton/ssa/simplify2.fun
U mlton/trunk/mlton/ssa/sources.cm
U mlton/trunk/mlton/ssa/sources.mlb
U mlton/trunk/mlton/ssa/ssa-tree.fun
U mlton/trunk/mlton/ssa/ssa-tree.sig
U mlton/trunk/mlton/ssa/ssa-tree2.fun
U mlton/trunk/mlton/ssa/ssa-tree2.sig
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/backend/backend.fun
===================================================================
--- mlton/trunk/mlton/backend/backend.fun 2007-07-18 19:45:43 UTC (rev 5779)
+++ mlton/trunk/mlton/backend/backend.fun 2007-07-19 21:00:36 UTC (rev 5780)
@@ -51,10 +51,10 @@
structure Rssa = Rssa)
structure Chunkify = Chunkify (Rssa)
structure ImplementHandlers = ImplementHandlers (structure Rssa = Rssa)
+structure ImplementProfiling = ImplementProfiling (structure Machine = Machine
+ structure Rssa = Rssa)
structure LimitCheck = LimitCheck (structure Rssa = Rssa)
structure ParallelMove = ParallelMove ()
-structure Profile = Profile (structure Machine = Machine
- structure Rssa = Rssa)
structure SignalCheck = SignalCheck(structure Rssa = Rssa)
structure SsaToRssa = SsaToRssa (structure Rssa = Rssa
structure Ssa = Ssa)
@@ -151,35 +151,68 @@
suffix = "rssa",
thunk = fn () => doit program,
typeCheck = R.Program.typeCheck}
- fun maybePass (name, doit, program) =
- if List.exists (!Control.dropPasses, fn re =>
- Regexp.Compiled.matchesAll (re, name))
- then program
- else pass (name, doit, program)
val program = pass ("toRssa", SsaToRssa.convert, (program, codegen))
- fun rssaSimplify program =
+ fun rssaSimplify p =
let
- val program =
- maybePass ("rssaShrink1", Rssa.Program.shrink, program)
- val program = pass ("insertLimitChecks", LimitCheck.insert, program)
- val program = pass ("insertSignalChecks", SignalCheck.insert, program)
- val program = pass ("implementHandlers", ImplementHandlers.doit, program)
- val program =
- maybePass ("rssaShrink2", Rssa.Program.shrink, program)
- val () = R.Program.checkHandlers program
- val (program, makeProfileInfo) =
- Control.passTypeCheck
- {display = Control.Layouts (fn ((program, _), output) =>
- Rssa.Program.layouts (program, output)),
- name = "implementProfiling",
- style = Control.No,
- suffix = "rssa",
- thunk = fn () => Profile.profile program,
- typeCheck = R.Program.typeCheck o #1}
- val program =
- maybePass ("rssaOrderFunctions", Rssa.Program.orderFunctions, program)
+ open Rssa
+ fun stats p =
+ Control.message (Control.Detail, fn () => Program.layoutStats p)
+ fun pass ({name, doit}, p) =
+ let
+ val _ =
+ let open Control
+ in maybeSaveToFile
+ ({name = name,
+ suffix = "pre.rssa"},
+ Control.No, p, Control.Layouts Program.layouts)
+ end
+ val p =
+ Control.passTypeCheck
+ {name = name,
+ suffix = "post.rssa",
+ style = Control.No,
+ thunk = fn () => doit p,
+ display = Control.Layouts Program.layouts,
+ typeCheck = Program.typeCheck}
+ val _ = stats p
+ in
+ p
+ end
+ fun maybePass ({name, doit}, p) =
+ if List.exists (!Control.dropPasses, fn re =>
+ Regexp.Compiled.matchesAll (re, name))
+ then p
+ else pass ({name = name, doit = doit}, p)
+ val p = maybePass ({name = "rssaShrink1",
+ doit = Program.shrink}, p)
+ val p = pass ({name = "insertLimitChecks",
+ doit = LimitCheck.insert}, p)
+ val p = pass ({name = "insertSignalChecks",
+ doit = SignalCheck.insert}, p)
+ val p = pass ({name = "implementHandlers",
+ doit = ImplementHandlers.doit}, p)
+ val p = maybePass ({name = "rssaShrink2",
+ doit = Program.shrink}, p)
+ val () = Program.checkHandlers p
+ val (p, makeProfileInfo) =
+ let
+ val makeProfileInfoRef =
+ ref (fn _ => Error.bug "Backend.toMachine.rssaSimplify: makeProfileInfoRef")
+ fun doit p =
+ let
+ val (p, makeProfileInfo) = ImplementProfiling.doit p
+ in
+ makeProfileInfoRef := makeProfileInfo
+ ; p
+ end
+ val p = pass ({name = "implementProfiling", doit = doit}, p)
+ in
+ (p, !makeProfileInfoRef)
+ end
+ val p = maybePass ({name = "rssaOrderFunctions",
+ doit = Program.orderFunctions}, p)
in
- (program, makeProfileInfo)
+ (p, makeProfileInfo)
end
val (program, makeProfileInfo) =
Control.passTypeCheck
Copied: mlton/trunk/mlton/backend/implement-profiling.fun (from rev 5779, mlton/trunk/mlton/backend/profile.fun)
===================================================================
--- mlton/trunk/mlton/backend/profile.fun 2007-07-18 19:45:43 UTC (rev 5779)
+++ mlton/trunk/mlton/backend/implement-profiling.fun 2007-07-19 21:00:36 UTC (rev 5780)
@@ -0,0 +1,941 @@
+(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+functor ImplementProfiling (S: IMPLEMENT_PROFILING_STRUCTS): IMPLEMENT_PROFILING =
+struct
+
+open S
+open Rssa
+
+structure CFunction =
+ struct
+ open CFunction
+
+ structure CType =
+ struct
+ open CType
+ val gcState = cpointer
+ end
+
+ local
+ fun make {args, name, prototype} =
+ T {args = args,
+ bytesNeeded = NONE,
+ convention = Convention.Cdecl,
+ ensuresBytesFree = false,
+ mayGC = false,
+ maySwitchThreads = false,
+ modifiesFrontier = false,
+ prototype = (prototype, NONE),
+ readsStackTop = true,
+ return = Type.unit,
+ target = Target.Direct name,
+ writesStackTop = false}
+ in
+ val profileEnter = fn () =>
+ make {args = Vector.new1 (Type.gcState ()),
+ name = "GC_profileEnter",
+ prototype = Vector.new1 CType.gcState}
+ val profileInc = fn () =>
+ make {args = Vector.new2 (Type.gcState (), Type.csize ()),
+ name = "GC_profileInc",
+ prototype = Vector.new2 (CType.gcState, CType.csize ())}
+ val profileLeave = fn () =>
+ make {args = Vector.new1 (Type.gcState ()),
+ name = "GC_profileLeave",
+ prototype = Vector.new1 CType.gcState}
+ end
+ end
+
+type sourceSeq = int list
+
+structure InfoNode =
+ struct
+ datatype t = T of {info: SourceInfo.t,
+ nameIndex: int,
+ sourcesIndex: int,
+ successors: t list ref}
+
+ local
+ fun make f (T r) = f r
+ in
+ val info = make #info
+ val sourcesIndex = make #sourcesIndex
+ end
+
+ fun layout (T {info, ...}) =
+ Layout.record [("info", SourceInfo.layout info)]
+
+ fun equals (n: t, n': t): bool = SourceInfo.equals (info n, info n')
+
+ fun call {from = T {successors, ...},
+ to as T {info = i', ...}} =
+ if let
+ open SourceInfo
+ in
+ equals (i', gc)
+ orelse equals (i', main)
+ orelse equals (i', unknown)
+ end orelse List.exists (!successors, fn n => equals (n, to))
+ then ()
+ else List.push (successors, to)
+
+ val call =
+ Trace.trace ("Profile.InfoNode.call",
+ fn {from, to} =>
+ Layout.record [("from", layout from),
+ ("to", layout to)],
+ Unit.layout)
+ call
+ end
+
+structure FuncInfo =
+ struct
+ datatype t = T of {callers: InfoNode.t list ref,
+ enters: InfoNode.t list ref,
+ seen: bool ref,
+ tailCalls: t list ref}
+
+ fun new () = T {callers = ref [],
+ enters = ref [],
+ seen = ref false,
+ tailCalls = ref []}
+ end
+
+structure Push =
+ struct
+ datatype t =
+ Enter of InfoNode.t
+ | Skip of SourceInfo.t
+
+ fun layout z =
+ let
+ open Layout
+ in
+ case z of
+ Enter n => seq [str "Enter ", InfoNode.layout n]
+ | Skip i => seq [str "Skip ", SourceInfo.layout i]
+ end
+
+ fun toSources (ps: t list): int list =
+ List.fold (rev ps, [], fn (p, ac) =>
+ case p of
+ Enter (InfoNode.T {sourcesIndex, ...}) =>
+ sourcesIndex :: ac
+ | Skip _ => ac)
+ end
+
+val traceEnter =
+ Trace.trace2 ("Profile.enter",
+ List.layout Push.layout,
+ SourceInfo.layout,
+ Layout.tuple2 (List.layout Push.layout, Bool.layout))
+
+fun doit program =
+ if !Control.profile = Control.ProfileNone
+ then (program, fn _ => NONE)
+ else
+ let
+ val Program.T {functions, handlesSignals, main, objectTypes} = program
+ val debug = false
+ datatype z = datatype Control.profile
+ val profile = !Control.profile
+ val profileStack: bool = !Control.profileStack
+ val needProfileLabels: bool =
+ profile = ProfileTimeLabel orelse profile = ProfileLabel
+ val needCodeCoverage: bool =
+ needProfileLabels orelse (profile = ProfileTimeField)
+ val frameProfileIndices: (Label.t * int) list ref = ref []
+ val infoNodes: InfoNode.t list ref = ref []
+ val nameCounter = Counter.new 0
+ val names: string list ref = ref []
+ local
+ val sourceCounter = Counter.new 0
+ val sep =
+ if profile = ProfileCallStack
+ then " "
+ else "\t"
+ val {get = nameIndex, ...} =
+ Property.get (SourceInfo.plist,
+ Property.initFun
+ (fn si =>
+ (List.push (names, SourceInfo.toString' (si, sep))
+ ; Counter.next nameCounter)))
+ in
+ fun sourceInfoNode (si: SourceInfo.t) =
+ let
+ val infoNode =
+ InfoNode.T {info = si,
+ nameIndex = nameIndex si,
+ sourcesIndex = Counter.next sourceCounter,
+ successors = ref []}
+ val _ = List.push (infoNodes, infoNode)
+ in
+ infoNode
+ end
+ end
+ fun firstEnter (ps: Push.t list): InfoNode.t option =
+ List.peekMap (ps, fn p =>
+ case p of
+ Push.Enter n => SOME n
+ | _ => NONE)
+ (* unknown must be 0, which == SOURCES_INDEX_UNKNOWN from gc.h *)
+ val unknownInfoNode = sourceInfoNode SourceInfo.unknown
+ (* gc must be 1 which == SOURCES_INDEX_GC from gc.h *)
+ val gcInfoNode = sourceInfoNode SourceInfo.gc
+ val mainInfoNode = sourceInfoNode SourceInfo.main
+ fun wantedSource (si: SourceInfo.t): bool =
+ if SourceInfo.isC si
+ then List.length (!Control.profileC) > 0
+ else (case SourceInfo.file si of
+ NONE => true
+ | SOME file =>
+ List.foldr
+ (!Control.profileInclExcl, true,
+ fn ((re, keep), b) =>
+ if Regexp.Compiled.matchesAll (re, file)
+ then keep
+ else b))
+ val wantedSource =
+ Trace.trace ("Profile.wantedSource", SourceInfo.layout, Bool.layout)
+ wantedSource
+ fun wantedCSource (si: SourceInfo.t): bool =
+ wantedSource si
+ andalso
+ if SourceInfo.isC si
+ then false
+ else (case SourceInfo.file si of
+ NONE => false
+ | SOME file =>
+ List.foldr
+ (!Control.profileC, false,
+ fn (re, b) =>
+ if Regexp.Compiled.matchesAll (re, file)
+ then true
+ else b))
+ val wantedCSource =
+ Trace.trace ("Profile.wantedCSource", SourceInfo.layout, Bool.layout)
+ wantedCSource
+ fun keepSource (si: SourceInfo.t): bool =
+ profile <> ProfileCount
+ orelse wantedSource si
+ val keepSource =
+ Trace.trace ("Profile.keepSource", SourceInfo.layout, Bool.layout)
+ keepSource
+ (* With -profile count, we want to get zero counts for all functions,
+ * whether or not they made it into the final executable.
+ *)
+ val () =
+ case profile of
+ ProfileCount =>
+ List.foreach (SourceInfo.all (), fn si =>
+ if wantedSource si
+ then ignore (sourceInfoNode si)
+ else ())
+ | _ => ()
+ val sourceInfoNode =
+ fn si =>
+ let
+ open SourceInfo
+ in
+ if equals (si, unknown)
+ then unknownInfoNode
+ else if equals (si, gc)
+ then gcInfoNode
+ else if equals (si, main)
+ then mainInfoNode
+ else sourceInfoNode si
+ end
+ val sourceInfoNode =
+ Trace.trace ("Profile.sourceInfoNode", SourceInfo.layout, InfoNode.layout)
+ sourceInfoNode
+ local
+ val table: {hash: word,
+ index: int,
+ sourceSeq: int vector} HashSet.t =
+ HashSet.new {hash = #hash}
+ val c = Counter.new 0
+ val sourceSeqs: int vector list ref = ref []
+ in
+ fun sourceSeqIndex (s: sourceSeq): int =
+ let
+ val s = Vector.fromListRev s
+ val hash =
+ Vector.fold (s, 0w0, fn (i, w) =>
+ w * 0w31 + Word.fromInt i)
+ in
+ #index
+ (HashSet.lookupOrInsert
+ (table, hash,
+ fn {sourceSeq = s', ...} => s = s',
+ fn () => let
+ val _ = List.push (sourceSeqs, s)
+ in
+ {hash = hash,
+ index = Counter.next c,
+ sourceSeq = s}
+ end))
+ end
+ fun makeSourceSeqs () = Vector.fromListRev (!sourceSeqs)
+ end
+ (* Ensure that [SourceInfo.unknown] is index 0. *)
+ val _ = sourceSeqIndex [InfoNode.sourcesIndex unknownInfoNode]
+ (* Ensure that [SourceInfo.gc] is index 1. *)
+ val _ = sourceSeqIndex [InfoNode.sourcesIndex gcInfoNode]
+ fun addFrameProfileIndex (label: Label.t,
+ index: int): unit =
+ List.push (frameProfileIndices, (label, index))
+ fun addFrameProfilePushes (label: Label.t,
+ pushes: Push.t list): unit =
+ addFrameProfileIndex (label,
+ sourceSeqIndex (Push.toSources pushes))
+ val {get = labelInfo: Label.t -> {block: Block.t,
+ visited1: bool ref,
+ visited2: bool ref},
+ set = setLabelInfo, ...} =
+ Property.getSetOnce
+ (Label.plist, Property.initRaise ("info", Label.layout))
+ val labels = ref []
+ fun profileLabelFromIndex (sourceSeqsIndex: int): Statement.t =
+ let
+ val l = ProfileLabel.new ()
+ val _ = List.push (labels, {label = l,
+ sourceSeqsIndex = sourceSeqsIndex})
+ in
+ Statement.ProfileLabel l
+ end
+ fun setCurSourceSeqsIndexFromIndex (sourceSeqsIndex: int): Statement.t =
+ let
+ val curSourceSeqsIndex =
+ Operand.Runtime Runtime.GCField.CurSourceSeqsIndex
+ in
+ Statement.Move
+ {dst = curSourceSeqsIndex,
+ src = Operand.word (WordX.fromIntInf
+ (IntInf.fromInt sourceSeqsIndex,
+ WordSize.word32))}
+ end
+ fun codeCoverageStatementFromIndex (sourceSeqsIndex: int): Statement.t =
+ if needProfileLabels
+ then profileLabelFromIndex sourceSeqsIndex
+ else if profile = ProfileTimeField
+ then setCurSourceSeqsIndexFromIndex sourceSeqsIndex
+ else Error.bug "Profile.codeCoverageStatement"
+ fun codeCoverageStatement (sourceSeq: int list): Statement.t =
+ codeCoverageStatementFromIndex (sourceSeqIndex sourceSeq)
+ local
+ val {get: Func.t -> FuncInfo.t, ...} =
+ Property.get (Func.plist, Property.initFun (fn _ => FuncInfo.new ()))
+ in
+ val funcInfo = get
+ fun addFuncEdges () =
+ (* Don't need to add edges for main because no one calls it. *)
+ List.foreach
+ (functions, fn f =>
+ let
+ val allSeen: bool ref list ref = ref []
+ val func = Function.name f
+ val fi as FuncInfo.T {callers, ...} = get func
+ (* Add edges from all the callers to the enters in f and all
+ * functions that f tail calls.
+ *)
+ fun call (FuncInfo.T {enters, seen, tailCalls, ...}): unit =
+ if !seen
+ then ()
+ else
+ let
+ val _ = seen := true
+ val _ = List.push (allSeen, seen)
+ val _ =
+ List.foreach
+ (!callers, fn from =>
+ List.foreach
+ (!enters, fn to =>
+ InfoNode.call {from = from, to = to}))
+ in
+ List.foreach (!tailCalls, call)
+ end
+ val _ = call fi
+ val _ = List.foreach (!allSeen, fn r => r := false)
+ in
+ ()
+ end)
+ end
+ fun doFunction (f: Function.t): Function.t =
+ let
+ val {args, blocks, name, raises, returns, start} = Function.dest f
+ val _ =
+ if not debug
+ then ()
+ else print (concat ["doFunction ", Func.toString name, "\n"])
+ val FuncInfo.T {enters, tailCalls, ...} = funcInfo name
+ fun enter (ps: Push.t list, si: SourceInfo.t): Push.t list * bool =
+ let
+ val node = Promise.lazy (fn () => sourceInfoNode si)
+ fun yes () = (Push.Enter (node ()) :: ps, true)
+ fun no () = (Push.Skip si :: ps, false)
+ in
+ if SourceInfo.equals (si, SourceInfo.unknown)
+ then no ()
+ else
+ case firstEnter ps of
+ NONE =>
+ if keepSource si
+ then (List.push (enters, node ())
+ ; yes ())
+ else no ()
+ | SOME (node' as InfoNode.T {info = si', ...}) =>
+ (*
+ * si : callee
+ * si' : caller
+ *)
+ if keepSource si
+ andalso
+ let
+ open SourceInfo
+ in
+ equals (si', unknown)
+ orelse
+ (wantedSource si
+ andalso
+ not (equals (si, gcArrayAllocate))
+ andalso
+ (not (isC si)
+ orelse
+ (wantedCSource si'
+ andalso not (equals (si', main)))))
+ end
+ then (InfoNode.call {from = node', to = node ()}
+ ; yes ())
+ else no ()
+ end
+ val enter = traceEnter enter
+ val _ =
+ Vector.foreach
+ (blocks, fn block as Block.T {label, ...} =>
+ setLabelInfo (label, {block = block,
+ visited1 = ref false,
+ visited2 = ref false}))
+ (* Find the first Enter statement and (conceptually) move it to the
+ * front of the function.
+ *)
+ local
+ exception Yes of Label.t * Statement.t
+ fun goto l =
+ let
+ val {block, visited1, ...} = labelInfo l
+ in
+ if !visited1
+ then ()
+ else
+ let
+ val () = visited1 := true
+ val Block.T {statements, transfer, ...} = block
+ val () =
+ Vector.foreach
+ (statements, fn s =>
+ case s of
+ Statement.Profile (ProfileExp.Enter _) =>
+ raise Yes (l, s)
+ | _ => ())
+ val () = Transfer.foreachLabel (transfer, goto)
+ in
+ ()
+ end
+ end
+ in
+ val first = (goto start; NONE) handle Yes z => SOME z
+ end
+ val blocks = ref []
+ datatype z = datatype Statement.t
+ datatype z = datatype ProfileExp.t
+ fun backward {args,
+ kind,
+ label,
+ leaves,
+ sourceSeq: int list,
+ statements: Statement.t list,
+ transfer: Transfer.t}: unit =
+ let
+ val (_, ncc, sourceSeq, statements) =
+ List.fold
+ (statements,
+ (leaves, true, sourceSeq, []),
+ fn (s, (leaves, ncc, sourceSeq, ss)) =>
+ case s of
+ Object _ => (leaves, true, sourceSeq, s :: ss)
+ | Profile ps =>
+ let
+ val (ncc, ss) =
+ if needCodeCoverage
+ then
+ if ncc
+ andalso not (List.isEmpty sourceSeq)
+ then (false,
+ codeCoverageStatement sourceSeq :: ss)
+ else (true, ss)
+ else (false, ss)
+ val (leaves, sourceSeq) =
+ case ps of
+ Enter _ =>
+ (case sourceSeq of
+ [] => Error.bug
+ "Profile.backward: unmatched Enter"
+ | _ :: sis => (leaves, sis))
+ | Leave _ =>
+ (case leaves of
+ [] => Error.bug
+ "Profile.backward: missing Leave"
+ | infoNode :: leaves =>
+ (leaves,
+ InfoNode.sourcesIndex infoNode
+ :: sourceSeq))
+ in
+ (leaves, ncc, sourceSeq, ss)
+ end
+ | _ => (leaves, true, sourceSeq, s :: ss))
+ val statements =
+ if needCodeCoverage
+ andalso ncc
+ then codeCoverageStatement sourceSeq :: statements
+ else statements
+ val {args, kind, label} =
+ if profileStack andalso (case kind of
+ Kind.Cont _ => true
+ | Kind.Handler => true
+ | _ => false)
+ then
+ let
+ val func = CFunction.profileLeave ()
+ val newLabel = Label.newNoname ()
+ val _ =
+ addFrameProfileIndex
+ (newLabel, sourceSeqIndex sourceSeq)
+ val statements =
+ if needCodeCoverage
+ then (Vector.new1
+ (codeCoverageStatement sourceSeq))
+ else Vector.new0 ()
+ val _ =
+ List.push
+ (blocks,
+ Block.T
+ {args = args,
+ kind = kind,
+ label = label,
+ statements = statements,
+ transfer =
+ Transfer.CCall
+ {args = Vector.new1 Operand.GCState,
+ func = func,
+ return = SOME newLabel}})
+ in
+ {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ label = newLabel}
+ end
+ else
+ {args = args,
+ kind = kind,
+ label = label}
+ in
+ List.push (blocks,
+ Block.T {args = args,
+ kind = kind,
+ label = label,
+ statements = Vector.fromList statements,
+ transfer = transfer})
+ end
+ val backward =
+ Trace.trace
+ ("Profile.backward",
+ fn {leaves, statements, sourceSeq, ...} =>
+ let
+ open Layout
+ in
+ record [("leaves", List.layout InfoNode.layout leaves),
+ ("sourceSeq", List.layout Int.layout sourceSeq),
+ ("statements",
+ List.layout Statement.layout statements)]
+ end,
+ Unit.layout)
+ backward
+ fun profileEnter (pushes: Push.t list,
+ transfer: Transfer.t): Transfer.t =
+ let
+ val func = CFunction.profileEnter ()
+ val newLabel = Label.newNoname ()
+ val index = sourceSeqIndex (Push.toSources pushes)
+ val _ = addFrameProfileIndex (newLabel, index)
+ val statements =
+ if needCodeCoverage
+ then Vector.new1 (codeCoverageStatementFromIndex index)
+ else Vector.new0 ()
+ val _ =
+ List.push
+ (blocks,
+ Block.T {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ label = newLabel,
+ statements = statements,
+ transfer = transfer})
+ in
+ Transfer.CCall {args = Vector.new1 Operand.GCState,
+ func = func,
+ return = SOME newLabel}
+ end
+ fun goto (l: Label.t, pushes: Push.t list): unit =
+ let
+ val _ =
+ if not debug
+ then ()
+ else
+ let
+ open Layout
+ in
+ outputl (seq [str "goto (",
+ Label.layout l,
+ str ", ",
+ List.layout Push.layout pushes,
+ str ")"],
+ Out.error)
+ end
+ val {block, visited2, ...} = labelInfo l
+ in
+ if !visited2
+ then ()
+ else
+ let
+ val _ = visited2 := true
+ val Block.T {args, kind, label, statements, transfer,
+ ...} = block
+ val statements =
+ case first of
+ NONE => statements
+ | SOME (firstLabel, firstEnter) =>
+ if Label.equals (label, firstLabel)
+ then
+ Vector.removeFirst
+ (statements, fn s =>
+ case s of
+ Profile (Enter _) => true
+ | _ => false)
+ else if Label.equals (label, start)
+ then
+ Vector.concat
+ [Vector.new1 firstEnter,
+ statements]
+ else statements
+ val _ =
+ let
+ fun add pushes =
+ addFrameProfilePushes (label, pushes)
+ datatype z = datatype Kind.t
+ in
+ case kind of
+ Cont _ => add pushes
+ | CReturn {func, ...} =>
+ let
+ datatype z = datatype CFunction.Target.t
+ val target = CFunction.target func
+ fun doit si =
+ add (#1 (enter (pushes, si)))
+ in
+ case target of
+ Direct "GC_collect" => doit SourceInfo.gc
+ | Direct "GC_arrayAllocate" =>
+ doit SourceInfo.gcArrayAllocate
+ | Direct "MLton_bug" => add pushes
+ | Direct name => doit (SourceInfo.fromC name)
+ | Indirect => doit (SourceInfo.fromC "<indirect>")
+ end
+ | Handler => add pushes
+ | Jump => ()
+ end
+ fun maybeSplit {args,
+ bytesAllocated: Bytes.t,
+ kind,
+ label,
+ leaves,
+ pushes: Push.t list,
+ shouldSplit: bool,
+ statements} =
+ if not shouldSplit
+ then {args = args,
+ bytesAllocated = Bytes.zero,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ statements = statements}
+ else
+ let
+ val newLabel = Label.newNoname ()
+ val _ =
+ addFrameProfilePushes (newLabel, pushes)
+ val func = CFunction.profileInc ()
+ val amount =
+ case profile of
+ ProfileAlloc => Bytes.toInt bytesAllocated
+ | ProfileCount => 1
+ | _ => Error.bug "Profile.maybeSplit: amount"
+ val transfer =
+ Transfer.CCall
+ {args = (Vector.new2
+ (Operand.GCState,
+ Operand.word
+ (WordX.fromIntInf
+ (IntInf.fromInt amount,
+ WordSize.csize ())))),
+ func = func,
+ return = SOME newLabel}
+ val sourceSeq = Push.toSources pushes
+ val _ =
+ backward {args = args,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ sourceSeq = sourceSeq,
+ statements = statements,
+ transfer = transfer}
+ in
+ {args = Vector.new0 (),
+ bytesAllocated = Bytes.zero,
+ kind = Kind.CReturn {func = func},
+ label = newLabel,
+ leaves = [],
+ statements = []}
+ end
+ val {args, bytesAllocated, kind, label, leaves, pushes,
+ statements} =
+ Vector.fold
+ (statements,
+ {args = args,
+ bytesAllocated = Bytes.zero,
+ kind = kind,
+ label = label,
+ leaves = [],
+ pushes = pushes,
+ statements = []},
+ fn (s, {args, bytesAllocated, kind, label,
+ leaves,
+ pushes: Push.t list,
+ statements}) =>
+ (if not debug
+ then ()
+ else
+ let
+ open Layout
+ in
+ outputl
+ (seq [List.layout Push.layout pushes,
+ str " ",
+ Statement.layout s],
+ Out.error)
+ end
+ ;
+ case s of
+ Object {size, ...} =>
+ {args = args,
+ bytesAllocated = Bytes.+ (bytesAllocated, size),
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ pushes = pushes,
+ statements = s :: statements}
+ | Profile ps =>
+ let
+ val shouldSplit =
+ profile = ProfileAlloc
+ andalso Bytes.> (bytesAllocated,
+ Bytes.zero)
+ val {args, bytesAllocated, kind, label,
+ leaves, statements} =
+ maybeSplit
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ pushes = pushes,
+ shouldSplit = shouldSplit,
+ statements = statements}
+ datatype z = datatype ProfileExp.t
+ val (pushes, keep, leaves) =
+ case ps of
+ Enter si =>
+ let
+ val (pushes, keep) =
+ enter (pushes, si)
+ in
+ (pushes, keep, leaves)
+ end
+ | Leave si =>
+ (case pushes of
+ [] => Error.bug
+ "Profile.goto: unmatched Leave"
+ | p :: pushes =>
+ let
+ val (keep, si', leaves) =
+ case p of
+ Push.Enter
+ (infoNode as
+ InfoNode.T
+ {info, ...}) =>
+ (true, info,
+ infoNode :: leaves)
+ | Push.Skip si' =>
+ (false, si',
+ leaves)
+ in
+ if SourceInfo.equals (si, si')
+ then (pushes,
+ keep,
+ leaves)
+ else Error.bug
+ "Profile.goto: mismatched Leave"
+ end)
+ val shouldSplit =
+ profile = ProfileCount
+ andalso (case ps of
+ Enter _ => keep
+ | _ => false)
+ val {args, bytesAllocated, kind, label,
+ leaves, statements} =
+ maybeSplit
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ pushes = pushes,
+ shouldSplit = shouldSplit,
+ statements = statements}
+ val statements =
+ if keep
+ then s :: statements
+ else statements
+ in
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ pushes = pushes,
+ statements = statements}
+ end
+ | _ =>
+ {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ pushes = pushes,
+ statements = s :: statements})
+ )
+ val shouldSplit =
+ profile = ProfileAlloc
+ andalso Bytes.> (bytesAllocated, Bytes.zero)
+ val {args, kind, label, leaves, statements, ...} =
+ maybeSplit {args = args,
+ bytesAllocated = bytesAllocated,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ pushes = pushes,
+ shouldSplit = shouldSplit,
+ statements = statements}
+ val _ =
+ Transfer.foreachLabel
+ (transfer, fn l => goto (l, pushes))
+ val transfer =
+ case transfer of
+ Transfer.Call {func, return, ...} =>
+ let
+ val fi as FuncInfo.T {callers, ...} =
+ funcInfo func
+ in
+ case return of
+ Return.NonTail _ =>
+ let
+ val _ =
+ case firstEnter pushes of
+ NONE =>
+ List.push (tailCalls, fi)
+ | SOME n =>
+ List.push (callers, n)
+ in
+ if profileStack
+ then profileEnter (pushes,
+ transfer)
+ else transfer
+ end
+ | _ =>
+ (List.push (tailCalls, fi)
+ ; transfer)
+ end
+ | _ => transfer
+ in
+ backward {args = args,
+ kind = kind,
+ label = label,
+ leaves = leaves,
+ sourceSeq = Push.toSources pushes,
+ statements = statements,
+ transfer = transfer}
+ end
+ end
+ val _ = goto (start, [])
+ val blocks = Vector.fromList (!blocks)
+ in
+ Function.new {args = args,
+ blocks = blocks,
+ name = name,
+ raises = raises,
+ returns = returns,
+ start = start}
+ end
+ val program = Program.T {functions = List.revMap (functions, doFunction),
+ handlesSignals = handlesSignals,
+ main = doFunction main,
+ objectTypes = objectTypes}
+ val _ = addFuncEdges ()
+ val names = Vector.fromListRev (!names)
+ val sources =
+ Vector.map
+ (Vector.fromListRev (!infoNodes),
+ fn InfoNode.T {nameIndex, successors, ...} =>
+ {nameIndex = nameIndex,
+ successorsIndex = (sourceSeqIndex
+ (List.revMap (!successors,
+ InfoNode.sourcesIndex)))})
+ (* makeSourceSeqs () must happen after making sources, since that creates
+ * new sourceSeqs.
+ *)
+ val sourceSeqs = makeSourceSeqs ()
+ fun makeProfileInfo {frames} =
+ let
+ val {get, set, ...} =
+ Property.getSetOnce
+ (Label.plist,
+ Property.initRaise ("frameProfileIndex", Label.layout))
+ val _ =
+ List.foreach (!frameProfileIndices, fn (l, i) =>
+ set (l, i))
+ val frameSources = Vector.map (frames, get)
+ in
+ SOME (Machine.ProfileInfo.T
+ {frameSources = frameSources,
+ labels = Vector.fromList (!labels),
+ names = names,
+ sourceSeqs = sourceSeqs,
+ sources = sources})
+ end
+ in
+ (program, makeProfileInfo)
+ end
+
+end
Copied: mlton/trunk/mlton/backend/implement-profiling.sig (from rev 5779, mlton/trunk/mlton/backend/profile.sig)
===================================================================
--- mlton/trunk/mlton/backend/profile.sig 2007-07-18 19:45:43 UTC (rev 5779)
+++ mlton/trunk/mlton/backend/implement-profiling.sig 2007-07-19 21:00:36 UTC (rev 5780)
@@ -0,0 +1,26 @@
+(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+type int = Int.t
+type word = Word.t
+
+signature IMPLEMENT_PROFILING_STRUCTS =
+ sig
+ structure Machine: MACHINE
+ structure Rssa: RSSA
+ sharing Machine.ProfileLabel = Rssa.ProfileLabel
+ end
+
+signature IMPLEMENT_PROFILING =
+ sig
+ include IMPLEMENT_PROFILING_STRUCTS
+
+ val doit:
+ Rssa.Program.t
+ -> Rssa.Program.t * ({frames: Rssa.Label.t vector}
+ -> Machine.ProfileInfo.t option)
+ end
Deleted: mlton/trunk/mlton/backend/profile.fun
===================================================================
--- mlton/trunk/mlton/backend/profile.fun 2007-07-18 19:45:43 UTC (rev 5779)
+++ mlton/trunk/mlton/backend/profile.fun 2007-07-19 21:00:36 UTC (rev 5780)
@@ -1,941 +0,0 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-functor Profile (S: PROFILE_STRUCTS): PROFILE =
-struct
-
-open S
-open Rssa
-
-structure CFunction =
- struct
- open CFunction
-
- structure CType =
- struct
- open CType
- val gcState = cpointer
- end
-
- local
- fun make {args, name, prototype} =
- T {args = args,
- bytesNeeded = NONE,
- convention = Convention.Cdecl,
- ensuresBytesFree = false,
- mayGC = false,
- maySwitchThreads = false,
- modifiesFrontier = false,
- prototype = (prototype, NONE),
- readsStackTop = true,
- return = Type.unit,
- target = Target.Direct name,
- writesStackTop = false}
- in
- val profileEnter = fn () =>
- make {args = Vector.new1 (Type.gcState ()),
- name = "GC_profileEnter",
- prototype = Vector.new1 CType.gcState}
- val profileInc = fn () =>
- make {args = Vector.new2 (Type.gcState (), Type.csize ()),
- name = "GC_profileInc",
- prototype = Vector.new2 (CType.gcState, CType.csize ())}
- val profileLeave = fn () =>
- make {args = Vector.new1 (Type.gcState ()),
- name = "GC_profileLeave",
- prototype = Vector.new1 CType.gcState}
- end
- end
-
-type sourceSeq = int list
-
-structure InfoNode =
- struct
- datatype t = T of {info: SourceInfo.t,
- nameIndex: int,
- sourcesIndex: int,
- successors: t list ref}
-
- local
- fun make f (T r) = f r
- in
- val info = make #info
- val sourcesIndex = make #sourcesIndex
- end
-
- fun layout (T {info, ...}) =
- Layout.record [("info", SourceInfo.layout info)]
-
- fun equals (n: t, n': t): bool = SourceInfo.equals (info n, info n')
-
- fun call {from = T {successors, ...},
- to as T {info = i', ...}} =
- if let
- open SourceInfo
- in
- equals (i', gc)
- orelse equals (i', main)
- orelse equals (i', unknown)
- end orelse List.exists (!successors, fn n => equals (n, to))
- then ()
- else List.push (successors, to)
-
- val call =
- Trace.trace ("Profile.InfoNode.call",
- fn {from, to} =>
- Layout.record [("from", layout from),
- ("to", layout to)],
- Unit.layout)
- call
- end
-
-structure FuncInfo =
- struct
- datatype t = T of {callers: InfoNode.t list ref,
- enters: InfoNode.t list ref,
- seen: bool ref,
- tailCalls: t list ref}
-
- fun new () = T {callers = ref [],
- enters = ref [],
- seen = ref false,
- tailCalls = ref []}
- end
-
-structure Push =
- struct
- datatype t =
- Enter of InfoNode.t
- | Skip of SourceInfo.t
-
- fun layout z =
- let
- open Layout
- in
- case z of
- Enter n => seq [str "Enter ", InfoNode.layout n]
- | Skip i => seq [str "Skip ", SourceInfo.layout i]
- end
-
- fun toSources (ps: t list): int list =
- List.fold (rev ps, [], fn (p, ac) =>
- case p of
- Enter (InfoNode.T {sourcesIndex, ...}) =>
- sourcesIndex :: ac
- | Skip _ => ac)
- end
-
-val traceEnter =
- Trace.trace2 ("Profile.enter",
- List.layout Push.layout,
- SourceInfo.layout,
- Layout.tuple2 (List.layout Push.layout, Bool.layout))
-
-fun profile program =
- if !Control.profile = Control.ProfileNone
- then (program, fn _ => NONE)
- else
- let
- val Program.T {functions, handlesSignals, main, objectTypes} = program
- val debug = false
- datatype z = datatype Control.profile
- val profile = !Control.profile
- val profileStack: bool = !Control.profileStack
- val needProfileLabels: bool =
- profile = ProfileTimeLabel orelse profile = ProfileLabel
- val needCodeCoverage: bool =
- needProfileLabels orelse (profile = ProfileTimeField)
- val frameProfileIndices: (Label.t * int) list ref = ref []
- val infoNodes: InfoNode.t list ref = ref []
- val nameCounter = Counter.new 0
- val names: string list ref = ref []
- local
- val sourceCounter = Counter.new 0
- val sep =
- if profile = ProfileCallStack
- then " "
- else "\t"
- val {get = nameIndex, ...} =
- Property.get (SourceInfo.plist,
- Property.initFun
- (fn si =>
- (List.push (names, SourceInfo.toString' (si, sep))
- ; Counter.next nameCounter)))
- in
- fun sourceInfoNode (si: SourceInfo.t) =
- let
- val infoNode =
- InfoNode.T {info = si,
- nameIndex = nameIndex si,
- sourcesIndex = Counter.next sourceCounter,
- successors = ref []}
- val _ = List.push (infoNodes, infoNode)
- in
- infoNode
- end
- end
- fun firstEnter (ps: Push.t list): InfoNode.t option =
- List.peekMap (ps, fn p =>
- case p of
- Push.Enter n => SOME n
- | _ => NONE)
- (* unknown must be 0, which == SOURCES_INDEX_UNKNOWN from gc.h *)
- val unknownInfoNode = sourceInfoNode SourceInfo.unknown
- (* gc must be 1 which == SOURCES_INDEX_GC from gc.h *)
- val gcInfoNode = sourceInfoNode SourceInfo.gc
- val mainInfoNode = sourceInfoNode SourceInfo.main
- fun wantedSource (si: SourceInfo.t): bool =
- if SourceInfo.isC si
- then List.length (!Control.profileC) > 0
- else (case SourceInfo.file si of
- NONE => true
- | SOME file =>
- List.foldr
- (!Control.profileInclExcl, true,
- fn ((re, keep), b) =>
- if Regexp.Compiled.matchesAll (re, file)
- then keep
- else b))
- val wantedSource =
- Trace.trace ("Profile.wantedSource", SourceInfo.layout, Bool.layout)
- wantedSource
- fun wantedCSource (si: SourceInfo.t): bool =
- wantedSource si
- andalso
- if SourceInfo.isC si
- then false
- else (case SourceInfo.file si of
- NONE => false
- | SOME file =>
- List.foldr
- (!Control.profileC, false,
- fn (re, b) =>
- if Regexp.Compiled.matchesAll (re, file)
- then true
- else b))
- val wantedCSource =
- Trace.trace ("Profile.wantedCSource", SourceInfo.layout, Bool.layout)
- wantedCSource
- fun keepSource (si: SourceInfo.t): bool =
- profile <> ProfileCount
- orelse wantedSource si
- val keepSource =
- Trace.trace ("Profile.keepSource", SourceInfo.layout, Bool.layout)
- keepSource
- (* With -profile count, we want to get zero counts for all functions,
- * whether or not they made it into the final executable.
- *)
- val () =
- case profile of
- ProfileCount =>
- List.foreach (SourceInfo.all (), fn si =>
- if wantedSource si
- then ignore (sourceInfoNode si)
- else ())
- | _ => ()
- val sourceInfoNode =
- fn si =>
- let
- open SourceInfo
- in
- if equals (si, unknown)
- then unknownInfoNode
- else if equals (si, gc)
- then gcInfoNode
- else if equals (si, main)
- then mainInfoNode
- else sourceInfoNode si
- end
- val sourceInfoNode =
- Trace.trace ("Profile.sourceInfoNode", SourceInfo.layout, InfoNode.layout)
- sourceInfoNode
- local
- val table: {hash: word,
- index: int,
- sourceSeq: int vector} HashSet.t =
- HashSet.new {hash = #hash}
- val c = Counter.new 0
- val sourceSeqs: int vector list ref = ref []
- in
- fun sourceSeqIndex (s: sourceSeq): int =
- let
- val s = Vector.fromListRev s
- val hash =
- Vector.fold (s, 0w0, fn (i, w) =>
- w * 0w31 + Word.fromInt i)
- in
- #index
- (HashSet.lookupOrInsert
- (table, hash,
- fn {sourceSeq = s', ...} => s = s',
- fn () => let
- val _ = List.push (sourceSeqs, s)
- in
- {hash = hash,
- index = Counter.next c,
- sourceSeq = s}
- end))
- end
- fun makeSourceSeqs () = Vector.fromListRev (!sourceSeqs)
- end
- (* Ensure that [SourceInfo.unknown] is index 0. *)
- val _ = sourceSeqIndex [InfoNode.sourcesIndex unknownInfoNode]
- (* Ensure that [SourceInfo.gc] is index 1. *)
- val _ = sourceSeqIndex [InfoNode.sourcesIndex gcInfoNode]
- fun addFrameProfileIndex (label: Label.t,
- index: int): unit =
- List.push (frameProfileIndices, (label, index))
- fun addFrameProfilePushes (label: Label.t,
- pushes: Push.t list): unit =
- addFrameProfileIndex (label,
- sourceSeqIndex (Push.toSources pushes))
- val {get = labelInfo: Label.t -> {block: Block.t,
- visited1: bool ref,
- visited2: bool ref},
- set = setLabelInfo, ...} =
- Property.getSetOnce
- (Label.plist, Property.initRaise ("info", Label.layout))
- val labels = ref []
- fun profileLabelFromIndex (sourceSeqsIndex: int): Statement.t =
- let
- val l = ProfileLabel.new ()
- val _ = List.push (labels, {label = l,
- sourceSeqsIndex = sourceSeqsIndex})
- in
- Statement.ProfileLabel l
- end
- fun setCurSourceSeqsIndexFromIndex (sourceSeqsIndex: int): Statement.t =
- let
- val curSourceSeqsIndex =
- Operand.Runtime Runtime.GCField.CurSourceSeqsIndex
- in
- Statement.Move
- {dst = curSourceSeqsIndex,
- src = Operand.word (WordX.fromIntInf
- (IntInf.fromInt sourceSeqsIndex,
- WordSize.word32))}
- end
- fun codeCoverageStatementFromIndex (sourceSeqsIndex: int): Statement.t =
- if needProfileLabels
- then profileLabelFromIndex sourceSeqsIndex
- else if profile = ProfileTimeField
- then setCurSourceSeqsIndexFromIndex sourceSeqsIndex
- else Error.bug "Profile.codeCoverageStatement"
- fun codeCoverageStatement (sourceSeq: int list): Statement.t =
- codeCoverageStatementFromIndex (sourceSeqIndex sourceSeq)
- local
- val {get: Func.t -> FuncInfo.t, ...} =
- Property.get (Func.plist, Property.initFun (fn _ => FuncInfo.new ()))
- in
- val funcInfo = get
- fun addFuncEdges () =
- (* Don't need to add edges for main because no one calls it. *)
- List.foreach
- (functions, fn f =>
- let
- val allSeen: bool ref list ref = ref []
- val func = Function.name f
- val fi as FuncInfo.T {callers, ...} = get func
- (* Add edges from all the callers to the enters in f and all
- * functions that f tail calls.
- *)
- fun call (FuncInfo.T {enters, seen, tailCalls, ...}): unit =
- if !seen
- then ()
- else
- let
- val _ = seen := true
- val _ = List.push (allSeen, seen)
- val _ =
- List.foreach
- (!callers, fn from =>
- List.foreach
- (!enters, fn to =>
- InfoNode.call {from = from, to = to}))
- in
- List.foreach (!tailCalls, call)
- end
- val _ = call fi
- val _ = List.foreach (!allSeen, fn r => r := false)
- in
- ()
- end)
- end
- fun doFunction (f: Function.t): Function.t =
- let
- val {args, blocks, name, raises, returns, start} = Function.dest f
- val _ =
- if not debug
- then ()
- else print (concat ["doFunction ", Func.toString name, "\n"])
- val FuncInfo.T {enters, tailCalls, ...} = funcInfo name
- fun enter (ps: Push.t list, si: SourceInfo.t): Push.t list * bool =
- let
- val node = Promise.lazy (fn () => sourceInfoNode si)
- fun yes () = (Push.Enter (node ()) :: ps, true)
- fun no () = (Push.Skip si :: ps, false)
- in
- if SourceInfo.equals (si, SourceInfo.unknown)
- then no ()
- else
- case firstEnter ps of
- NONE =>
- if keepSource si
- then (List.p
More information about the MLton-commit
mailing list