[MLton-devel] cvs commit: Profiling labels in x86-codegen
Matthew Fluet
fluet@users.sourceforge.net
Mon, 20 Jan 2003 08:28:43 -0800
fluet 03/01/20 08:28:43
Modified: mlton/atoms atoms.fun atoms.sig sources.cm
mlton/backend machine-atoms.fun machine-atoms.sig
machine.fun machine.sig
mlton/codegen/x86-codegen peephole.fun peephole.sig
x86-codegen.fun x86-generate-transfers.fun
x86-generate-transfers.sig x86-liveness.fun
x86-liveness.sig x86-mlton-basic.sig x86-mlton.fun
x86-pseudo.sig x86-simplify.fun x86-simplify.sig
x86-translate.fun x86.fun x86.sig
mlton/main compile.sml
Added: mlton/atoms profile-label.fun profile-label.sig
Log:
Ensure that all blocks introduced by the x86 codegen have an
associated profile label. This eliminates an imprecision in time
profiling with the native codegen. The one outstanding issue is the
fact that empty compensation blocks are not removed when they have
profile labels embedded. This shouldn't be too hard to fix, and I'll
try to do so by the end of the week.
Revision Changes Path
1.4 +1 -0 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- atoms.fun 10 Jan 2003 18:36:08 -0000 1.3
+++ atoms.fun 20 Jan 2003 16:28:23 -0000 1.4
@@ -14,6 +14,7 @@
structure SourceInfo = SourceInfo ()
structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
+ structure ProfileLabel = ProfileLabel ()
structure Var = Var (structure AstId = Ast.Var)
structure Tycon = Tycon (structure AstId = Ast.Tycon)
structure UnaryTycon = UnaryTycon (structure Tycon = Tycon)
1.4 +1 -0 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- atoms.sig 10 Jan 2003 18:36:08 -0000 1.3
+++ atoms.sig 20 Jan 2003 16:28:23 -0000 1.4
@@ -19,6 +19,7 @@
structure Const: CONST
structure Prim: PRIM
structure ProfileExp: PROFILE_EXP
+ structure ProfileLabel: PROFILE_LABEL
structure Record: RECORD
structure Scheme: SCHEME
structure SortedRecord: RECORD
1.8 +3 -0 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- sources.cm 10 Jan 2003 18:36:08 -0000 1.7
+++ sources.cm 20 Jan 2003 16:28:24 -0000 1.8
@@ -18,6 +18,7 @@
signature HASH_TYPE
signature PRIM
signature PROFILE_EXP
+signature PROFILE_LABEL
signature RECORD
signature SCHEME
signature SOURCE_INFO
@@ -60,6 +61,8 @@
prim.sig
profile-exp.fun
profile-exp.sig
+profile-label.fun
+profile-label.sig
scheme.sig
source-info.fun
source-info.sig
1.1 mlton/mlton/atoms/profile-label.fun
Index: profile-label.fun
===================================================================
functor ProfileLabel (S: PROFILE_LABEL_STRUCTS): PROFILE_LABEL =
struct
datatype t = T of {plist: PropertyList.t,
uniq: int}
local
fun make f (T r) = f r
in
val plist = make #plist
val uniq = make #uniq
end
local
val c = Counter.new 0
in
fun new () = T {plist = PropertyList.new (),
uniq = Counter.next c}
end
fun toString (T {uniq, ...}) =
concat ["MLtonProfile", Int.toString uniq]
val layout = Layout.str o toString
fun equals (l, l') = uniq l = uniq l'
val clear = PropertyList.clear o plist
end
1.1 mlton/mlton/atoms/profile-label.sig
Index: profile-label.sig
===================================================================
type int = Int.t
type word = Word.t
signature PROFILE_LABEL_STRUCTS =
sig
end
signature PROFILE_LABEL =
sig
type t
val clear: t -> unit
val equals: t * t -> bool
val layout: t -> Layout.t
val new: unit -> t
val plist: t -> PropertyList.t
val toString: t -> string
end
1.6 +0 -29 mlton/mlton/backend/machine-atoms.fun
Index: machine-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- machine-atoms.fun 2 Jan 2003 17:45:14 -0000 1.5
+++ machine-atoms.fun 20 Jan 2003 16:28:26 -0000 1.6
@@ -413,35 +413,6 @@
(PointerTycon.wordVector, wordVector)]
end
-structure ProfileLabel =
- struct
- datatype t = T of {plist: PropertyList.t,
- uniq: int}
-
- local
- fun make f (T r) = f r
- in
- val plist = make #plist
- val uniq = make #uniq
- end
-
- local
- val c = Counter.new 0
- in
- fun new () = T {plist = PropertyList.new (),
- uniq = Counter.next c}
- end
-
- fun toString (T {uniq, ...}) =
- concat ["MLtonProfile", Int.toString uniq]
-
- val layout = Layout.str o toString
-
- fun equals (l, l') = uniq l = uniq l'
-
- val clear = PropertyList.clear o plist
- end
-
fun castIsOk {from: Type.t,
fromInt: int option,
to: Type.t,
1.6 +1 -12 mlton/mlton/backend/machine-atoms.sig
Index: machine-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine-atoms.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- machine-atoms.sig 2 Jan 2003 17:45:14 -0000 1.5
+++ machine-atoms.sig 20 Jan 2003 16:28:26 -0000 1.6
@@ -11,6 +11,7 @@
sig
structure Label: HASH_ID
structure Prim: PRIM
+ structure ProfileLabel: PROFILE_LABEL
structure Runtime: RUNTIME
structure SourceInfo: SOURCE_INFO
end
@@ -112,18 +113,6 @@
val thread: t
val toRuntime: t -> Runtime.ObjectType.t
val wordVector: t
- end
-
- structure ProfileLabel:
- sig
- type t
-
- val clear: t -> unit
- val equals: t * t -> bool
- val layout: t -> Layout.t
- val new: unit -> t
- val plist: t -> PropertyList.t
- val toString: t -> string
end
val castIsOk: {from: Type.t,
1.40 +48 -0 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- machine.fun 6 Jan 2003 01:15:30 -0000 1.39
+++ machine.fun 20 Jan 2003 16:28:27 -0000 1.40
@@ -21,6 +21,7 @@
structure Atoms = MachineAtoms (structure Label = Label
structure Prim = Prim
+ structure ProfileLabel = ProfileLabel
structure Runtime = Runtime
structure SourceInfo = SourceInfo)
@@ -678,6 +679,53 @@
(sourceSuccessors, fn i =>
0 <= i andalso i < sourceSeqsLength))
end
+
+ fun modify (T {frameSources, labels, sourceSeqs, sourceSuccessors, sources}) :
+ {newProfileLabel: ProfileLabel.t -> ProfileLabel.t,
+ delProfileLabel: ProfileLabel.t -> unit,
+ getProfileInfo: unit -> t} =
+ let
+ val {get: ProfileLabel.t -> int, set, ...} =
+ Property.getSet
+ (ProfileLabel.plist,
+ Property.initRaise ("ProfileInfo.extend", ProfileLabel.layout))
+ val _ =
+ Vector.foreach
+ (labels, fn {label, sourceSeqsIndex} =>
+ set (label, sourceSeqsIndex))
+ val new = ref []
+ fun newProfileLabel l =
+ let
+ val i = get l
+ val l' = ProfileLabel.new ()
+ val _ = set (l', i)
+ val _ = List.push (new, {label = l', sourceSeqsIndex = i})
+ in
+ l'
+ end
+ fun delProfileLabel l = set (l, ~1)
+ fun getProfileInfo () =
+ let
+ val labels = Vector.concat
+ [labels, Vector.fromList (!new)]
+ val labels = Vector.keepAll
+ (labels, fn {label, ...} =>
+ get label <> ~1)
+ val pi = T {frameSources = frameSources,
+ labels = Vector.concat
+ [labels, Vector.fromList (!new)],
+ sourceSeqs = sourceSeqs,
+ sourceSuccessors = sourceSuccessors,
+ sources = sources}
+ in
+ Assert.assert ("newProfileInfo", fn () => isOK pi);
+ pi
+ end
+ in
+ {newProfileLabel = newProfileLabel,
+ delProfileLabel = delProfileLabel,
+ getProfileInfo = getProfileInfo}
+ end
end
structure Program =
1.30 +5 -0 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- machine.sig 4 Jan 2003 02:00:33 -0000 1.29
+++ machine.sig 20 Jan 2003 16:28:28 -0000 1.30
@@ -12,6 +12,7 @@
sig
structure Label: HASH_ID
structure Prim: PRIM
+ structure ProfileLabel: PROFILE_LABEL
structure SourceInfo: SOURCE_INFO
end
@@ -223,6 +224,10 @@
sourceSeqs: int vector vector,
sourceSuccessors: int vector,
sources: SourceInfo.t vector}
+
+ val modify: t -> {newProfileLabel: ProfileLabel.t -> ProfileLabel.t,
+ delProfileLabel: ProfileLabel.t -> unit,
+ getProfileInfo: unit -> t}
end
structure Program:
1.5 +13 -2 mlton/mlton/codegen/x86-codegen/peephole.fun
Index: peephole.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/peephole.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- peephole.fun 20 Dec 2002 18:29:43 -0000 1.4
+++ peephole.fun 20 Jan 2003 16:28:30 -0000 1.5
@@ -30,6 +30,7 @@
transfer: transfer_element}
type match = {entry: entry_type,
+ profileLabel: profileLabel_type,
start: statement_type list,
statements: statement_type list list,
finish: statement_type list,
@@ -51,6 +52,7 @@
type find_state = {remaining: optimization list,
state: {entry: entry_type,
+ profileLabel: profileLabel_type,
start: statement_type list,
finish: statement_type list,
transfer: transfer_type}}
@@ -164,7 +166,7 @@
match_state: match_state}
= let
fun next {remaining: optimization list,
- state as {entry, start, finish, transfer}} :
+ state as {entry, profileLabel, start, finish, transfer}} :
find_state option
= (case remaining
of [] => NONE
@@ -174,6 +176,7 @@
| statement::finish
=> SOME {remaining = optimizations,
state = {entry = entry,
+ profileLabel = profileLabel,
start = statement::start,
finish = finish,
transfer = transfer}})
@@ -192,6 +195,7 @@
= template_transfer},
...}::_,
state as {entry,
+ profileLabel,
start,
finish,
transfer}}) :
@@ -202,6 +206,7 @@
of SOME find_state => findMatch' find_state
| NONE
=> Done {block = T {entry = entry,
+ profileLabel = profileLabel,
statements = List.fold(start,
finish,
op ::),
@@ -225,6 +230,7 @@
else Continue {remaining = remaining,
match
= {entry = entry,
+ profileLabel = profileLabel,
start = start,
statements = statements,
finish = finish,
@@ -234,11 +240,13 @@
fun findMatch (match_state: match_state) : match_state
= case match_state
- of Start {block as T {entry, statements, transfer}}
+ of Start {block as T {entry, profileLabel,
+ statements, transfer}}
=> let
val find_state
= {remaining = optimizations,
state = {entry = entry,
+ profileLabel = profileLabel,
start = [],
finish = statements,
transfer = transfer}}
@@ -247,6 +255,7 @@
end
| Continue {remaining,
match as {entry,
+ profileLabel,
start,
statements,
finish,
@@ -259,6 +268,7 @@
val find_state
= {remaining = remaining,
state = {entry = entry,
+ profileLabel = profileLabel,
start = start,
finish = finish,
transfer = transfer}}
@@ -266,6 +276,7 @@
case next find_state
of NONE => Done {block
= T {entry = entry,
+ profileLabel = profileLabel,
statements = List.fold(start,
finish,
op ::),
1.5 +4 -1 mlton/mlton/codegen/x86-codegen/peephole.sig
Index: peephole.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/peephole.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- peephole.sig 20 Dec 2002 18:29:43 -0000 1.4
+++ peephole.sig 20 Jan 2003 16:28:31 -0000 1.5
@@ -11,9 +11,11 @@
signature PEEPHOLE_TYPES =
sig
type entry_type
+ type profileLabel_type
type statement_type
type transfer_type
datatype block = T of {entry: entry_type,
+ profileLabel: profileLabel_type,
statements: statement_type list,
transfer: transfer_type}
end
@@ -38,6 +40,7 @@
transfer: transfer_element}
type match = {entry: entry_type,
+ profileLabel: profileLabel_type,
start: statement_type list,
statements: statement_type list list,
finish: statement_type list,
@@ -59,4 +62,4 @@
optimizations: optimization list} ->
{blocks: block list,
changed: bool}
- end
+ end
\ No newline at end of file
1.36 +38 -11 mlton/mlton/codegen/x86-codegen/x86-codegen.fun
Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -r1.35 -r1.36
--- x86-codegen.fun 20 Dec 2002 18:29:43 -0000 1.35
+++ x86-codegen.fun 20 Jan 2003 16:28:31 -0000 1.36
@@ -11,6 +11,7 @@
structure x86
= x86(structure Label = Machine.Label
+ structure ProfileLabel = Machine.ProfileLabel
structure Runtime = Machine.Runtime)
structure x86MLtonBasic
@@ -78,15 +79,7 @@
open x86
structure Type = Machine.Type
- fun output {program as Machine.Program.T {chunks,
- frameLayouts,
- frameOffsets,
- handlesSignals,
- intInfs,
- main,
- maxFrameSize,
- strings,
- ...},
+ fun output {program as Machine.Program.T {chunks, frameLayouts, main, ...},
includes: string list,
outputC,
outputS}: unit
@@ -105,9 +98,41 @@
val makeC = outputC
val makeS = outputS
+ val Machine.Program.T {profileInfo, ...} = program
+ val {newProfileLabel, delProfileLabel, getProfileInfo} =
+ Machine.ProfileInfo.modify profileInfo
+
(* C specific *)
fun outputC ()
= let
+ local
+ val Machine.Program.T
+ {chunks,
+ frameLayouts,
+ frameOffsets,
+ handlesSignals,
+ intInfs,
+ main,
+ maxFrameSize,
+ objectTypes,
+ reals,
+ strings, ...} =
+ program
+ in
+ val program =
+ Machine.Program.T
+ {chunks = chunks,
+ frameLayouts = frameLayouts,
+ frameOffsets = frameOffsets,
+ handlesSignals = handlesSignals,
+ intInfs = intInfs,
+ main = main,
+ maxFrameSize = maxFrameSize,
+ objectTypes = objectTypes,
+ profileInfo = getProfileInfo (),
+ reals = reals,
+ strings = strings}
+ end
val {file, print, done} = makeC ()
fun make (name, l, pr, last) =
(print (concat ["static ", name, " = {"])
@@ -209,6 +234,7 @@
optimize = if isMain
then 0
else !Control.Native.optimize,
+ delProfileLabel = delProfileLabel,
liveInfo = liveInfo,
jumpInfo = jumpInfo}
handle exn
@@ -221,6 +247,7 @@
= (x86GenerateTransfers.generateTransfers
{chunk = chunk,
optimize = !Control.Native.optimize,
+ newProfileLabel = newProfileLabel,
liveInfo = liveInfo,
jumpInfo = jumpInfo,
reserveEsp = reserveEsp})
@@ -306,7 +333,7 @@
val outputAssembly =
Control.trace (Control.Pass, "outputAssembly") outputAssembly
in
- outputC()
- ; outputAssembly()
+ outputAssembly()
+ ; outputC()
end
end
1.37 +48 -15 mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun
Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- x86-generate-transfers.fun 2 Jan 2003 17:45:17 -0000 1.36
+++ x86-generate-transfers.fun 20 Jan 2003 16:28:31 -0000 1.37
@@ -125,6 +125,7 @@
fun generateTransfers {chunk as Chunk.T {data, blocks, ...},
optimize: int,
+ newProfileLabel: x86.ProfileLabel.t -> x86.ProfileLabel.t,
liveInfo : x86Liveness.LiveInfo.t,
jumpInfo : x86JumpInfo.t,
reserveEsp: bool}
@@ -351,6 +352,22 @@
setLayoutInfo(label, SOME block)
end)
+ val profileLabel as {get = getProfileLabel : Label.t -> ProfileLabel.t option,
+ set = setProfileLabel,
+ destroy = destProfileLabel}
+ = Property.destGetSetOnce
+ (Label.plist,
+ Property.initRaise ("profileLabel", Label.layout))
+ val _
+ = List.foreach
+ (blocks,
+ fn block as Block.T {entry, profileLabel, ...}
+ => let
+ val label = Entry.label entry
+ in
+ setProfileLabel(label, profileLabel)
+ end)
+
local
val stack = ref []
val queue = ref (Queue.empty ())
@@ -371,8 +388,11 @@
= let
val label' = Label.new label
val live = getLive(liveInfo, label)
+ val profileLabel = getProfileLabel label
+ val profileLabel' = Option.map (profileLabel, newProfileLabel)
val block
= Block.T {entry = Entry.jump {label = label'},
+ profileLabel = profileLabel',
statements
= (Assembly.directive_restoreregalloc
{live = MemLocSet.add
@@ -385,6 +405,7 @@
transfer = Transfer.goto {target = label}}
in
setLive(liveInfo, label', live);
+ setProfileLabel(label', profileLabel');
incNear(jumpInfo, label');
Assert.assert("pushCompensationBlock",
fn () => getNear(jumpInfo, label') = Count 1);
@@ -420,7 +441,7 @@
Assembly.t AppendList.t
= (case getLayoutInfo label
of NONE => AppendList.empty
- | SOME (Block.T {entry, statements, transfer})
+ | SOME (Block.T {entry, profileLabel, statements, transfer})
=> let
val _ = setLayoutInfo(label, NONE)
@@ -475,7 +496,10 @@
in
AppendList.appends
[align,
- AppendList.single (Assembly.label label),
+ AppendList.single
+ (Assembly.label label),
+ AppendList.fromList
+ (ProfileLabel.toAssemblyOpt profileLabel),
assumes]
end
val pre
@@ -536,13 +560,15 @@
(* assignTo dst *)
getReturn ()]
in
- AppendList.append
- (AppendList.fromList
+ AppendList.appends
+ [AppendList.fromList
[Assembly.pseudoop_p2align
(Immediate.const_int 4, NONE, NONE),
Assembly.pseudoop_long
[Immediate.const_int frameLayoutsIndex],
Assembly.label label],
+ AppendList.fromList
+ (ProfileLabel.toAssemblyOpt profileLabel),
if maySwitchThreads
then (* entry from far assumptions *)
farEntry finish
@@ -568,31 +594,35 @@
=> {memloc = memloc,
sync = sync,
weight = 1024}))})],
- finish))
+ finish)]
end
else AppendList.append (near label, getReturn ())
end
| Func {label,...}
- => AppendList.append
- (AppendList.fromList
+ => AppendList.appends
+ [AppendList.fromList
[Assembly.pseudoop_p2align
(Immediate.const_int 4, NONE, NONE),
Assembly.pseudoop_global label,
Assembly.label label],
+ AppendList.fromList
+ (ProfileLabel.toAssemblyOpt profileLabel),
(* entry from far assumptions *)
- (farEntry AppendList.empty))
+ (farEntry AppendList.empty)]
| Cont {label,
frameInfo = FrameInfo.T {size,
frameLayoutsIndex},
...}
=>
- AppendList.append
- (AppendList.fromList
+ AppendList.appends
+ [AppendList.fromList
[Assembly.pseudoop_p2align
(Immediate.const_int 4, NONE, NONE),
Assembly.pseudoop_long
[Immediate.const_int frameLayoutsIndex],
Assembly.label label],
+ AppendList.fromList
+ (ProfileLabel.toAssemblyOpt profileLabel),
(* entry from far assumptions *)
(farEntry
(let
@@ -609,18 +639,20 @@
src = bytes,
size = pointerSize},
profileStackTopCommit)
- end)))
+ end))]
| Handler {frameInfo = (FrameInfo.T
{frameLayoutsIndex, size}),
label,
...}
- => AppendList.append
- (AppendList.fromList
+ => AppendList.appends
+ [AppendList.fromList
[Assembly.pseudoop_p2align
(Immediate.const_int 4, NONE, NONE),
Assembly.pseudoop_long
[Immediate.const_int frameLayoutsIndex],
Assembly.label label],
+ AppendList.fromList
+ (ProfileLabel.toAssemblyOpt profileLabel),
(* entry from far assumptions *)
(farEntry
(let
@@ -637,8 +669,8 @@
src = bytes,
size = pointerSize},
profileStackTopCommit)
- end)))
-val pre
+ end))]
+ val pre
= AppendList.appends
[if !Control.Native.commented > 1
then AppendList.single
@@ -1887,6 +1919,7 @@
| block => block::(doit ())))
val assembly = doit ()
val _ = destLayoutInfo ()
+ val _ = destProfileLabel ()
in
data::assembly
end
1.10 +1 -0 mlton/mlton/codegen/x86-codegen/x86-generate-transfers.sig
Index: x86-generate-transfers.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- x86-generate-transfers.sig 16 Apr 2002 12:10:52 -0000 1.9
+++ x86-generate-transfers.sig 20 Jan 2003 16:28:32 -0000 1.10
@@ -31,6 +31,7 @@
val generateTransfers:
{chunk: x86.Chunk.t,
optimize: int,
+ newProfileLabel: x86.ProfileLabel.t -> x86.ProfileLabel.t,
liveInfo: x86Liveness.LiveInfo.t,
jumpInfo: x86JumpInfo.t,
reserveEsp: bool} -> x86.Assembly.t list list
1.13 +10 -5 mlton/mlton/codegen/x86-codegen/x86-liveness.fun
Index: x86-liveness.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-liveness.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- x86-liveness.fun 20 Dec 2002 18:29:44 -0000 1.12
+++ x86-liveness.fun 20 Jan 2003 16:28:32 -0000 1.13
@@ -504,10 +504,11 @@
structure LivenessBlock =
struct
datatype t = T of {entry: (Entry.t * Liveness.t),
+ profileLabel: ProfileLabel.t option,
statements: (Assembly.t * Liveness.t) list,
transfer: Transfer.t * Liveness.t}
- fun toString (T {entry, statements, transfer})
+ fun toString (T {entry, statements, transfer, ...})
= concat [let
val (entry,info) = entry
in
@@ -533,7 +534,7 @@
"\n"]
end]
- fun printBlock (T {entry, statements, transfer})
+ fun printBlock (T {entry, statements, transfer, ...})
= (let
val (entry,info) = entry
in
@@ -650,7 +651,8 @@
live = live}
end
- fun toLivenessBlock {block as Block.T {entry, statements, transfer},
+ fun toLivenessBlock {block as Block.T {entry, profileLabel,
+ statements, transfer},
liveInfo : LiveInfo.t}
= let
val {transfer, live}
@@ -667,6 +669,7 @@
val liveness_block
= T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer}
in
@@ -717,7 +720,7 @@
live = live'}
end
- fun verifyLivenessBlock {block as T {entry, statements, transfer},
+ fun verifyLivenessBlock {block as T {entry, statements, transfer, ...},
liveInfo: LiveInfo.t}
= let
val {verified = verified_transfer,
@@ -754,13 +757,15 @@
"verifyLivenessBlock"
verifyLivenessBlock
- fun toBlock {block as T {entry, statements, transfer}}
+ fun toBlock {block as T {entry, profileLabel,
+ statements, transfer}}
= let
val (entry,info) = entry
val statements = List.map(statements, fn (asm,info) => asm)
val (transfer,info) = transfer
in
Block.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer}
end
1.11 +1 -0 mlton/mlton/codegen/x86-codegen/x86-liveness.sig
Index: x86-liveness.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-liveness.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- x86-liveness.sig 20 Dec 2002 18:29:44 -0000 1.10
+++ x86-liveness.sig 20 Jan 2003 16:28:32 -0000 1.11
@@ -60,6 +60,7 @@
structure LivenessBlock:
sig
datatype t = T of {entry: (x86.Entry.t * Liveness.t),
+ profileLabel: x86.ProfileLabel.t option,
statements: (x86.Assembly.t * Liveness.t) list,
transfer: (x86.Transfer.t * Liveness.t)}
1.22 +1 -0 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86-mlton-basic.sig 3 Jan 2003 06:14:16 -0000 1.21
+++ x86-mlton-basic.sig 20 Jan 2003 16:28:33 -0000 1.22
@@ -13,6 +13,7 @@
structure x86 : X86_PSEUDO
structure Machine: MACHINE
sharing x86.Label = Machine.Label
+ sharing type x86.ProfileLabel.t = Machine.ProfileLabel.t
sharing x86.Runtime = Machine.Runtime
end
1.41 +46 -46 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -r1.40 -r1.41
--- x86-mlton.fun 20 Dec 2002 18:29:44 -0000 1.40
+++ x86-mlton.fun 20 Jan 2003 16:28:33 -0000 1.41
@@ -49,7 +49,7 @@
fun unimplemented s
= AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements = [Assembly.comment ("UNIMPLEMENTED PRIM: " ^ s)],
transfer = NONE}]
@@ -80,7 +80,7 @@
"applyPrim: lengthArrayVectorString, src"
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -132,7 +132,7 @@
| _ => Error.bug "applyPrim: subWord8ArrayVector, src2"
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -184,7 +184,7 @@
| _ => Error.bug "applyPrim: updateWord8Array, src2"
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -204,7 +204,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -224,7 +224,7 @@
fn () => Size.lt(srcsize,dstsize))
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_movx
@@ -246,7 +246,7 @@
fn () => Size.lt(dstsize,srcsize))
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_xvom
@@ -292,7 +292,7 @@
else (src1,src2)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -336,7 +336,7 @@
else (src1,src2)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -376,7 +376,7 @@
| _ => (src1,src2)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -400,7 +400,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -429,7 +429,7 @@
fn () => src2size = wordSize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_mov
@@ -463,7 +463,7 @@
*)
case Operand.deImmediate src1
of SOME _ => AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_cmp
@@ -477,7 +477,7 @@
size = dstsize}],
transfer = NONE}]
| NONE => AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_cmp
@@ -510,7 +510,7 @@
*)
case Operand.deImmediate src1
of SOME _ => AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_test
@@ -524,7 +524,7 @@
size = dstsize}],
transfer = NONE}]
| NONE => AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_test
@@ -562,7 +562,7 @@
| _ => (oper,src1,src2)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmov
@@ -591,7 +591,7 @@
src3size = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmov
@@ -621,7 +621,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmov
@@ -645,7 +645,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfldc
@@ -667,14 +667,14 @@
val comment = primName
in
(AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements
= [x86.Assembly.comment
("begin prim: " ^ comment)],
transfer = NONE}),
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements
= [x86.Assembly.comment
@@ -700,7 +700,7 @@
val (src,srcsize) = getSrc1 ()
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_cmp
@@ -726,7 +726,7 @@
class = Classes.CStatic}
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [case Size.class dstsize
@@ -769,7 +769,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmov
@@ -819,7 +819,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmov
@@ -865,7 +865,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmov
@@ -895,7 +895,7 @@
src2size = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmov
@@ -920,7 +920,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfldc
@@ -979,7 +979,7 @@
fn () => srcsize = dstsize)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmov
@@ -1008,7 +1008,7 @@
fn () => src1size = src2size)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfcom
@@ -1039,7 +1039,7 @@
fn () => src1size = src2size)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfcom
@@ -1070,7 +1070,7 @@
fn () => src1size = src2size)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfucom
@@ -1106,7 +1106,7 @@
fn () => src1size = src2size)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfcom
@@ -1137,7 +1137,7 @@
fn () => src1size = src2size)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfcom
@@ -1168,7 +1168,7 @@
fn () => src1size = src2size)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfucom
@@ -1195,7 +1195,7 @@
val (src,srcsize) = getSrc1 ()
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmovfi
@@ -1211,7 +1211,7 @@
val (src,srcsize) = getSrc1 ()
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmovti
@@ -1236,7 +1236,7 @@
fn () => src2size = Size.LONG)
in
AppendList.fromList
- [Block.T'
+ [Block.mkBlock'
{entry = NONE,
statements
= [Assembly.instruction_pfmovfi
@@ -1321,7 +1321,7 @@
val dstsize = Option.map (returnTy, toX86Size)
val comment_begin
= if !Control.Native.commented > 0
- then AppendList.single (x86.Block.T'
+ then AppendList.single (x86.Block.mkBlock'
{entry = NONE,
statements
= [x86.Assembly.comment
@@ -1332,7 +1332,7 @@
AppendList.appends
[comment_begin,
AppendList.single
- (Block.T'
+ (Block.mkBlock'
{entry = NONE,
statements = [],
transfer = SOME (Transfer.ccall
@@ -1361,7 +1361,7 @@
(liveInfo, label, live label)
in
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = SOME (Entry.creturn {dst = dst,
frameInfo = frameInfo,
func = func,
@@ -1372,7 +1372,7 @@
val comment_end
= if !Control.Native.commented > 0
then (AppendList.single
- (x86.Block.T' {entry = NONE,
+ (x86.Block.mkBlock' {entry = NONE,
statements = [x86.Assembly.comment
("end creturn: " ^ name)],
transfer = NONE}))
@@ -1400,7 +1400,7 @@
fn () => src1size = dstsize)
fun check (src, statement, condition)
= AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [x86.Assembly.instruction_mov
{dst = dst,
@@ -1516,14 +1516,14 @@
val comment = primName
in
(AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements
= [x86.Assembly.comment
("begin arith: " ^ comment)],
transfer = NONE}),
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements
= [x86.Assembly.comment
1.16 +17 -8 mlton/mlton/codegen/x86-codegen/x86-pseudo.sig
Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- x86-pseudo.sig 2 Jan 2003 17:45:18 -0000 1.15
+++ x86-pseudo.sig 20 Jan 2003 16:28:35 -0000 1.16
@@ -453,15 +453,24 @@
target: Label.t} -> t
end
- structure Block :
+ structure ProfileLabel :
sig
- datatype t' = T' of {entry: Entry.t option,
- statements: Assembly.t list,
- transfer: Transfer.t option}
- datatype t = T of {entry: Entry.t,
- statements: Assembly.t list,
- transfer: Transfer.t}
- val compress : t' list -> t list
+ type t
+ end
+
+ structure Block :
+ sig
+ type t'
+ val mkBlock': {entry: Entry.t option,
+ statements: Assembly.t list,
+ transfer: Transfer.t option} -> t'
+ val mkProfileBlock': {profileLabel: ProfileLabel.t} -> t'
+ val printBlock' : t' -> unit
+
+ type t
+ val printBlock : t -> unit
+
+ val compress: t' list -> t list
end
structure Chunk :
1.24 +129 -6 mlton/mlton/codegen/x86-codegen/x86-simplify.fun
Index: x86-simplify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-simplify.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- x86-simplify.fun 20 Dec 2002 18:29:44 -0000 1.23
+++ x86-simplify.fun 20 Jan 2003 16:28:35 -0000 1.24
@@ -22,6 +22,7 @@
struct
structure Peephole
= Peephole(type entry_type = Entry.t
+ type profileLabel_type = ProfileLabel.t option
type statement_type = Assembly.t
type transfer_type = Transfer.t
datatype block = datatype Block.t)
@@ -72,6 +73,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -110,11 +112,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -153,11 +157,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -194,6 +200,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -235,6 +242,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.pFMOV
@@ -273,11 +281,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.pFMOV
@@ -316,11 +326,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.pFMOV
@@ -359,6 +371,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -437,6 +450,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -478,12 +492,14 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
| _ => NONE
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -525,12 +541,14 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
| _ => NONE
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -570,6 +588,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -615,6 +634,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -687,11 +707,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -764,11 +786,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -834,6 +858,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -879,6 +904,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -944,11 +970,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -1014,11 +1042,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.MOV
@@ -1080,6 +1110,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1134,6 +1165,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.BinAL
@@ -1196,6 +1228,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1276,6 +1309,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.pMD
@@ -1307,6 +1341,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1324,6 +1359,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1350,11 +1386,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
| _ => NONE)
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.pMD
@@ -1370,6 +1408,7 @@
| SOME (0,false)
=> SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = List.fold(start,
List.concat [comments, finish],
op ::),
@@ -1390,6 +1429,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1416,6 +1456,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1445,11 +1486,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE)
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.pMD
@@ -1465,6 +1508,7 @@
| SOME (0,false)
=> SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = List.fold(start,
List.concat [comments, finish],
op ::),
@@ -1487,6 +1531,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1494,6 +1539,7 @@
| SOME (i,true)
=> NONE)
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.pMD
@@ -1509,6 +1555,7 @@
| SOME (0,false)
=> SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = List.fold(start,
List.concat [comments, finish],
op ::),
@@ -1529,6 +1576,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1596,11 +1644,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE)
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.pMD
@@ -1616,6 +1666,7 @@
| SOME (0,false)
=> SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = List.fold(start,
List.concat [comments, finish],
op ::),
@@ -1638,12 +1689,14 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| SOME (i,true) => NONE)
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.IMUL2
@@ -1674,6 +1727,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1691,6 +1745,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1717,11 +1772,13 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
| _ => NONE)
| {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction (Instruction.IMUL2
@@ -1736,6 +1793,7 @@
| SOME (0,false)
=> SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = List.fold(start,
List.concat [comments, finish],
op ::),
@@ -1756,6 +1814,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1782,6 +1841,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1811,6 +1871,7 @@
in
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1864,6 +1925,7 @@
val rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction instruction],
@@ -1892,6 +1954,7 @@
op ::)
in
SOME (Block.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -1937,6 +2000,7 @@
val rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction
@@ -1978,6 +2042,7 @@
falsee = falsee}
in
SOME (Block.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -2033,6 +2098,7 @@
val rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[Assembly.Instruction instruction],
@@ -2060,6 +2126,7 @@
op ::)
in
SOME (Block.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -2175,6 +2242,7 @@
val rewriter
= fn {entry,
+ profileLabel,
start,
statements as [],
finish as [],
@@ -2190,6 +2258,7 @@
val transfer = Transfer.goto {target = truee}
in
SOME (Block.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -2222,6 +2291,7 @@
val rewriter
= fn {entry,
+ profileLabel,
start as [],
statements as [statements'],
finish as [],
@@ -2266,6 +2336,7 @@
else Error.bug "elimSwitchTest"
in
SOME (Block.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -2304,6 +2375,7 @@
val rewriter
= fn {entry,
+ profileLabel,
start as [],
statements as [statements'],
finish as [],
@@ -2356,6 +2428,7 @@
default = default})
in
SOME (Block.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -2370,6 +2443,7 @@
structure ElimGoto =
struct
fun elimSimpleGoto {chunk as Chunk.T {data, blocks, ...},
+ delProfileLabel : x86.ProfileLabel.t -> unit,
jumpInfo : x86JumpInfo.t}
= let
val gotoInfo as {get: Label.t -> Label.t option,
@@ -2382,6 +2456,7 @@
= List.keepAllMap
(blocks,
fn block as Block.T {entry as Entry.Jump {label},
+ profileLabel,
statements,
transfer as Transfer.Goto {target}}
=> if List.forall(statements,
@@ -2391,7 +2466,9 @@
andalso
not (Label.equals(label, target))
*)
- then (set(label, SOME target); SOME label)
+ then (Option.app(profileLabel, delProfileLabel);
+ set(label, SOME target);
+ SOME label)
else NONE
| _ => NONE)
@@ -2442,8 +2519,9 @@
val blocks
= List.map
(blocks,
- fn Block.T {entry, statements, transfer}
+ fn Block.T {entry, profileLabel, statements, transfer}
=> Block.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = elimSimpleGoto' transfer})
@@ -2496,6 +2574,7 @@
=> case get label
of SOME (Block.T
{entry,
+ profileLabel,
statements,
transfer as Transfer.Goto {target}})
=> (if Label.equals(label,target)
@@ -2504,14 +2583,20 @@
of NONE => b
| SOME (Block.T
{entry = entry',
+ profileLabel = profileLabel',
statements = statements',
transfer = transfer'})
=> (set(label,
SOME (Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements
= List.concat
- [statements,
+ [statements,
+ [Assembly.Label
+ (Entry.label entry')],
+ ProfileLabel.toAssemblyOpt
+ profileLabel',
statements'],
transfer
= transfer'}));
@@ -2525,6 +2610,7 @@
val changed = ref false
val elimComplexGoto'
= fn block as Block.T {entry,
+ profileLabel,
statements,
transfer as Transfer.Goto {target}}
=> if Label.equals(Entry.label entry,target)
@@ -2532,6 +2618,7 @@
else (case get target
of NONE => block
| SOME (Block.T {entry = entry',
+ profileLabel = profileLabel',
statements = statements',
transfer = transfer'})
=> let
@@ -2547,9 +2634,14 @@
val block
= Block.T {entry = entry,
+ profileLabel = profileLabel,
statements
= List.concat
- [statements,
+ [statements,
+ [Assembly.label
+ (Entry.label entry')],
+ ProfileLabel.toAssemblyOpt
+ profileLabel',
statements'],
transfer = transfer'}
in
@@ -2622,6 +2714,7 @@
fn label
=> let
val {block as Block.T {entry,
+ profileLabel,
statements,
transfer},
reach} = get label
@@ -2630,6 +2723,7 @@
then SOME
(Block.T
{entry = entry,
+ profileLabel = profileLabel,
statements
= List.keepAll
(statements,
@@ -2659,6 +2753,7 @@
elimBlocks
fun elimGoto {chunk : Chunk.t,
+ delProfileLabel: x86.ProfileLabel.t -> unit,
jumpInfo : x86JumpInfo.t}
= let
val elimIff
@@ -2673,6 +2768,7 @@
val {chunk,
changed = changed_elimSimpleGoto}
= elimSimpleGoto {chunk = chunk,
+ delProfileLabel = delProfileLabel,
jumpInfo = jumpInfo}
val Chunk.T {data, blocks, ...} = chunk
@@ -2736,7 +2832,8 @@
structure Liveness = x86Liveness.Liveness
structure LivenessBlock = x86Liveness.LivenessBlock
- fun moveHoist {block as LivenessBlock.T {entry, statements, transfer}}
+ fun moveHoist {block as LivenessBlock.T
+ {entry, profileLabel, statements, transfer}}
= let
val {transfer,live}
= LivenessBlock.reLivenessTransfer {transfer = transfer}
@@ -3026,6 +3123,7 @@
fn force as {age,...}
=> age <> 0)
val block = LivenessBlock.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer}
in
@@ -3271,7 +3369,8 @@
| copyPropagate' _ = Error.bug "copyPropagate'"
- fun copyPropagate {block as LivenessBlock.T {entry, statements, transfer},
+ fun copyPropagate {block as LivenessBlock.T
+ {entry, profileLabel, statements, transfer},
liveInfo}
= let
val {pblock as {statements,transfer},changed}
@@ -3356,6 +3455,7 @@
changed = changed})
in
{block = LivenessBlock.T {entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer},
changed = changed}
@@ -3388,6 +3488,7 @@
structure Peephole
= Peephole(type entry_type = Entry.t * Liveness.t
+ type profileLabel_type = ProfileLabel.t option
type statement_type = Assembly.t * Liveness.t
type transfer_type = Transfer.t * Liveness.t
datatype block = datatype LivenessBlock.t)
@@ -3440,6 +3541,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction instruction,
@@ -3498,6 +3600,7 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -3570,6 +3673,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction (Instruction.MOV
@@ -3695,6 +3799,7 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -3728,6 +3833,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction (Instruction.MOV
@@ -3745,6 +3851,7 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -3805,6 +3912,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction (Instruction.MOV
@@ -3880,11 +3988,13 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction (Instruction.MOV
@@ -3960,11 +4070,13 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
else NONE
| {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction (Instruction.MOV
@@ -4038,6 +4150,7 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -4109,6 +4222,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction (Instruction.pFMOV
@@ -4224,6 +4338,7 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -4257,6 +4372,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction (Instruction.pFMOV
@@ -4275,6 +4391,7 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -4316,6 +4433,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[(Assembly.Instruction (Instruction.pFMOV
@@ -4391,6 +4509,7 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -4443,6 +4562,7 @@
val rewriter : rewriter
= fn {entry,
+ profileLabel,
start,
statements as
[[(statement as
@@ -4516,6 +4636,7 @@
in
SOME (LivenessBlock.T
{entry = entry,
+ profileLabel = profileLabel,
statements = statements,
transfer = transfer})
end
@@ -4643,6 +4764,7 @@
fun simplify {chunk as Chunk.T {data, blocks, ...}: Chunk.t,
optimize : int,
+ delProfileLabel : x86.ProfileLabel.t -> unit,
liveInfo : x86Liveness.LiveInfo.t,
jumpInfo : x86JumpInfo.t} :
Chunk.t
@@ -4821,6 +4943,7 @@
val {chunk = chunk',
changed = changed'}
= ElimGoto.elimGoto {chunk = chunk,
+ delProfileLabel = delProfileLabel,
jumpInfo = jumpInfo}
handle exn
=> Error.bug
1.4 +1 -0 mlton/mlton/codegen/x86-codegen/x86-simplify.sig
Index: x86-simplify.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-simplify.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- x86-simplify.sig 10 Apr 2002 07:02:19 -0000 1.3
+++ x86-simplify.sig 20 Jan 2003 16:28:36 -0000 1.4
@@ -25,6 +25,7 @@
val simplify : {chunk : x86.Chunk.t,
optimize : int,
+ delProfileLabel : x86.ProfileLabel.t -> unit,
liveInfo : x86Liveness.LiveInfo.t,
jumpInfo : x86JumpInfo.t} -> x86.Chunk.t
1.38 +28 -51 mlton/mlton/codegen/x86-codegen/x86-translate.fun
Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- x86-translate.fun 3 Jan 2003 06:14:16 -0000 1.37
+++ x86-translate.fun 20 Jan 2003 16:28:37 -0000 1.38
@@ -221,7 +221,7 @@
=> let
in
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = SOME (x86.Entry.jump {label = label}),
statements = [],
transfer = NONE})
@@ -238,7 +238,7 @@
| NONE => args)
in
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = SOME (x86.Entry.func {label = label,
live = args}),
statements = [],
@@ -258,7 +258,7 @@
| NONE => args)
in
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = SOME (x86.Entry.cont {label = label,
live = args,
frameInfo = frameInfo}),
@@ -269,7 +269,7 @@
=> let
in
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = SOME (x86.Entry.handler
{frameInfo = frameInfoToX86 frameInfo,
label = label,
@@ -300,14 +300,14 @@
val comment = (Layout.toString o layout) statement
in
(AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [x86.Assembly.comment
(concat ["begin: ",
comment])],
transfer = NONE}),
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [x86.Assembly.comment
(concat ["end: ",
@@ -340,7 +340,7 @@
AppendList.appends
[comment_begin,
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements
= [(* dst = src *)
@@ -372,17 +372,9 @@
comment_end]
end
| ProfileLabel l =>
- let
- val label =
- Label.fromString (Machine.ProfileLabel.toString l)
- in
- AppendList.single
- (x86.Block.T'
- {entry = NONE,
- statements = [x86.Assembly.pseudoop_global label,
- x86.Assembly.label label],
- transfer = NONE})
- end
+ AppendList.single
+ (x86.Block.mkProfileBlock'
+ {profileLabel = l})
| SetSlotExnStack {offset}
=> let
val (comment_begin, comment_end) = comments statement
@@ -408,7 +400,7 @@
AppendList.appends
[comment_begin,
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements =
[(* *(stackTop + offset) = exnStack *)
@@ -432,7 +424,7 @@
AppendList.appends
[comment_begin,
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements
= [(* exnStack = (stackTop + offset) - stackBottom *)
@@ -479,7 +471,7 @@
AppendList.appends
[comment_begin,
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements
= [(* exnStack = *(stackTop + offset) *)
@@ -552,7 +544,7 @@
AppendList.appends
[comment_begin,
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements
= ((* *(frontier) = header *)
@@ -587,7 +579,7 @@
fun goto l
= AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [],
transfer = SOME (x86.Transfer.goto
@@ -600,7 +592,7 @@
in
if Label.equals(a, b)
then AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [],
transfer = SOME (x86.Transfer.goto {target = a})})
@@ -608,7 +600,7 @@
((* if (test) goto a
* goto b
*)
- x86.Block.T'
+ x86.Block.mkBlock'
{entry = NONE,
statements
= [x86.Assembly.instruction_test
@@ -629,7 +621,7 @@
in
if Label.equals(a, b)
then AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [],
transfer = SOME (x86.Transfer.goto {target = a})})
@@ -637,7 +629,7 @@
((* if (test = k) goto a
* goto b
*)
- x86.Block.T'
+ x86.Block.mkBlock'
{entry = NONE,
statements
= [x86.Assembly.instruction_cmp
@@ -656,7 +648,7 @@
val test = Operand.toX86Operand test
in
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [],
transfer = SOME (x86.Transfer.switch
@@ -722,7 +714,7 @@
val comment = (Layout.toString o layout) transfer
in
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [x86.Assembly.comment comment],
transfer = NONE})
@@ -764,7 +756,7 @@
=> AppendList.append
(comments transfer,
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [],
transfer
@@ -784,7 +776,7 @@
=> AppendList.append
(comments transfer,
AppendList.single
- (x86.Block.T'
+ (x86.Block.mkBlock'
{entry = NONE,
statements = [],
transfer
@@ -817,7 +809,7 @@
((* if (test & 0x3) goto int
* goto pointer
*)
- x86.Block.T'
+ x86.Block.mkBlock'
{entry = NONE,
statements
= [x86.Assembly.instruction_test
@@ -845,7 +837,7 @@
(comments transfer,
AppendList.single
((* goto label *)
- x86.Block.T'
+ x86.Block.mkBlock'
{entry = NONE,
statements = [],
transfer = SOME (x86.Transfer.goto {target = label})})))
@@ -874,7 +866,7 @@
AppendList.append
(com,
AppendList.single
- (x86.Block.T' {entry = NONE,
+ (x86.Block.mkBlock' {entry = NONE,
statements = [],
transfer = SOME transfer}))
end)
@@ -902,7 +894,7 @@
(Entry.toX86Blocks {label = label,
kind = kind,
transInfo = transInfo},
- x86.Block.T'
+ x86.Block.mkBlock'
{entry = NONE,
statements
= if !Control.Native.commented > 0
@@ -928,23 +920,8 @@
transInfo = transInfo}, l)))
val pseudo_blocks = AppendList.toList pseudo_blocks
-
- val blocks = x86.Block.compress pseudo_blocks
- val blocks
- = if !Control.profile = Control.ProfileNone
- then blocks
- else
- List.map
- (blocks,
- fn (x86.Block.T {entry, statements, transfer})
- => let
- val label = x86.Entry.label entry
- in
- x86.Block.T {entry = entry,
- statements = statements,
- transfer = transfer}
- end)
+ val blocks = x86.Block.compress pseudo_blocks
in
blocks
end
1.35 +69 -17 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- x86.fun 2 Jan 2003 17:45:19 -0000 1.34
+++ x86.fun 20 Jan 2003 16:28:38 -0000 1.35
@@ -3712,11 +3712,6 @@
| _ => false
end
- val addProfileLabel: (string * Label.t -> unit) ref =
- ref (fn _ => ())
-
- fun setAddProfileLabel x = addProfileLabel := x
-
structure Transfer =
struct
structure Cases =
@@ -4063,36 +4058,72 @@
val ccall = CCall
end
+ structure ProfileLabel =
+ struct
+ open ProfileLabel
+
+ fun toAssembly pl =
+ let
+ val label = Label.fromString (toString pl)
+ in
+ [Assembly.pseudoop_global label,
+ Assembly.label label]
+ end
+ fun toAssemblyOpt pl =
+ case pl of
+ NONE => []
+ | SOME pl => toAssembly pl
+ end
+
structure Block =
struct
datatype t' = T' of {entry: Entry.t option,
+ profileLabel: ProfileLabel.t option,
statements: Assembly.t list,
transfer: Transfer.t option}
+ fun mkBlock' {entry, statements, transfer} =
+ T' {entry = entry,
+ profileLabel = NONE,
+ statements = statements,
+ transfer = transfer}
+ fun mkProfileBlock' {profileLabel} =
+ T' {entry = NONE,
+ profileLabel = SOME profileLabel,
+ statements = [],
+ transfer = NONE}
+
datatype t = T of {entry: Entry.t,
+ profileLabel: ProfileLabel.t option,
statements: Assembly.t list,
transfer: Transfer.t}
- fun printBlock (T {entry, statements, transfer})
+ fun printBlock (T {entry, profileLabel, statements, transfer, ...})
= (print (Entry.toString entry);
print ":\n";
+ Option.app
+ (profileLabel, fn profileLabel =>
+ (print (ProfileLabel.toString profileLabel);
+ print ":\n"));
List.foreach
- (statements,
- fn asm
- => (print (Assembly.toString asm);
- print "\n"));
+ (statements, fn asm =>
+ (print (Assembly.toString asm);
+ print "\n"));
print (Transfer.toString transfer);
print "\n")
- fun print_block' (T' {entry, statements, transfer})
+ fun printBlock' (T' {entry, profileLabel, statements, transfer, ...})
= (print (if isSome entry
then Entry.toString (valOf entry)
else "---");
print ":\n";
+ Option.app
+ (profileLabel, fn profileLabel =>
+ (print (ProfileLabel.toString profileLabel);
+ print ":\n"));
List.foreach
- (statements,
- fn asm
- => (print (Assembly.toString asm);
- print "\n"));
+ (statements, fn asm =>
+ (print (Assembly.toString asm);
+ print "\n"));
print (if isSome transfer
then Transfer.toString (valOf transfer)
else "NONE");
@@ -4101,25 +4132,46 @@
val rec compress
= fn [] => []
| [T' {entry = SOME entry1,
+ profileLabel = profileLabel1,
statements = statements1,
transfer = SOME transfer1}]
=> [T {entry = entry1,
+ profileLabel = profileLabel1,
statements = statements1,
transfer = transfer1}]
| (T' {entry = SOME entry1,
+ profileLabel = profileLabel1,
statements = statements1,
transfer = SOME transfer1})::blocks
=> (T {entry = entry1,
+ profileLabel = profileLabel1,
statements = statements1,
transfer = transfer1})::(compress blocks)
| (T' {entry = SOME entry1,
+ profileLabel = NONE,
+ statements = [],
+ transfer = NONE})::
+ (T' {entry = NONE,
+ profileLabel = profileLabel2,
+ statements = statements2,
+ transfer = transfer2})::blocks
+ => compress ((T' {entry = SOME entry1,
+ profileLabel = profileLabel2,
+ statements = statements2,
+ transfer = transfer2})::blocks)
+ | (T' {entry = SOME entry1,
+ profileLabel = profileLabel1,
statements = statements1,
- transfer = NONE})::
+ transfer = NONE})::
(T' {entry = NONE,
+ profileLabel = profileLabel2,
statements = statements2,
transfer = transfer2})::blocks
=> compress ((T' {entry = SOME entry1,
- statements = statements1 @ statements2,
+ profileLabel = profileLabel1,
+ statements = statements1 @
+ (ProfileLabel.toAssemblyOpt profileLabel2) @
+ statements2,
transfer = transfer2})::blocks)
| _ => Error.bug "Blocks.compress"
end
1.25 +19 -4 mlton/mlton/codegen/x86-codegen/x86.sig
Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- x86.sig 2 Jan 2003 17:45:19 -0000 1.24
+++ x86.sig 20 Jan 2003 16:28:39 -0000 1.25
@@ -11,15 +11,15 @@
signature X86_STRUCTS =
sig
structure Label: HASH_ID
+ structure ProfileLabel: PROFILE_LABEL
structure Runtime: RUNTIME
end
signature X86 =
sig
- include X86_STRUCTS
+ structure Label: HASH_ID
+ structure Runtime: RUNTIME
- val setAddProfileLabel: (string * Label.t -> unit) -> unit
-
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
val tracerTop : string -> ('a -> 'b) ->
@@ -1163,16 +1163,31 @@
target: Label.t} -> t
end
+ structure ProfileLabel :
+ sig
+ include PROFILE_LABEL
+ val toAssembly : t -> Assembly.t list
+ val toAssemblyOpt : t option -> Assembly.t list
+ end
+
structure Block :
sig
datatype t' = T' of {entry: Entry.t option,
+ profileLabel: ProfileLabel.t option,
statements: Assembly.t list,
transfer: Transfer.t option}
+ val mkBlock': {entry: Entry.t option,
+ statements: Assembly.t list,
+ transfer: Transfer.t option} -> t'
+ val mkProfileBlock': {profileLabel: ProfileLabel.t} -> t'
+ val printBlock' : t' -> unit
+
datatype t = T of {entry: Entry.t,
+ profileLabel: ProfileLabel.t option,
statements: Assembly.t list,
transfer: Transfer.t}
-
val printBlock : t -> unit
+
val compress : t' list -> t list
end
1.46 +1 -0 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- compile.sml 3 Jan 2003 06:14:16 -0000 1.45
+++ compile.sml 20 Jan 2003 16:28:42 -0000 1.46
@@ -21,6 +21,7 @@
structure Ssa = Ssa (open Atoms)
structure Machine = Machine (structure Label = Ssa.Label
structure Prim = Atoms.Prim
+ structure ProfileLabel = Atoms.ProfileLabel
structure SourceInfo = Ssa.SourceInfo)
local
open Machine
-------------------------------------------------------
This SF.NET email is sponsored by: FREE SSL Guide from Thawte
are you planning your Web Server Security? Click here to get a FREE
Thawte SSL guide and find the answers to all your SSL security issues.
http://ads.sourceforge.net/cgi-bin/redirect.pl?thaw0026en
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel