[MLton-devel] cvs commit: source-level profiling
Stephen Weeks
sweeks@users.sourceforge.net
Sun, 12 Jan 2003 17:14:28 -0800
sweeks 03/01/12 17:14:28
Modified: mlprof main.sml
mlton/ast wrapped.sig
mlton/atoms source-info.fun source-info.sig
mlton/backend profile.fun
mlton/control control.sig control.sml
mlton/core-ml core-ml.fun core-ml.sig lookup-constant.fun
mlton/elaborate elaborate-core.fun
mlton/main main.sml
mlton/ssa ssa-tree.fun
mlton/type-inference infer.fun scope.fun
mlton/xml xml-tree.fun
Log:
Display function name instead of <file>: <line> in profiling, except
with anonymous functions.
Also, fixed problems with the source information being incorrect for
mutually recursive functions and with extra source information being
created for compiler-generated functions.
Changed -profile xml to -profile source, which seems like a better
name to me from a user perspective.
Added option to mlprof: -show-line {false|true}. This allows you to
see the line numbers in addition to the function names if you want.
Revision Changes Path
1.25 +47 -8 mlton/mlprof/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlprof/main.sml,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- main.sml 7 Jan 2003 16:23:51 -0000 1.24
+++ main.sml 13 Jan 2003 01:14:25 -0000 1.25
@@ -20,21 +20,56 @@
val graphShow = ref GraphShow.Above
val raw = ref false
+val showLine = ref false
val thresh: int ref = ref 0
val die = Process.fail
-
+
+structure Source =
+ struct
+ datatype t =
+ NamePos of {name: string,
+ pos: string}
+ | Simple of string
+
+ fun toString n =
+ case n of
+ NamePos {name, pos} =>
+ if !showLine
+ then concat [name, " ", pos]
+ else name
+ | Simple s => s
+
+ val layout = Layout.str o toString
+
+ fun fromString s =
+ case String.tokens (s, fn c => Char.equals (c, #"\t")) of
+ [s] => Simple s
+ | [name, pos] => NamePos {name = name, pos = pos}
+ | _ => die "strange source"
+
+ fun toDotLabel s =
+ case s of
+ NamePos {name, pos} =>
+ if !showLine
+ then [(name, Dot.Center),
+ (pos, Dot.Center)]
+ else [(name, Dot.Center)]
+ | Simple s =>
+ [(s, Dot.Center)]
+ end
+
structure AFile =
struct
datatype t = T of {magic: word,
name: string,
sourceSuccessors: int vector vector,
- sources: string vector}
+ sources: Source.t vector}
fun layout (T {magic, name, sourceSuccessors, sources}) =
Layout.record [("name", String.layout name),
("magic", Word.layout magic),
- ("sources", Vector.layout String.layout sources),
+ ("sources", Vector.layout Source.layout sources),
("sourceSuccessors",
Vector.layout (Vector.layout Int.layout)
sourceSuccessors)]
@@ -49,7 +84,8 @@
val sourcesLength = valOf (Int.fromString (line ()))
val sources =
Vector.tabulate (sourcesLength, fn _ =>
- String.dropSuffix (line (), 1))
+ Source.fromString
+ (String.dropSuffix (line (), 1)))
val sourceSuccessors =
Vector.tabulate
(sourcesLength, fn _ =>
@@ -266,7 +302,7 @@
val showInTable =
(per > 0.0 andalso per >= thresh)
orelse (not profileStack andalso i = sourcesIndexGC)
- val name = Vector.sub (sources, i)
+ val source = Vector.sub (sources, i)
val node =
if (not profileStack orelse i <> sourcesIndexGC)
andalso (case !graphShow of
@@ -280,8 +316,9 @@
List.push
(no,
Dot.NodeOption.Label
- [(name, Dot.Center),
- (concat (List.separate (row, " ")), Dot.Center)])
+ (Source.toDotLabel source
+ @ [(concat (List.separate (row, " ")),
+ Dot.Center)]))
val _ =
List.push (no, Dot.NodeOption.Shape Dot.Box)
in
@@ -291,7 +328,7 @@
in
{node = node,
per = per,
- row = name :: row,
+ row = Source.toString source :: row,
showInTable = showInTable}
end)
val counts =
@@ -400,6 +437,8 @@
| _ => usage "invalid -graph arg")),
(Normal, "raw", " {false|true}", "show raw counts",
boolRef raw),
+ (Normal, "show-line", " {false|true}", " show line numbers",
+ boolRef showLine),
(Normal, "thresh", " {0|1|...|100}", "only show counts above threshold",
Int (fn i => if i < 0 orelse i > 100
then usage "invalid -thresh"
1.5 +0 -1 mlton/mlton/ast/wrapped.sig
Index: wrapped.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/wrapped.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- wrapped.sig 10 Apr 2002 07:02:18 -0000 1.4
+++ wrapped.sig 13 Jan 2003 01:14:25 -0000 1.5
@@ -13,7 +13,6 @@
type obj
val dest: obj -> node' * Region.t
-(* val make: node' -> obj *)
val makeRegion': node' * SourcePos.t * SourcePos.t -> obj
val makeRegion: node' * Region.t -> obj
val node: obj -> node'
1.3 +117 -34 mlton/mlton/atoms/source-info.fun
Index: source-info.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/source-info.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- source-info.fun 11 Jan 2003 02:18:46 -0000 1.2
+++ source-info.fun 13 Jan 2003 01:14:25 -0000 1.3
@@ -1,44 +1,127 @@
functor SourceInfo (S: SOURCE_INFO_STRUCTS): SOURCE_INFO =
struct
-type t = string
-
-fun toString s = s
+structure Pos =
+ struct
+ datatype t =
+ Known of {file: string,
+ isBasis: bool,
+ line: int}
+ | Unknown
+
+ fun equals (p, p') =
+ case (p, p') of
+ (Known {file = f, line = l, ...},
+ Known {file = f', line = l', ...}) =>
+ f = f' andalso l = l'
+ | (Unknown, Unknown) => true
+ | _ => false
+
+ fun toString p =
+ case p of
+ Known {file, line, ...} =>
+ concat [file, ": ", Int.toString line]
+ | Unknown => "<unknown>"
+
+ fun fromRegion r =
+ case Region.left r of
+ NONE => Unknown
+ | SOME (SourcePos.T {file, line, ...}) =>
+ let
+ val s = "/basis-library/"
+ val (file, isBasis) =
+ case String.findSubstring {string = file, substring = s} of
+ NONE => (file, false)
+ | SOME i =>
+ (concat ["<basis>/",
+ String.dropPrefix (file, i + String.size s)],
+ true)
+ in
+ Known {file = file,
+ isBasis = isBasis,
+ line = line}
+ end
+
+ fun isBasis p =
+ case p of
+ Known {isBasis, ...} => isBasis
+ | Unknown => false
+ end
+
+datatype info =
+ Anonymous of Pos.t
+ | C of string
+ | Function of {name: string,
+ pos: Pos.t}
+
+datatype t = T of {hash: word,
+ info: info,
+ plist: PropertyList.t}
+
+fun new info = T {hash = Random.word (),
+ info = info,
+ plist = PropertyList.new ()}
+
+local
+ fun make f (T r) = f r
+in
+ val hash = make #hash
+ val info = make #info
+ val plist = make #plist
+end
+
+fun anonymous r = new (Anonymous (Pos.fromRegion r))
+
+local
+ val set: {hash: word,
+ name: string,
+ sourceInfo: t} HashSet.t =
+ HashSet.new {hash = #hash}
+in
+ fun fromC (name: string) =
+ let
+ val hash = String.hash name
+ in
+ #sourceInfo
+ (HashSet.lookupOrInsert
+ (set, hash, fn {hash = h, ...} => hash = h,
+ fn () => {hash = hash,
+ name = name,
+ sourceInfo = new (C name)}))
+ end
+end
+
+fun function {name, region} =
+ new (Function {name = name,
+ pos = Pos.fromRegion region})
+
+fun toString si =
+ case info si of
+ Anonymous p => Pos.toString p
+ | C s => concat ["<", s, ">"]
+ | Function {name, pos} => concat [name, "\t", Pos.toString pos]
val layout = Layout.str o toString
-val equals: t * t -> bool = op =
-
-val fromString = fn s => s
-
-val hash = String.hash
-
-val gc = "<gc>"
-val gcArrayAllocate = "<GC_arrayAllocate>"
-val main = "<main>"
-val polyEqual = "<poly-equal>"
-val unknown = "<unknown>"
+val equals: t * t -> bool =
+ fn (s, s') => PropertyList.equals (plist s, plist s')
-val basisPrefix = "<basis>/"
+val equals =
+ Trace.trace2 ("SourceInfo.equals", layout, layout, Bool.layout) equals
-fun fromRegion r =
- case Region.left r of
- NONE => "<unknown>"
- | SOME (SourcePos.T {file, line, ...}) =>
- let
- val s = "/basis-library/"
- val file =
- case String.findSubstring {string = file, substring = s} of
- NONE => file
- | SOME i =>
- concat [basisPrefix,
- String.dropPrefix (file, i + String.size s)]
- in
- concat [file, ":", Int.toString line]
- end
-
-fun isBasis s =
- String.isPrefix {prefix = basisPrefix,
- string = s}
+fun isBasis (s: t): bool =
+ case info s of
+ Anonymous p => Pos.isBasis p
+ | C _ => false
+ | Function {pos, ...} => Pos.isBasis pos
+
+val isBasis =
+ Trace.trace ("SourceInfo.isBasis", layout, Bool.layout) isBasis
+
+val gc = fromC "gc"
+val gcArrayAllocate = fromC "GC_arrayAllocate>"
+val main = fromC "main"
+val polyEqual = fromC "poly-equal"
+val unknown = fromC "unknown"
end
1.3 +4 -2 mlton/mlton/atoms/source-info.sig
Index: source-info.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/source-info.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- source-info.sig 11 Jan 2003 02:18:47 -0000 1.2
+++ source-info.sig 13 Jan 2003 01:14:26 -0000 1.3
@@ -11,15 +11,17 @@
type t
+ val anonymous: Region.t -> t
val equals: t * t -> bool
val gc: t
val gcArrayAllocate: t
- val fromRegion: Region.t -> t
- val fromString: string -> t
val hash: t -> word
+ val fromC: string -> t
+ val function: {name: string, region: Region.t} -> t
val isBasis: t -> bool
val layout: t -> Layout.t
val main: t
+ val plist: t -> PropertyList.t
val polyEqual: t
val toString: t -> string
val unknown: t
1.17 +26 -25 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- profile.fun 11 Jan 2003 02:18:47 -0000 1.16
+++ profile.fun 13 Jan 2003 01:14:26 -0000 1.17
@@ -95,31 +95,29 @@
val profileTime: bool = profile = Control.ProfileTime
val frameProfileIndices = ref []
local
- val table: InfoNode.t HashSet.t =
- HashSet.new {hash = SourceInfo.hash o InfoNode.info}
val c = Counter.new 0
val sourceInfos = ref []
in
- fun sourceInfoNode (si: SourceInfo.t) =
- HashSet.lookupOrInsert
- (table, SourceInfo.hash si,
- fn InfoNode.T {info = si', ...} => SourceInfo.equals (si, si'),
- fn () => let
- val _ = List.push (sourceInfos, si)
- val index = Counter.next c
- in
- InfoNode.T {index = index,
- info = si,
- successors = ref []}
- end)
+ val {get = sourceInfoNode, ...} =
+ Property.get (SourceInfo.plist,
+ Property.initFun
+ (fn si =>
+ let
+ val _ = List.push (sourceInfos, si)
+ val index = Counter.next c
+ in
+ InfoNode.T {index = index,
+ info = si,
+ successors = ref []}
+ end))
val sourceInfoIndex = InfoNode.index o sourceInfoNode
- fun firstEnter (ps: Push.t list): InfoNode.t option =
- List.peekMap (ps, fn p =>
- case p of
- Push.Enter n => SOME n
- | _ => NONE)
fun makeSources () = Vector.fromListRev (!sourceInfos)
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
val unknownIndex = InfoNode.index unknownInfoNode
@@ -243,14 +241,19 @@
andalso
(equals (si, gcArrayAllocate)
orelse (isBasis si
- andalso
- (equals (si, main)
- orelse not (equals (si', main)))))
+ andalso not (equals (si', main))))
end
then no ()
else (InfoNode.call {from = node', to = node ()}
; yes ())
end
+ val enter =
+ Trace.trace2 ("Profile.enter",
+ List.layout Push.layout,
+ SourceInfo.layout,
+ Layout.tuple2 (List.layout Push.layout,
+ Bool.layout))
+ enter
val _ =
Vector.foreach
(blocks, fn block as Block.T {label, ...} =>
@@ -588,9 +591,7 @@
"GC_gc" => SourceInfo.gc
| "GC_arrayAllocate" =>
SourceInfo.gcArrayAllocate
- | _ =>
- SourceInfo.fromString
- (concat ["<", name, ">"])
+ | _ => SourceInfo.fromC name
val set =
setCurrentSource
(sourceSeqIndex
1.63 +1 -1 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -r1.62 -r1.63
--- control.sig 11 Jan 2003 00:34:40 -0000 1.62
+++ control.sig 13 Jan 2003 01:14:26 -0000 1.63
@@ -201,7 +201,7 @@
val profileBasis: bool ref
- datatype profileIL = ProfileXML | ProfileSSA
+ datatype profileIL = ProfileSSA | ProfileSource
val profileIL: profileIL ref
val profileStack: bool ref
1.79 +3 -3 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -r1.78 -r1.79
--- control.sml 11 Jan 2003 00:34:40 -0000 1.78
+++ control.sml 13 Jan 2003 01:14:26 -0000 1.79
@@ -359,11 +359,11 @@
structure ProfileIL =
struct
- datatype t = ProfileSSA | ProfileXML
+ datatype t = ProfileSSA | ProfileSource
val toString =
fn ProfileSSA => "ProfileSSA"
- | ProfileXML => "ProfileXML"
+ | ProfileSource => "ProfileSource"
end
val profileBasis = control {name = "profile basis",
@@ -373,7 +373,7 @@
datatype profileIL = datatype ProfileIL.t
val profileIL = control {name = "profile IL",
- default = ProfileXML,
+ default = ProfileSource,
toString = ProfileIL.toString}
val profileStack = control {name = "profile stack",
1.9 +47 -43 mlton/mlton/core-ml/core-ml.fun
Index: core-ml.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- core-ml.fun 10 Apr 2002 07:02:20 -0000 1.8
+++ core-ml.fun 13 Jan 2003 01:14:26 -0000 1.9
@@ -213,9 +213,10 @@
pat: Pat.t,
tyvars: Tyvar.t vector}
| Fun of {tyvars: Tyvar.t vector,
- decs: {var: Var.t,
+ decs: {match: match,
+ profile: SourceInfo.t,
types: Type.t vector,
- match: match} vector}
+ var: Var.t} vector}
| Datatype of {
tyvars: Tyvar.t vector,
tycon: Tycon.t,
@@ -237,7 +238,8 @@
| Const of Ast.Const.t
| Con of Con.t
| Record of exp Record.t
- | Fn of match
+ | Fn of {match: match,
+ profile: SourceInfo.t option}
| App of exp * exp
| Let of dec vector * exp
| Constraint of exp * Type.t
@@ -307,7 +309,7 @@
{tyvars = tyvars,
vbs = Vector.new0 (),
rvbs = (Vector.map
- (decs, fn {var, types, match} =>
+ (decs, fn {match, types, var, ...} =>
{pat = (Vector.fold
(types, Apat.var (Var.toAst var),
fn (t, p) =>
@@ -325,21 +327,20 @@
end
and expToAst e =
case Wrap.node e of
- Var x => Exp.var (Var.toAst x)
+ App (e1, e2) => Exp.app (expToAst e1, expToAst e2)
+ | Con c => Exp.con (Con.toAst c)
+ | Const c => Exp.const c
+ | Constraint (e, t) => Exp.constraint (expToAst e, Type.toAst t)
+ | Fn {match, ...} => Exp.fnn (matchToAst match)
+ | Handle (try, match) => Exp.handlee (expToAst try, matchToAst match)
+ | Let (ds, e) => Exp.lett (Vector.map (ds, decToAst), expToAst e)
| Prim p => Exp.longvid (Ast.Longvid.short
(Ast.Longvid.Id.fromString (Prim.toString p,
Region.bogus)))
- | Const c => Exp.const c
- | Con c => Exp.con (Con.toAst c)
+ | Raise {exn, filePos} =>
+ Exp.raisee {exn = expToAst exn, filePos = filePos}
| Record r => Exp.record (Record.map (r, expToAst))
- | Fn m => Exp.fnn (matchToAst m)
- | App (e1, e2) => Exp.app (expToAst e1, expToAst e2)
- | Let (ds, e) => Exp.lett (Vector.map (ds, decToAst), expToAst e)
- | Constraint (e, t) => Exp.constraint (expToAst e, Type.toAst t)
- | Handle (try, match) =>
- Exp.handlee (expToAst try, matchToAst match)
- | Raise {exn, filePos} => Exp.raisee {exn = expToAst exn,
- filePos = filePos}
+ | Var x => Exp.var (Var.toAst x)
and matchToAst m =
let
@@ -355,21 +356,21 @@
let
fun exp e =
case Wrap.node e of
- Var x => f x
- | Record r => Record.foreach (r, exp)
- | Fn m => match m
- | App (e1, e2) => (exp e1; exp e2)
- | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
+ App (e1, e2) => (exp e1; exp e2)
| Constraint (e, _) => exp e
+ | Fn {match = m, ...} => match m
| Handle (e, m) => (exp e; match m)
+ | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
| Raise {exn, ...} => exp exn
+ | Record r => Record.foreach (r, exp)
+ | Var x => f x
| _ => ()
and match m = Vector.foreach (Match.rules m, exp o #2)
and dec d =
case Wrap.node d of
- Val {exp = e, ...} => exp e
- | Fun {decs, ...} => Vector.foreach (decs, match o #match)
+ Fun {decs, ...} => Vector.foreach (decs, match o #match)
| Overload {ovlds, ...} => Vector.foreach (ovlds, f)
+ | Val {exp = e, ...} => exp e
| _ => ()
in
{exp = exp, dec = dec}
@@ -392,8 +393,9 @@
fun fnn (m, r) = makeRegion (Fn m, r)
fun fn1 (p, e, r) =
- fnn (Match.new {filePos = "",
- rules = Vector.new1 (p, e)},
+ fnn ({match = Match.new {filePos = "",
+ rules = Vector.new1 (p, e)},
+ profile = NONE},
r)
fun isExpansive e =
@@ -415,10 +417,12 @@
fun lambda (x, e, r) = fn1 (makeRegion (Pat.Var x, r), e, r)
- fun delay (e, r) = fn1 (Pat.unit r, e, r)
+(* fun delay (e, r) = fn1 (Pat.unit r, e, r) *)
fun casee (test, rules, r) =
- makeRegion (App (makeRegion (Fn rules, r),
+ makeRegion (App (makeRegion (Fn {match = rules,
+ profile = NONE},
+ r),
test),
r)
@@ -485,24 +489,24 @@
let
val loop = Var.newNoname ()
val call = makeRegion (App (var (loop, r), unit r), r)
+ val match =
+ Match.new {filePos = "",
+ rules = (Vector.new1
+ (Pat.tuple (Vector.new0 (), r),
+ iff (test,
+ seq (Vector.new2 (expr, call), r),
+ unit r,
+ r)))}
in
makeRegion
(Let (Vector.new1
(makeRegion
(Fun {tyvars = Vector.new0 (),
decs = (Vector.new1
- {var = loop,
+ {match = match,
+ profile = SourceInfo.anonymous r,
types = Vector.new0 (),
- match = (Match.new
- {filePos = "",
- rules =
- Vector.new1
- (Pat.tuple (Vector.new0 (), r),
- iff (test,
- seq (Vector.new2 (expr, call),
- r),
- unit r,
- r))})})},
+ var = loop})},
r)),
call),
r)
@@ -550,20 +554,20 @@
fun exp e =
(inc ()
; (case Exp.node e of
- Fn m => match m
- | Record r => Record.foreach (r, exp)
- | App (e, e') => (exp e; exp e')
- | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
+ App (e, e') => (exp e; exp e')
| Constraint (e, _) => exp e
+ | Fn {match = m, ...} => match m
| Handle (e, m) => (exp e; match m)
+ | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
| Raise {exn, ...} => exp exn
+ | Record r => Record.foreach (r, exp)
| _ => ()))
and match m = Vector.foreach (Match.rules m, exp o #2)
and dec d =
case Dec.node d of
- Val {exp = e, ...} => exp e
+ Exception _ => inc ()
| Fun {decs, ...} => Vector.foreach (decs, match o #match)
- | Exception _ => inc ()
+ | Val {exp = e, ...} => exp e
| _ => ()
val _ = Vector.foreach (ds, dec)
in
1.7 +6 -6 mlton/mlton/core-ml/core-ml.sig
Index: core-ml.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- core-ml.sig 10 Apr 2002 07:02:20 -0000 1.6
+++ core-ml.sig 13 Jan 2003 01:14:26 -0000 1.7
@@ -70,7 +70,8 @@
| Con of Con.t
| Const of Ast.Const.t
| Constraint of t * Type.t
- | Fn of match
+ | Fn of {match: match,
+ profile: SourceInfo.t option}
| Handle of t * match
| Let of dec vector * t
| Prim of Prim.t
@@ -83,7 +84,7 @@
val andAlso: t * t * Region.t -> t
val casee: t * match * Region.t -> t
- val delay: t * Region.t -> t
+(* val delay: t * Region.t -> t *)
val force: t * Region.t -> t
val foreachVar: t * (Var.t -> unit) -> unit
val iff: t * t * t * Region.t -> t
@@ -130,11 +131,10 @@
}
| Fun of {
tyvars: Tyvar.t vector,
- decs: {
- var: Var.t,
+ decs: {match: Match.t,
+ profile: SourceInfo.t,
types: Type.t vector, (* multiple constraints *)
- match: Match.t
- } vector
+ var: Var.t} vector
}
| Overload of {
var: Var.t,
1.18 +7 -7 mlton/mlton/core-ml/lookup-constant.fun
Index: lookup-constant.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/lookup-constant.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- lookup-constant.fun 3 Jan 2003 06:14:16 -0000 1.17
+++ lookup-constant.fun 13 Jan 2003 01:14:27 -0000 1.18
@@ -66,7 +66,12 @@
open Exp Dec
fun loopExp (e: Exp.t, ac: res): res =
case Exp.node e of
- Prim p =>
+ App (e, e') => loopExp (e, loopExp (e', ac))
+ | Constraint (e, _) => loopExp (e, ac)
+ | Fn {match = m, ...} => loopMatch (m, ac)
+ | Handle (e, m) => loopMatch (m, loopExp (e, ac))
+ | Let (ds, e) => loopDecs (ds, loopExp (e, ac))
+ | Prim p =>
(case Prim.name p of
Prim.Name.Constant c =>
let
@@ -96,13 +101,8 @@
| _ => strange ()
end
| _ => ac)
- | Record r => Record.fold (r, ac, loopExp)
- | Fn m => loopMatch (m, ac)
- | App (e, e') => loopExp (e, loopExp (e', ac))
- | Let (ds, e) => loopDecs (ds, loopExp (e, ac))
- | Constraint (e, _) => loopExp (e, ac)
- | Handle (e, m) => loopMatch (m, loopExp (e, ac))
| Raise {exn, ...} => loopExp (exn, ac)
+ | Record r => Record.fold (r, ac, loopExp)
| _ => ac
and loopMatch (m, ac: res): res =
Vector.fold (Match.rules m , ac, fn ((_, e), ac) => loopExp (e, ac))
1.12 +117 -61 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- elaborate-core.fun 10 Apr 2002 07:02:20 -0000 1.11
+++ elaborate-core.fun 13 Jan 2003 01:14:27 -0000 1.12
@@ -48,6 +48,7 @@
structure Ctype = Type
structure Cvar = Var
structure Scheme = Scheme
+ structure SourceInfo = SourceInfo
structure Tycon = Tycon
structure Type = Type
structure Tyvar = Tyvar
@@ -62,6 +63,26 @@
structure Parse = PrecedenceParse (structure Ast = Ast
structure Env = Env)
+structure Apat =
+ struct
+ open Apat
+
+ fun getName (p: t): string option =
+ case node p of
+ Var {name, ...} => SOME (Longvid.toString name)
+ | Constraint (p, _) => getName p
+ | FlatApp v =>
+ if 1 = Vector.length v
+ then getName (Vector.sub (v, 0))
+ else NONE
+ | Layered {var, ...} => SOME (Avar.toString var)
+ | _ => NONE
+
+ val getName =
+ Trace.trace ("Apat.getName", layout, Option.layout String.layout)
+ getName
+ end
+
structure Lookup =
struct
type t = Longtycon.t -> TypeStr.t
@@ -304,7 +325,7 @@
end
val info = Trace.info "elaborateDec"
-val info' = Trace.info "elaborateExp"
+val elabExpInfo = Trace.info "elaborateExp"
fun elaborateDec (d, E) =
let
@@ -442,7 +463,8 @@
(clauses, fn {pats, resultType, body} =>
let
val {func, args} = Parse.parseClause (pats, E)
- in {func = func,
+ in
+ {func = func,
args = args,
resultType = resultType,
body =
@@ -488,54 +510,66 @@
then Error.bug "empty clauses in fundec"
else
let
- val {args, ...} = Vector.sub (clauses, 0)
+ val {func, args, ...} = Vector.sub (clauses, 0)
+ val profile =
+ SourceInfo.function
+ {name = Ast.Var.toString func,
+ region = region}
val numVars = Vector.length args
- in {var = newFunc,
+ val match =
+ let
+ val rs =
+ Vector.map
+ (clauses,
+ fn {args, resultType, body, ...} =>
+ let
+ val (pats, body) =
+ Env.scope
+ (E, fn () =>
+ (elaboratePatsV (args, E),
+ elabExp body))
+ in (Cpat.tuple (pats, region),
+ constrain (body,
+ elabTypeOpt resultType,
+ region))
+ end)
+ fun make (i, xs) =
+ if i = 0
+ then
+ Cexp.casee
+ (Cexp.tuple
+ (Vector.rev
+ (Vector.fromListMap
+ (xs, fn x =>
+ doit (Cexp.Var x))),
+ region),
+ Cmatch.new {filePos = filePos,
+ rules = rs},
+ region)
+ else
+ let
+ val x = Cvar.newNoname ()
+ in
+ Cexp.lambda
+ (x,
+ make (i - 1, x :: xs),
+ region)
+ end
+ in if numVars = 1
+ then Cmatch.new {filePos = filePos,
+ rules = rs}
+ else (case Cexp.node (make (numVars, [])) of
+ Cexp.Fn {match = m, ...} => m
+ | _ => Error.bug "elabFbs")
+ end
+ in
+ {match = match,
+ profile = profile,
types = Vector.new0 (),
- match =
- let
- val rs =
- Vector.map
- (clauses,
- fn {args, resultType, body, ...} =>
- let
- val (pats, body) =
- Env.scope
- (E, fn () =>
- (elaboratePatsV (args, E),
- elabExp body))
- in (Cpat.tuple (pats, region),
- constrain (body,
- elabTypeOpt resultType,
- region))
- end)
- fun make (i, xs) =
- if i = 0
- then
- Cexp.casee
- (Cexp.tuple
- (Vector.rev
- (Vector.fromListMap
- (xs, fn x => doit (Cexp.Var x))),
- region),
- Cmatch.new {filePos = filePos,
- rules = rs},
- region)
- else
- let val x = Cvar.newNoname ()
- in Cexp.lambda (x,
- make (i - 1, x :: xs),
- region)
- end
- in if numVars = 1
- then Cmatch.new {filePos = filePos,
- rules = rs}
- else (case Cexp.node (make (numVars, [])) of
- Cexp.Fn m => m
- | _ => Error.bug "elabFbs")
- end}
+ var = newFunc}
end)
- in Decs.single (Cdec.makeRegion (Cdec.Fun {tyvars = tyvars,
+ in
+ Decs.single (Cdec.makeRegion (Cdec.Fun {tyvars = tyvars,
decs = decs},
region))
end
@@ -597,7 +631,8 @@
(* Must do all the es and rvbs pefore the ps because of
* scoping rules.
*)
- val es = Vector.map (vbs, elabExp o #exp)
+ val es = Vector.map (vbs, fn {pat, exp, ...} =>
+ elabExp' (exp, Apat.getName pat))
fun varsAndTypes (p: Apat.t, vars, types)
: Avar.t list * Atype.t list =
let
@@ -640,9 +675,9 @@
(rvbs, fn {pat, ...} =>
let
val (vars, types) = varsAndTypes (pat, [], [])
- val var =
+ val (name, var) =
case vars of
- [] => Cvar.newNoname ()
+ [] => ("<anon>", Cvar.newNoname ())
| x :: _ =>
let
val x' = Cvar.fromAst x
@@ -651,18 +686,24 @@
(vars, fn y =>
Env.extendVar (E, y, x'))
in
- x'
+ (Avar.toString x, x')
end
in
- (var,
- Vector.fromListMap (types, Scheme.ty o elabType))
+ {name = name,
+ types = (Vector.fromListMap
+ (types, Scheme.ty o elabType)),
+ var = var}
end)
val rvbs =
Vector.map2
- (rvbs, vts, fn ({match, ...}, (var, types)) =>
- {var = var,
+ (rvbs, vts,
+ fn ({pat, match, ...}, {name, types, var}) =>
+ {match = elabMatch match,
+ profile = (SourceInfo.function
+ {name = name,
+ region = Apat.region pat}),
types = types,
- match = elabMatch match})
+ var = var})
val ps = Vector.map (vbs, fn {pat, filePos, ...} =>
{pat = elaboratePat (pat, E),
filePos = filePos,
@@ -704,10 +745,14 @@
end) d
and elabExps (es: Ast.Exp.t list): Cexp.t list =
List.map (es, elabExp)
- and elabExp arg: Cexp.t =
- Trace.traceInfo (info', Ast.Exp.layout, Cexp.layout,
+ and elabExp e = elabExp' (e, NONE)
+ and elabExp' (arg: Aexp.t * string option): Cexp.t =
+ Trace.traceInfo (elabExpInfo,
+ Layout.tuple2 (Aexp.layout,
+ Option.layout String.layout),
+ Cexp.layout,
Trace.assertTrue)
- (fn (e: Aexp.t) =>
+ (fn (e: Aexp.t, name) =>
let
val region = Aexp.region e
fun doit n = Cexp.makeRegion (n, region)
@@ -721,9 +766,20 @@
Cexp.casee (elabExp e, elabMatch m, region)
| Aexp.Const c => doit (Cexp.Const c)
| Aexp.Constraint (e, t) =>
- doit (Cexp.Constraint (elabExp e, Scheme.ty (elabType t)))
+ doit (Cexp.Constraint (elabExp' (e, name),
+ Scheme.ty (elabType t)))
| Aexp.FlatApp items => elabExp (Parse.parseExp (items, E))
- | Aexp.Fn m => doit (Cexp.Fn (elabMatch m))
+ | Aexp.Fn m =>
+ let
+ val profile =
+ case name of
+ NONE => SourceInfo.anonymous region
+ | SOME s => SourceInfo.function {name = s,
+ region = region}
+ in
+ doit (Cexp.Fn {match = elabMatch m,
+ profile = SOME profile})
+ end
| Aexp.Handle (try, match) =>
doit (Cexp.Handle (elabExp try, elabMatch match))
| Aexp.If (a, b, c) =>
1.111 +2 -2 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.110
retrieving revision 1.111
diff -u -r1.110 -r1.111
--- main.sml 11 Jan 2003 00:34:40 -0000 1.110
+++ main.sml 13 Jan 2003 01:14:27 -0000 1.111
@@ -263,11 +263,11 @@
(Expert, "profile-basis", " {false|true}",
"profile the basis implementation",
boolRef profileBasis),
- (Expert, "profile-il", " {xml}", "where to insert profile exps",
+ (Expert, "profile-il", " {source}", "where to insert profile exps",
SpaceString
(fn s =>
case s of
- "xml" => profileIL := ProfileXML
+ "source" => profileIL := ProfileSource
| _ => usage (concat ["invalid -profile-il arg: ", s]))),
(Normal, "profile-stack", " {false|true}",
"profile the stack",
1.55 +1 -1 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- ssa-tree.fun 11 Jan 2003 00:34:40 -0000 1.54
+++ ssa-tree.fun 13 Jan 2003 01:14:27 -0000 1.55
@@ -1342,7 +1342,7 @@
fun profile (f: t, sourceInfo): t =
if !Control.profile = Control.ProfileNone
- orelse !Control.profileIL <> Control.ProfileXML
+ orelse !Control.profileIL <> Control.ProfileSource
then f
else
let
1.21 +18 -15 mlton/mlton/type-inference/infer.fun
Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- infer.fun 10 Jan 2003 20:52:49 -0000 1.20
+++ infer.fun 13 Jan 2003 01:14:27 -0000 1.21
@@ -841,7 +841,7 @@
(fn () => Vector.map (valOf (!argsRef) (), Xtype.var))
val (decs, env') =
Vector.mapAndFold
- (decs, env, fn ({var, types, match}, env) =>
+ (decs, env, fn ({match, profile, types, var}, env) =>
let
val argType = newType ()
val resultType = newType ()
@@ -852,10 +852,11 @@
Type.unify (t, Type.fromCoreML t',
Cmatch.region match))
in
- ({var = var,
- argType = argType,
+ ({argType = argType,
+ match = match,
+ profile = profile,
resultType = resultType,
- match = match},
+ var = var},
Env.extendVarRange
(env, var,
VarRange.T {scheme = Scheme.fromType t,
@@ -864,17 +865,19 @@
val region = Cmatch.region (#match (Vector.sub (decs, 0)))
val decs =
Vector.map
- (decs, fn {var, match, argType, resultType} =>
+ (decs, fn {argType, match, profile, resultType, var} =>
let
val saved = !currentFunction
val _ = currentFunction := var :: saved
val rs = inferMatchUnify (match, env',
argType, resultType)
val _ = currentFunction := saved
- in {var = var,
+ in
+ {profile = profile,
region = Cmatch.region match,
rules = rs,
- ty = Type.arrow (argType, resultType)}
+ ty = Type.arrow (argType, resultType),
+ var = var}
end)
val {bound, schemes} =
Env.closes (env, Vector.map (decs, #ty), tyvars, region)
@@ -887,7 +890,8 @@
[Xdec.Fun
{tyvars = bound (),
decs = (Vector.map
- (decs, fn {var, region, rules, ty} =>
+ (decs,
+ fn {var, profile, region, rules, ty} =>
let
val ty = Type.toXml (ty, region)
val {arg, argType, body, ...} =
@@ -895,9 +899,7 @@
(forceRulesMatch (rules, region))
val body =
Xml.Exp.enterLeave
- (body,
- #2 (Xtype.dearrow ty),
- SourceInfo.fromRegion region)
+ (body, #2 (Xtype.dearrow ty), profile)
val lambda =
Xlambda.new
{arg = arg,
@@ -986,7 +988,7 @@
ty = Type.toXml (ty, region)}),
ty, region)
end
- | Cexp.Fn m =>
+ | Cexp.Fn {match = m, profile} =>
let
val rs as {argType, resultType, rules, ...} =
inferMatch (m, env)
@@ -997,9 +999,10 @@
Xlambda.dest (forceRulesMatch (rs, region))
val resultType = Type.toXml (resultType, region)
val body =
- Xml.Exp.enterLeave (body,
- resultType,
- SourceInfo.fromRegion region)
+ case profile of
+ NONE => body
+ | SOME si =>
+ Xml.Exp.enterLeave (body, resultType, si)
in
Xexp.lambda {arg = arg,
argType = argType,
1.7 +19 -9 mlton/mlton/type-inference/scope.fun
Index: scope.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/scope.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- scope.fun 10 Apr 2002 07:02:21 -0000 1.6
+++ scope.fun 13 Jan 2003 01:14:28 -0000 1.7
@@ -141,12 +141,16 @@
let
val (env, tyvars) = TyvarEnv.rename (env, tyvars)
val (decs, unguarded) =
- renames (decs, fn {var, types, match} =>
+ renames (decs, fn {match, profile, types, var} =>
let
val (types, u1) = renames (types, fn t =>
renameTy (t, env))
val (match, u2) = renameMatch (match, env)
- in ({var = var, types = types, match = match},
+ in
+ ({match = match,
+ profile = profile,
+ types = types,
+ var = var},
Tyvars.+ (u1, u2))
end)
in (doit (Fun {tyvars = (Vector.fromList
@@ -211,9 +215,12 @@
in
(doit (Constraint (e, t)), Tyvars.+ (u1, u2))
end
- | Fn m =>
- let val (m, unguarded) = renameMatch (m, env)
- in (doit (Fn m), unguarded)
+ | Fn {match = m, profile} =>
+ let
+ val (m, unguarded) = renameMatch (m, env)
+ in
+ (doit (Fn {match = m, profile = profile}),
+ unguarded)
end
| Handle (e, m) =>
let
@@ -334,11 +341,12 @@
doit
(Fun {tyvars = tyvars,
decs = (Vector.map
- (decs, fn {var, types, match} =>
- {var = var,
+ (decs, fn {match, profile, types, var} =>
+ {match = removeMatch (match, scope),
+ profile = profile,
types = Vector.map (types, fn t =>
removeTy (t, scope)),
- match = removeMatch (match, scope)}))})
+ var = var}))})
end
| Exception {con, arg} =>
doit (Exception {con = con,
@@ -368,7 +376,9 @@
| Const _ => e
| Constraint (e, t) =>
doit (Constraint (removeExp (e, scope), removeTy (t, scope)))
- | Fn m => doit (Fn (removeMatch (m, scope)))
+ | Fn {match = m, profile} =>
+ doit (Fn {match = removeMatch (m, scope),
+ profile = profile})
| Handle (e, m) =>
doit (Handle (removeExp (e, scope), removeMatch (m, scope)))
| Let (ds, e) => doit (Let (removes (ds, scope, removeDec),
1.15 +1 -1 mlton/mlton/xml/xml-tree.fun
Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- xml-tree.fun 10 Jan 2003 20:52:52 -0000 1.14
+++ xml-tree.fun 13 Jan 2003 01:14:28 -0000 1.15
@@ -342,7 +342,7 @@
fun enterLeave (e: t, ty: Type.t, si: SourceInfo.t): t =
if !Control.profile = Control.ProfileNone
- orelse !Control.profileIL <> Control.ProfileXML
+ orelse !Control.profileIL <> Control.ProfileSource
then e
else
let
-------------------------------------------------------
This SF.NET email is sponsored by:
SourceForge Enterprise Edition + IBM + LinuxWorld = Something 2 See!
http://www.vasoftware.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel