[MLton-devel] cvs commit: profiling: elimination of currentSource
Stephen Weeks
sweeks@users.sourceforge.net
Wed, 22 Jan 2003 19:34:38 -0800
sweeks 03/01/22 19:34:38
Modified: include codegen.h
mlton/backend allocate-registers.fun backend.fun
c-function.fun c-function.sig limit-check.fun
machine.fun machine.sig profile.fun rssa.fun
rssa.sig runtime.fun runtime.sig ssa-to-rssa.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-generate-transfers.fun
x86-mlton-basic.fun x86-mlton-basic.sig
x86-translate.fun
mlton/core-ml lookup-constant.fun
mlton/main compile.sml
runtime gc.c gc.h
Log:
Profiling no longer uses gcState.currentSource (which I have
eliminated) to get the current source. Instead, it uses the top frame
on the ML stack. This necessitates creating a stack frame for all C
calls when compiling with profiling. GC_profile{Enter,Inc,Leave} also
use the top frame on the ML stack to know where they are.
In making this change, I had to tweak similar parts of
x86-generate-transfers.fun and c-codegen.fun. Just a thought: maybe
it would be better to move synchronization of gcState to the backend
and make it more explicit in the Machine IL (i.e. make FlushStackTop,
FlushFrontier and friends Machine IL statements)? This might
eliminate some duplication of knowledge of when to flush from all the
codegens.
Added a new field to frameLayouts to indicate whether the frame is
for calling a C function or an ML function. The time profiling signal
handler uses this to decide whether or not to look at the current PC.
Made GC_state more consistent in keeping sizes of all arrays.
Revision Changes Path
1.6 +4 -2 mlton/include/codegen.h
Index: codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/codegen.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- codegen.h 18 Jan 2003 19:01:10 -0000 1.5
+++ codegen.h 23 Jan 2003 03:34:36 -0000 1.6
@@ -3,11 +3,11 @@
#define BeginIntInfs static struct GC_intInfInit intInfInits[] = {
#define IntInf(g, n) { g, n },
-#define EndIntInfs { 0, NULL }};
+#define EndIntInfs };
#define BeginStrings static struct GC_stringInit stringInits[] = {
#define String(g, s, l) { g, s, l },
-#define EndStrings { 0, NULL, 0 }};
+#define EndStrings };
#define BeginReals static void real_Init() {
#define Real(c, f) globaldouble[c] = f;
@@ -46,6 +46,7 @@
gcState.globals = globalpointer; \
gcState.globalsSize = cardof(globalpointer); \
gcState.intInfInits = intInfInits; \
+ gcState.intInfInitsSize = cardof(intInfInits); \
gcState.loadGlobals = loadGlobals; \
gcState.magic = mg; \
gcState.maxFrameSize = mfs; \
@@ -63,6 +64,7 @@
gcState.sourceSeqsSize = cardof(sourceSeqs); \
gcState.sourceSuccessors = sourceSuccessors; \
gcState.stringInits = stringInits; \
+ gcState.stringInitsSize = cardof(stringInits); \
MLton_init (argc, argv, &gcState); \
#endif /* #ifndef _CODEGEN_H_ */
1.25 +7 -9 mlton/mlton/backend/allocate-registers.fun
Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- allocate-registers.fun 2 Jan 2003 17:45:10 -0000 1.24
+++ allocate-registers.fun 23 Jan 2003 03:34:36 -0000 1.25
@@ -370,16 +370,14 @@
let
val {begin, beginNoFormals, ...} = labelLive label
val _ =
- case kind of
- Kind.Cont _ =>
- (Vector.foreach (args, forceStack o #1)
- ; List.foreach (beginNoFormals, forceStack))
- | Kind.Handler =>
+ case Kind.frameStyle kind of
+ Kind.None => ()
+ | Kind.OffsetsAndSize =>
List.foreach (beginNoFormals, forceStack)
- | Kind.CReturn {func = CFunction.T {mayGC, ...}} =>
- if mayGC
- then List.foreach (beginNoFormals, forceStack)
- else ()
+ | Kind.SizeOnly => ()
+ val _ =
+ case kind of
+ Kind.Cont _ => Vector.foreach (args, forceStack o #1)
| _ => ()
val _ =
Vector.foreach
1.48 +64 -47 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- backend.fun 10 Jan 2003 18:36:08 -0000 1.47
+++ backend.fun 23 Jan 2003 03:34:36 -0000 1.48
@@ -163,11 +163,10 @@
suffix = "rssa",
thunk = fn () => Profile.profile program,
typeCheck = R.Program.typeCheck o #program}
- val profileStack =
- !Control.profile <> Control.ProfileNone
- andalso !Control.profileStack
+ val profile = !Control.profile <> Control.ProfileNone
+ val profileStack = profile andalso !Control.profileStack
val frameProfileIndex =
- if profileStack
+ if profile
then
let
val {get, set, ...} =
@@ -252,7 +251,8 @@
in
(frameLayouts, frameOffsets, frameSources)
end
- fun getFrameLayoutsIndex {label: Label.t,
+ fun getFrameLayoutsIndex {isC: bool,
+ label: Label.t,
offsets: int list,
size: int}: int =
let
@@ -263,9 +263,10 @@
val _ =
List.push (frameLayouts,
{frameOffsetsIndex = foi,
+ isC = isC,
size = size})
val _ =
- if profileStack
+ if profile
then List.push (frameSources, profileIndex)
else ()
in
@@ -282,22 +283,27 @@
#frameLayoutsIndex
(HashSet.lookupOrInsert
(table, Word.fromInt foi,
- fn {frameOffsetsIndex = foi',
+ fn {frameOffsetsIndex = foi', isC = isC',
profileIndex = pi', size = s', ...} =>
- foi = foi' andalso profileIndex = pi' andalso size = s',
+ foi = foi'
+ andalso isC = isC'
+ andalso profileIndex = pi'
+ andalso size = s',
fn () => {frameLayoutsIndex = new (),
frameOffsetsIndex = foi,
+ isC = isC,
profileIndex = profileIndex,
size = size}))
end
end
- val {get = frameInfo: Label.t -> M.FrameInfo.t,
+ val {get = frameInfo: Label.t -> M.FrameInfo.t option,
set = setFrameInfo, ...} =
Property.getSetOnce (Label.plist,
- Property.initRaise ("frameInfo", Label.layout))
+ Property.initConst NONE)
val setFrameInfo =
Trace.trace2 ("Backend.setFrameInfo",
- Label.layout, M.FrameInfo.layout, Unit.layout)
+ Label.layout, Option.layout M.FrameInfo.layout,
+ Unit.layout)
setFrameInfo
(* The global raise operands. *)
local
@@ -675,29 +681,44 @@
val _ =
Vector.foreach
(blocks, fn R.Block.T {kind, label, ...} =>
- if not (R.Kind.isFrame kind)
- then ()
- else
- let
- val {liveNoFormals, size, ...} = labelRegInfo label
- val offsets =
- Vector.fold
- (liveNoFormals, [], fn (oper, ac) =>
- case oper of
- M.Operand.StackOffset {offset, ty} =>
- if Type.isPointer ty
- then offset :: ac
- else ac
- | _ => ac)
- val frameLayoutsIndex =
- getFrameLayoutsIndex {label = label,
- offsets = offsets,
- size = size}
- in
- setFrameInfo (label,
- M.FrameInfo.T
- {frameLayoutsIndex = frameLayoutsIndex})
- end)
+ let
+ fun doit (useOffsets: bool): unit =
+ let
+ val {liveNoFormals, size, ...} = labelRegInfo label
+ val offsets =
+ if useOffsets
+ then
+ Vector.fold
+ (liveNoFormals, [], fn (oper, ac) =>
+ case oper of
+ M.Operand.StackOffset {offset, ty} =>
+ if Type.isPointer ty
+ then offset :: ac
+ else ac
+ | _ => ac)
+ else
+ []
+ val isC =
+ case kind of
+ R.Kind.CReturn _ => true
+ | _ => false
+ val frameLayoutsIndex =
+ getFrameLayoutsIndex {isC = isC,
+ label = label,
+ offsets = offsets,
+ size = size}
+ in
+ setFrameInfo
+ (label,
+ SOME (M.FrameInfo.T
+ {frameLayoutsIndex = frameLayoutsIndex}))
+ end
+ in
+ case R.Kind.frameStyle kind of
+ R.Kind.None => ()
+ | R.Kind.OffsetsAndSize => doit true
+ | R.Kind.SizeOnly => doit false
+ end)
(* ------------------------------------------------- *)
(* genTransfer *)
(* ------------------------------------------------- *)
@@ -720,10 +741,9 @@
| R.Transfer.CCall {args, func, return} =>
simple (M.Transfer.CCall
{args = translateOperands args,
- frameInfo = if CFunction.mayGC func
- then SOME (frameInfo
- (valOf return))
- else NONE,
+ frameInfo = (case return of
+ NONE => NONE
+ | SOME l => frameInfo l),
func = func,
return = return})
| R.Transfer.Call {func, args, return} =>
@@ -881,14 +901,14 @@
val srcs = callReturnOperands (args, #2, size)
in
(M.Kind.Cont {args = srcs,
- frameInfo = frameInfo label},
+ frameInfo = valOf (frameInfo label)},
liveNoFormals,
parallelMove
{chunk = chunk,
dsts = Vector.map (args, varOperand o #1),
srcs = srcs})
end
- | R.Kind.CReturn {func as CFunction.T {mayGC, ...}} =>
+ | R.Kind.CReturn {func, ...} =>
let
val dst =
case Vector.length args of
@@ -896,13 +916,9 @@
| 1 => SOME (varOperand
(#1 (Vector.sub (args, 0))))
| _ => Error.bug "strange CReturn"
- val frameInfo =
- if mayGC
- then SOME (frameInfo label)
- else NONE
in
(M.Kind.CReturn {dst = dst,
- frameInfo = frameInfo,
+ frameInfo = frameInfo label,
func = func},
liveNoFormals,
Vector.new0 ())
@@ -917,8 +933,9 @@
val handles =
raiseOperands (Vector.map (dsts, M.Operand.ty))
in
- (M.Kind.Handler {frameInfo = frameInfo label,
- handles = handles},
+ (M.Kind.Handler
+ {frameInfo = valOf (frameInfo label),
+ handles = handles},
liveNoFormals,
M.Statement.moves {dsts = dsts,
srcs = handles})
1.10 +14 -26 mlton/mlton/backend/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- c-function.fun 8 Jan 2003 15:19:16 -0000 1.9
+++ c-function.fun 23 Jan 2003 03:34:36 -0000 1.10
@@ -15,13 +15,11 @@
maySwitchThreads: bool,
modifiesFrontier: bool,
modifiesStackTop: bool,
- needsCurrentSource: bool,
name: string,
returnTy: Type.t option}
fun layout (T {bytesNeeded, ensuresBytesFree, mayGC, maySwitchThreads,
- modifiesFrontier, modifiesStackTop, name, needsCurrentSource,
- returnTy}) =
+ modifiesFrontier, modifiesStackTop, name, returnTy}) =
Layout.record
[("bytesNeeded", Option.layout Int.layout bytesNeeded),
("ensuresBytesFree", Bool.layout ensuresBytesFree),
@@ -30,7 +28,6 @@
("modifiesFrontier", Bool.layout modifiesFrontier),
("modifiesStackTop", Bool.layout modifiesStackTop),
("name", String.layout name),
- ("needsCurrentSource", Bool.layout needsCurrentSource),
("returnTy", Option.layout Type.layout returnTy)]
local
@@ -43,7 +40,6 @@
val modifiesFrontier = make #modifiesFrontier
val modifiesStackTop = make #modifiesStackTop
val name = make #name
- val needsCurrentSource = make #needsCurrentSource
val returnTy = make #returnTy
end
@@ -52,9 +48,10 @@
fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
modifiesStackTop, returnTy, ...}): bool =
(if maySwitchThreads
- then (case returnTy of
- NONE => true
- | SOME t => false)
+ then (mayGC
+ andalso (case returnTy of
+ NONE => true
+ | SOME t => false))
else true)
andalso
(if ensuresBytesFree orelse maySwitchThreads
@@ -79,7 +76,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_gc",
- needsCurrentSource = true,
returnTy = NONE}
val t = make true
val f = make false
@@ -95,28 +91,20 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = name,
- needsCurrentSource = false,
returnTy = returnTy}
val bug = vanilla {name = "MLton_bug",
returnTy = NONE}
-val profileEnter = vanilla {name = "GC_profileEnter",
- returnTy = NONE}
-
-val profileInc =
- T {bytesNeeded = NONE,
- ensuresBytesFree = false,
- mayGC = false,
- maySwitchThreads = false,
- modifiesFrontier = false,
- modifiesStackTop = false,
- name = "GC_profileInc",
- needsCurrentSource = true,
- returnTy = NONE}
-
-val profileLeave = vanilla {name = "GC_profileLeave",
- returnTy = NONE}
+local
+ fun make name =
+ vanilla {name = name,
+ returnTy = NONE}
+in
+ val profileEnter = make "GC_profileEnter"
+ val profileInc = make "GC_profileInc"
+ val profileLeave = make "GC_profileLeave"
+end
val size = vanilla {name = "MLton_size",
returnTy = SOME Type.int}
1.7 +0 -2 mlton/mlton/backend/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/c-function.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- c-function.sig 3 Jan 2003 06:14:15 -0000 1.6
+++ c-function.sig 23 Jan 2003 03:34:36 -0000 1.7
@@ -31,7 +31,6 @@
mayGC: bool,
maySwitchThreads: bool,
name: string,
- needsCurrentSource: bool,
returnTy: Type.t option}
val bug: t
@@ -45,7 +44,6 @@
val maySwitchThreads: t -> bool
val modifiesFrontier: t -> bool
val modifiesStackTop: t -> bool
- val needsCurrentSource: t -> bool
val name: t -> string
val profileEnter: t
val profileInc: t
1.35 +0 -1 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- limit-check.fun 3 Jan 2003 06:14:15 -0000 1.34
+++ limit-check.fun 23 Jan 2003 03:34:36 -0000 1.35
@@ -133,7 +133,6 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = "MLton_allocTooLarge",
- needsCurrentSource = false,
returnTy = NONE}
val _ =
newBlocks :=
1.42 +54 -33 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- machine.fun 20 Jan 2003 20:38:28 -0000 1.41
+++ machine.fun 23 Jan 2003 03:34:36 -0000 1.42
@@ -416,9 +416,12 @@
in
val frameLayoutsIndex = make #frameLayoutsIndex
end
-
+
fun layout (T {frameLayoutsIndex, ...}) =
Layout.record [("frameLayoutsIndex", Int.layout frameLayoutsIndex)]
+
+ fun equals (T {frameLayoutsIndex = i}, T {frameLayoutsIndex = i'}) =
+ i = i'
end
structure Transfer =
@@ -730,6 +733,7 @@
struct
datatype t = T of {chunks: Chunk.t list,
frameLayouts: {frameOffsetsIndex: int,
+ isC: bool,
size: int} vector,
frameOffsets: int vector vector,
handlesSignals: bool,
@@ -765,9 +769,10 @@
("frameOffsets",
Vector.layout (Vector.layout Int.layout) frameOffsets),
("frameLayouts",
- Vector.layout (fn {frameOffsetsIndex, size} =>
+ Vector.layout (fn {frameOffsetsIndex, isC, size} =>
record [("frameOffsetsIndex",
Int.layout frameOffsetsIndex),
+ ("isC", Bool.layout isC),
("size", Int.layout size)])
frameLayouts)])
; output (str "\nProfileInfo:")
@@ -850,7 +855,6 @@
("frameSources length",
fn () => (Vector.length frameSources
= (if !Control.profile <> Control.ProfileNone
- andalso !Control.profileStack
then Vector.length frameLayouts
else 0)),
fn () => ProfileInfo.layout profileInfo)
@@ -871,7 +875,7 @@
fun boolToUnitOpt b = if b then SOME () else NONE
val _ =
Vector.foreach
- (frameLayouts, fn {frameOffsetsIndex, size} =>
+ (frameLayouts, fn {frameOffsetsIndex, size, ...} =>
Err.check
("frameLayouts",
fn () => (0 <= frameOffsetsIndex
@@ -1042,30 +1046,39 @@
let
datatype z = datatype Kind.t
exception No
- fun frame (FrameInfo.T {frameLayoutsIndex}): bool =
+ fun frame (FrameInfo.T {frameLayoutsIndex},
+ useSlots: bool,
+ isC: bool): bool =
let
- val {frameOffsetsIndex, size} =
+ val {frameOffsetsIndex, isC = isC', ...} =
Vector.sub (frameLayouts, frameLayoutsIndex)
handle Subscript => raise No
- val Alloc.T zs = alloc
- val liveOffsets =
- List.fold
- (zs, [], fn (z, liveOffsets) =>
- case z of
- Operand.StackOffset {offset, ty} =>
- if Type.isPointer ty
- then offset :: liveOffsets
- else liveOffsets
- | _ => raise No)
- val liveOffsets =
- Vector.fromArray
- (QuickSort.sortArray
- (Array.fromList liveOffsets, op <=))
- val liveOffsets' =
- Vector.sub (frameOffsets, frameOffsetsIndex)
- handle Subscript => raise No
in
- liveOffsets = liveOffsets'
+ isC = isC'
+ andalso
+ (not useSlots
+ orelse
+ let
+ val Alloc.T zs = alloc
+ val liveOffsets =
+ List.fold
+ (zs, [], fn (z, liveOffsets) =>
+ case z of
+ Operand.StackOffset {offset, ty} =>
+ if Type.isPointer ty
+ then offset :: liveOffsets
+ else liveOffsets
+ | _ => raise No)
+ val liveOffsets =
+ Vector.fromArray
+ (QuickSort.sortArray
+ (Array.fromList liveOffsets, op <=))
+ val liveOffsets' =
+ Vector.sub (frameOffsets, frameOffsetsIndex)
+ handle Subscript => raise No
+ in
+ liveOffsets = liveOffsets'
+ end)
end handle No => false
fun slotsAreInFrame (fi: FrameInfo.t): bool =
let
@@ -1081,24 +1094,30 @@
in
case k of
Cont {args, frameInfo} =>
- if frame frameInfo
+ if frame (frameInfo, true, false)
andalso slotsAreInFrame frameInfo
then SOME (Vector.fold
(args, alloc, fn (z, alloc) =>
Alloc.define (alloc, z)))
else NONE
- | CReturn {dst, frameInfo, ...} =>
- if (case frameInfo of
- NONE => true
- | SOME fi => (frame fi
- andalso slotsAreInFrame fi))
+ | CReturn {dst, frameInfo, func, ...} =>
+ if (if CFunction.mayGC func
+ then (case frameInfo of
+ NONE => false
+ | SOME fi => (frame (fi, true, true)
+ andalso slotsAreInFrame fi))
+ else if !Control.profile = Control.ProfileNone
+ then true
+ else (case frameInfo of
+ NONE => false
+ | SOME fi => frame (fi, false, true)))
then SOME (case dst of
NONE => alloc
| SOME z => Alloc.define (alloc, z))
else NONE
| Func => SOME alloc
| Handler {frameInfo, ...} =>
- if frame frameInfo
+ if frame (frameInfo, false, false)
then SOME alloc
else NONE
| Jump => SOME alloc
@@ -1345,7 +1364,7 @@
andalso jump (overflow, alloc)
andalso jump (success, alloc)
end
- | CCall {args, frameInfo, func, return} =>
+ | CCall {args, frameInfo = fi, func, return} =>
let
val _ = checkOperands (args, alloc)
in
@@ -1360,8 +1379,10 @@
andalso
case labelKind l of
Kind.CReturn
- {dst, func = f, ...} =>
+ {dst, frameInfo = fi', func = f, ...} =>
CFunction.equals (func, f)
+ andalso (Option.equals
+ (fi, fi', FrameInfo.equals))
andalso
(case (dst, CFunction.returnTy f) of
(NONE, _) => true
1.32 +2 -0 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- machine.sig 20 Jan 2003 20:38:29 -0000 1.31
+++ machine.sig 23 Jan 2003 03:34:36 -0000 1.32
@@ -127,6 +127,7 @@
sig
datatype t = T of {frameLayoutsIndex: int}
+ val equals: t * t -> bool
val layout: t -> Layout.t
end
@@ -234,6 +235,7 @@
datatype t =
T of {chunks: Chunk.t list,
frameLayouts: {frameOffsetsIndex: int,
+ isC: bool,
size: int} vector,
(* Each vector in frame Offsets specifies the offsets
* of live pointers in a stack frame. A vector is referred
1.21 +71 -116 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- profile.fun 14 Jan 2003 20:05:35 -0000 1.20
+++ profile.fun 23 Jan 2003 03:34:36 -0000 1.21
@@ -157,6 +157,13 @@
val unknownSourceSeq = sourceSeqIndex [sourceInfoIndex SourceInfo.unknown]
(* Ensure that [SourceInfo.gc] is index 1. *)
val gcSourceSeq = sourceSeqIndex [sourceInfoIndex SourceInfo.gc]
+ fun addFrameProfileIndex (label: Label.t,
+ index: int): unit =
+ List.push (frameProfileIndices, (label, index))
+ fun addFrameProfilePushes (label: Label.t,
+ pushes: Push.t list): unit =
+ addFrameProfileIndex (label,
+ sourceSeqIndex (Push.toSources pushes))
val {get = labelInfo: Label.t -> {block: Block.t,
visited: bool ref},
set = setLabelInfo, ...} =
@@ -284,40 +291,25 @@
val blocks = ref []
datatype z = datatype Statement.t
datatype z = datatype ProfileExp.t
- fun setCurrentSource (n: int): Statement.t =
- Statement.Move
- {dst = Operand.Runtime Runtime.GCField.CurrentSource,
- src = Operand.word (Word.fromInt n)}
- val setCurrentSource =
- Trace.trace ("Profile.setCurrentSource",
- Int.layout, Statement.layout)
- setCurrentSource
- val clearCurrentSource = setCurrentSource ~1
fun backward {args,
kind,
label,
- needsCurrentSource,
sourceSeq: int list,
statements: Statement.t list,
transfer: Transfer.t}: unit =
let
- fun addCurrent (statements, sourceSeq) =
- setCurrentSource (sourceSeqIndex sourceSeq) :: statements
- val (ncs, npl, sourceSeq, statements) =
+ val (npl, sourceSeq, statements) =
List.fold
(statements,
- (needsCurrentSource, true, sourceSeq, []),
- fn (s, (ncs, npl, sourceSeq, ss)) =>
+ (true, sourceSeq, []),
+ fn (s, (npl, sourceSeq, ss)) =>
case s of
- Object _ => (true, true, sourceSeq, s :: ss)
+ Object _ => (true, sourceSeq, s :: ss)
| Profile ps =>
let
val (npl, ss) =
if profileAlloc
- then if ncs
- then (false,
- addCurrent (ss, sourceSeq))
- else (false, ss)
+ then (false, ss)
else (* profileTime *)
if npl andalso not (List.isEmpty sourceSeq)
then (false,
@@ -334,36 +326,13 @@
else Error.bug "mismatched Enter")
| Leave si => sourceInfoIndex si :: sourceSeq
in
- (false, npl, sourceSeq, ss)
+ (npl, sourceSeq, ss)
end
- | _ => (ncs, true, sourceSeq, s :: ss))
+ | _ => (true, sourceSeq, s :: ss))
val statements =
- if profileAlloc
- then
- if ncs
- then addCurrent (statements, sourceSeq)
- else statements
- else (* profileTime *)
- let
- fun pl () = profileLabel sourceSeq
- in
- if (case kind of
- Kind.Cont _ => profileStack
- | Kind.CReturn {func, ...} => true
- | Kind.Handler => profileStack
- | _ => false)
- then
- (case statements of
- (s as Statement.ProfileLabel _) :: ss =>
- s :: clearCurrentSource :: ss
- | _ =>
- pl ()
- :: clearCurrentSource
- :: statements)
- else if npl
- then pl () :: statements
- else statements
- end
+ if profileTime andalso npl
+ then profileLabel sourceSeq :: statements
+ else statements
val {args, kind, label} =
if profileStack andalso (case kind of
Kind.Cont _ => true
@@ -373,13 +342,15 @@
let
val func = CFunction.profileLeave
val newLabel = Label.newNoname ()
- val index = sourceSeqIndex sourceSeq
- val statements =
- [setCurrentSource index]
+ val _ =
+ addFrameProfileIndex
+ (newLabel, sourceSeqIndex sourceSeq)
val statements =
if profileTime
- then profileLabelIndex index :: statements
- else statements
+ then (Vector.new1
+ (profileLabelIndex
+ (sourceSeqIndex sourceSeq)))
+ else Vector.new0 ()
val _ =
List.push
(blocks,
@@ -387,7 +358,7 @@
{args = args,
kind = kind,
label = label,
- statements = Vector.fromList statements,
+ statements = statements,
transfer =
Transfer.CCall
{args = Vector.new1 Operand.GCState,
@@ -417,31 +388,29 @@
List.layout Statement.layout statements],
Unit.layout)
backward
- fun profileEnter (sourceSeq: int list,
- transfer: Transfer.t)
- : Statement.t * Transfer.t =
+ fun profileEnter (pushes: Push.t list,
+ transfer: Transfer.t): Transfer.t =
let
val func = CFunction.profileEnter
val newLabel = Label.newNoname ()
- val index = sourceSeqIndex sourceSeq
- val statements = [clearCurrentSource]
+ val index = sourceSeqIndex (Push.toSources pushes)
+ val _ = addFrameProfileIndex (newLabel, index)
val statements =
if profileTime
- then profileLabelIndex index :: statements
- else statements
+ then Vector.new1 (profileLabelIndex index)
+ else Vector.new0 ()
val _ =
List.push
(blocks,
Block.T {args = Vector.new0 (),
kind = Kind.CReturn {func = func},
label = newLabel,
- statements = Vector.fromList statements,
+ statements = statements,
transfer = transfer})
in
- (setCurrentSource index,
- Transfer.CCall {args = Vector.new1 Operand.GCState,
- func = func,
- return = SOME newLabel})
+ Transfer.CCall {args = Vector.new1 Operand.GCState,
+ func = func,
+ return = SOME newLabel}
end
fun goto (l: Label.t, pushes: Push.t list): unit =
let
@@ -478,12 +447,28 @@
| _ => false)
else statements
val _ =
- if profileStack andalso Kind.isFrame kind
- then List.push (frameProfileIndices,
- (label,
- sourceSeqIndex
- (Push.toSources pushes)))
- else ()
+ let
+ fun add pushes =
+ addFrameProfilePushes (label, pushes)
+ datatype z = datatype Kind.t
+ in
+ case kind of
+ Cont _ => add pushes
+ | CReturn {func, ...} =>
+ let
+ val name = CFunction.name func
+ val si =
+ case name of
+ "GC_gc" => SourceInfo.gc
+ | "GC_arrayAllocate" =>
+ SourceInfo.gcArrayAllocate
+ | _ => SourceInfo.fromC name
+ in
+ add (#1 (enter (pushes, si)))
+ end
+ | Handler => add pushes
+ | Jump => ()
+ end
fun maybeSplit {args, bytesAllocated, kind, label,
pushes: Push.t list,
statements} =
@@ -491,6 +476,8 @@
then
let
val newLabel = Label.newNoname ()
+ val _ =
+ addFrameProfilePushes (newLabel, pushes)
val func = CFunction.profileInc
val transfer =
Transfer.CCall
@@ -505,7 +492,6 @@
backward {args = args,
kind = kind,
label = label,
- needsCurrentSource = true,
sourceSeq = sourceSeq,
statements = statements,
transfer = transfer}
@@ -611,9 +597,6 @@
pushes = pushes,
statements = s :: statements})
)
- val _ =
- Transfer.foreachLabel
- (transfer, fn l => goto (l, pushes))
val {args, kind, label, statements, ...} =
maybeSplit {args = args,
bytesAllocated = bytesAllocated,
@@ -621,32 +604,12 @@
label = label,
pushes = pushes,
statements = statements}
- val sourceSeq = Push.toSources pushes
- val (statements, transfer) =
+ val _ =
+ Transfer.foreachLabel
+ (transfer, fn l => goto (l, pushes))
+ val transfer =
case transfer of
- Transfer.CCall {func, ...} =>
- if (profileAlloc
- andalso CFunction.needsCurrentSource func)
- orelse profileTime
- then
- let
- val name = CFunction.name func
- val si =
- case name of
- "GC_gc" => SourceInfo.gc
- | "GC_arrayAllocate" =>
- SourceInfo.gcArrayAllocate
- | _ => SourceInfo.fromC name
- val set =
- setCurrentSource
- (sourceSeqIndex
- (Push.toSources
- (#1 (enter (pushes, si)))))
- in
- (set :: statements, transfer)
- end
- else (statements, transfer)
- | Transfer.Call {func, return, ...} =>
+ Transfer.Call {func, return, ...} =>
let
val fi as FuncInfo.T {callers, ...} =
funcInfo func
@@ -661,29 +624,21 @@
| SOME n =>
List.push (callers, n)
in
- if profileStack
- then
- let
- val (s, t) =
- profileEnter
- (sourceSeq, transfer)
- in
- (s :: statements, t)
- end
- else
- (statements, transfer)
+ if profileStack
+ then profileEnter (pushes,
+ transfer)
+ else transfer
end
| _ =>
(List.push (tailCalls, fi)
- ; (statements, transfer))
+ ; transfer)
end
- | _ => (statements, transfer)
+ | _ => transfer
in
backward {args = args,
kind = kind,
label = label,
- needsCurrentSource = false,
- sourceSeq = sourceSeq,
+ sourceSeq = Push.toSources pushes,
statements = statements,
transfer = transfer}
end
1.29 +11 -5 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- rssa.fun 11 Jan 2003 00:34:39 -0000 1.28
+++ rssa.fun 23 Jan 2003 03:34:36 -0000 1.29
@@ -430,12 +430,18 @@
| Jump => str "Jump"
end
- fun isFrame (k: t): bool =
+ datatype frameStyle = None | OffsetsAndSize | SizeOnly
+ fun frameStyle (k: t): frameStyle =
case k of
- Cont _ => true
- | CReturn {func = CFunction.T {mayGC, ...}, ...} => mayGC
- | Handler => true
- | Jump => false
+ Cont _ => OffsetsAndSize
+ | CReturn {func, ...} =>
+ if CFunction.mayGC func
+ then OffsetsAndSize
+ else if !Control.profile = Control.ProfileNone
+ then None
+ else SizeOnly
+ | Handler => SizeOnly
+ | Jump => None
end
local
1.24 +2 -1 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- rssa.sig 11 Jan 2003 00:34:39 -0000 1.23
+++ rssa.sig 23 Jan 2003 03:34:36 -0000 1.24
@@ -168,7 +168,8 @@
| Handler
| Jump
- val isFrame: t -> bool
+ datatype frameStyle = None | OffsetsAndSize | SizeOnly
+ val frameStyle: t -> frameStyle
end
structure Block:
1.11 +1 -7 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- runtime.fun 3 Jan 2003 06:14:15 -0000 1.10
+++ runtime.fun 23 Jan 2003 03:34:36 -0000 1.11
@@ -18,7 +18,6 @@
datatype t =
CanHandle
| CardMap
- | CurrentSource
| CurrentThread
| ExnStack
| Frontier
@@ -35,7 +34,6 @@
val ty =
fn CanHandle => Type.int
| CardMap => Type.pointer
- | CurrentSource => Type.word
| CurrentThread => Type.pointer
| ExnStack => Type.word
| Frontier => Type.pointer
@@ -49,7 +47,6 @@
val canHandleOffset: int ref = ref 0
val cardMapOffset: int ref = ref 0
- val currentSourceOffset: int ref = ref 0
val currentThreadOffset: int ref = ref 0
val frontierOffset: int ref = ref 0
val limitOffset: int ref = ref 0
@@ -60,12 +57,11 @@
val stackLimitOffset: int ref = ref 0
val stackTopOffset: int ref = ref 0
- fun setOffsets {canHandle, cardMap, currentSource, currentThread, frontier,
+ fun setOffsets {canHandle, cardMap, currentThread, frontier,
limit, limitPlusSlop, maxFrameSize, signalIsPending,
stackBottom, stackLimit, stackTop} =
(canHandleOffset := canHandle
; cardMapOffset := cardMap
- ; currentSourceOffset := currentSource
; currentThreadOffset := currentThread
; frontierOffset := frontier
; limitOffset := limit
@@ -79,7 +75,6 @@
val offset =
fn CanHandle => !canHandleOffset
| CardMap => !cardMapOffset
- | CurrentSource => !currentSourceOffset
| CurrentThread => !currentThreadOffset
| ExnStack => Error.bug "exn stack offset not defined"
| Frontier => !frontierOffset
@@ -94,7 +89,6 @@
val toString =
fn CanHandle => "CanHandle"
| CardMap => "CardMap"
- | CurrentSource => "CurrentSource"
| CurrentThread => "CurrentThread"
| ExnStack => "ExnStack"
| Frontier => "Frontier"
1.20 +0 -2 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- runtime.sig 3 Jan 2003 06:14:15 -0000 1.19
+++ runtime.sig 23 Jan 2003 03:34:36 -0000 1.20
@@ -24,7 +24,6 @@
datatype t =
CanHandle
| CardMap
- | CurrentSource
| CurrentThread
| ExnStack
| Frontier (* The place where the next object is allocated. *)
@@ -41,7 +40,6 @@
val offset: t -> int (* Field offset in struct GC_state. *)
val setOffsets: {canHandle: int,
cardMap: int,
- currentSource: int,
currentThread: int,
frontier: int,
limit: int,
1.35 +0 -8 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- ssa-to-rssa.fun 11 Jan 2003 00:34:39 -0000 1.34
+++ ssa-to-rssa.fun 23 Jan 2003 03:34:36 -0000 1.35
@@ -49,7 +49,6 @@
modifiesFrontier = true,
modifiesStackTop = false,
name = name,
- needsCurrentSource = true,
returnTy = SOME Type.pointer}
in
val intInfAdd = make ("IntInf_do_add", 2)
@@ -84,7 +83,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyCurrentThread",
- needsCurrentSource = false,
returnTy = NONE}
val copyThread =
@@ -95,7 +93,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyThread",
- needsCurrentSource = false,
returnTy = SOME Type.pointer}
val exit =
@@ -106,7 +103,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "MLton_exit",
- needsCurrentSource = false,
returnTy = NONE}
val gcArrayAllocate =
@@ -117,7 +113,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_arrayAllocate",
- needsCurrentSource = true,
returnTy = SOME Type.pointer}
local
@@ -129,7 +124,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = name,
- needsCurrentSource = true,
returnTy = NONE}
in
val pack = make "GC_pack"
@@ -144,7 +138,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "Thread_switchTo",
- needsCurrentSource = false,
returnTy = NONE}
val worldSave =
@@ -155,7 +148,6 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_saveWorld",
- needsCurrentSource = false,
returnTy = NONE}
end
1.44 +25 -22 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- c-codegen.fun 18 Jan 2003 19:01:10 -0000 1.43
+++ c-codegen.fun 23 Jan 2003 03:34:37 -0000 1.44
@@ -109,7 +109,8 @@
fun bug (s: string, print) =
call ("MLton_bug", [concat ["\"", String.escapeC s, "\""]], print)
- fun push (i, print) = call ("\tPush", [int i], print)
+ fun push (i, print) =
+ call ("\tPush", [int i], print)
fun move ({dst, src}, print) =
print (concat [dst, " = ", src, ";\n"])
@@ -205,9 +206,10 @@
; print "};\n")
fun declareFrameLayouts () =
declareArray ("GC_frameLayout", "frameLayouts", frameLayouts,
- fn (_, {frameOffsetsIndex, size}) =>
+ fn (_, {frameOffsetsIndex, isC, size}) =>
concat ["{",
- C.int size,
+ C.bool isC,
+ ", ", C.int size,
", frameOffsets", C.int frameOffsetsIndex,
"}"])
fun declareObjectTypes () =
@@ -408,7 +410,6 @@
case r of
CanHandle => "gcState.canHandle"
| CardMap => "gcState.cardMapForMutator"
- | CurrentSource => "gcState.currentSource"
| CurrentThread => "gcState.currentThread"
| ExnStack => "ExnStack"
| Frontier => "frontier"
@@ -526,13 +527,17 @@
| Switch s => Switch.foreachLabel (s, jump)
end)
fun push (return: Label.t, size: int) =
- (C.push (size, print)
- ; print "\t"
+ (print "\t"
; C.move ({dst = operandToString
- (Operand.StackOffset {offset = ~Runtime.labelSize,
- ty = Type.label return}),
+ (Operand.StackOffset
+ {offset = size - Runtime.labelSize,
+ ty = Type.label return}),
src = operandToString (Operand.Label return)},
- print))
+ print)
+ ; C.push (size, print)
+ ; if !Control.profile <> Control.ProfileNone
+ then print "\tFlushStackTop();\n"
+ else ())
fun copyArgs (args: Operand.t vector): string list * (unit -> unit) =
if Vector.exists (args,
fn Operand.StackOffset _ => true
@@ -610,10 +615,10 @@
val _ =
case kind of
Kind.Cont {frameInfo, ...} => pop frameInfo
- | Kind.CReturn {dst, frameInfo, func, ...} =>
- (if CFunction.mayGC func
- then pop (valOf frameInfo)
- else ()
+ | Kind.CReturn {dst, frameInfo, ...} =>
+ (case frameInfo of
+ NONE => ()
+ | SOME fi => pop (valOf frameInfo)
; (Option.app
(dst, fn x =>
print (concat
@@ -707,8 +712,7 @@
end
| CCall {args,
frameInfo,
- func = CFunction.T {mayGC,
- maySwitchThreads,
+ func = CFunction.T {maySwitchThreads,
modifiesFrontier,
modifiesStackTop,
name,
@@ -717,20 +721,19 @@
return} =>
let
val (args, afterCall) =
- if mayGC
- then
+ case frameInfo of
+ NONE =>
+ (Vector.toListMap (args, operandToString),
+ fn () => ())
+ | SOME frameInfo =>
let
val size =
- Program.frameSize (program,
- valOf frameInfo)
+ Program.frameSize (program, frameInfo)
val res = copyArgs args
val _ = push (valOf return, size)
in
res
end
- else
- (Vector.toListMap (args, operandToString),
- fn () => ())
val _ =
if modifiesFrontier
then print "\tFlushFrontier();\n"
1.38 +17 -16 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.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- x86-generate-transfers.fun 20 Jan 2003 16:28:31 -0000 1.37
+++ x86-generate-transfers.fun 23 Jan 2003 03:34:37 -0000 1.38
@@ -508,9 +508,8 @@
=> near label
| CReturn {dst,
frameInfo,
- func = CFunction.T {mayGC,
- maySwitchThreads,
- name, ...},
+ func = CFunction.T {maySwitchThreads,
+ ...},
label}
=> let
fun getReturn ()
@@ -536,10 +535,11 @@
size = dstsize})
| _ => Error.bug "CReturn")
in
- if mayGC orelse maySwitchThreads
- then let
+ case frameInfo of
+ SOME fi =>
+ let
val FrameInfo.T {size, frameLayoutsIndex}
- = valOf frameInfo
+ = fi
val finish
= AppendList.appends
[let
@@ -596,7 +596,8 @@
weight = 1024}))})],
finish)]
end
- else AppendList.append (near label, getReturn ())
+ | NONE =>
+ AppendList.append (near label, getReturn ())
end
| Func {label,...}
=> AppendList.appends
@@ -1078,8 +1079,7 @@
end
| CCall {args, dstsize,
frameInfo,
- func = CFunction.T {mayGC,
- maySwitchThreads,
+ func = CFunction.T {maySwitchThreads,
modifiesFrontier,
modifiesStackTop,
name, ...},
@@ -1129,9 +1129,10 @@
size = size}),
assembly_args),
(Size.toBytes size) + size_args))
- val flush
- = if mayGC orelse maySwitchThreads
- then (* Entering runtime *)
+ val flush =
+ case frameInfo of
+ SOME (FrameInfo.T {size, ...}) =>
+ (* Entering runtime *)
let
val return = valOf return
val _ = enque return
@@ -1148,7 +1149,6 @@
= x86MLton.gcState_stackTopMinusWordDeref ()
val stackTopMinusWordDeref
= x86MLton.gcState_stackTopMinusWordDerefOperand ()
- val FrameInfo.T {size, ...} = valOf frameInfo
val bytes = x86.Operand.immediate_const_int size
val live =
@@ -1222,7 +1222,8 @@
dead_memlocs = MemLocSet.empty,
dead_classes = ClassSet.empty})))
end
- else AppendList.single
+ | NONE =>
+ AppendList.single
(Assembly.directive_force
{commit_memlocs = let
val s = MemLocSet.empty
@@ -1249,7 +1250,7 @@
{target = Operand.label target,
absolute = false}]
val kill
- = if mayGC orelse maySwitchThreads
+ = if isSome frameInfo
then AppendList.single
(Assembly.directive_force
{commit_memlocs = MemLocSet.empty,
@@ -1313,7 +1314,7 @@
absolute = true})))
else case return
of NONE => AppendList.empty
- | SOME l => (if mayGC
+ | SOME l => (if isSome frameInfo
then (* Don't need to trampoline,
* since didn't switch threads,
* but can't fall because
1.14 +0 -3 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- x86-mlton-basic.fun 20 Jan 2003 21:27:40 -0000 1.13
+++ x86-mlton-basic.fun 23 Jan 2003 03:34:37 -0000 1.14
@@ -355,9 +355,6 @@
val (_, _, gcState_cardMapContentsOperand) =
make (Field.CardMap, wordSize, Classes.GCState)
- val (_, _, gcState_currentSourceContentsOperand) =
- make (Field.CurrentSource, wordSize, Classes.GCStateVolatile)
-
val (gcState_currentThread, gcState_currentThreadContents,
gcState_currentThreadContentsOperand) =
make (Field.CurrentThread, pointerSize, Classes.GCState)
1.23 +0 -1 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.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- x86-mlton-basic.sig 20 Jan 2003 16:28:33 -0000 1.22
+++ x86-mlton-basic.sig 23 Jan 2003 03:34:37 -0000 1.23
@@ -105,7 +105,6 @@
(* gcState relative locations defined in gc.h *)
val gcState_canHandleContentsOperand: unit -> x86.Operand.t
val gcState_cardMapContentsOperand: unit -> x86.Operand.t
- val gcState_currentSourceContentsOperand: unit -> x86.Operand.t
val gcState_currentThreadContentsOperand: unit -> x86.Operand.t
val gcState_currentThread_exnStackContents: unit -> x86.MemLoc.t
val gcState_currentThread_exnStackContentsOperand: unit -> x86.Operand.t
1.39 +0 -1 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.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- x86-translate.fun 20 Jan 2003 16:28:37 -0000 1.38
+++ x86-translate.fun 23 Jan 2003 03:34:37 -0000 1.39
@@ -166,7 +166,6 @@
case oper of
CanHandle => gcState_canHandleContentsOperand ()
| CardMap => gcState_cardMapContentsOperand ()
- | CurrentSource => gcState_currentSourceContentsOperand ()
| CurrentThread => gcState_currentThreadContentsOperand ()
| ExnStack =>
gcState_currentThread_exnStackContentsOperand ()
1.19 +0 -1 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.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- lookup-constant.fun 13 Jan 2003 01:14:27 -0000 1.18
+++ lookup-constant.fun 23 Jan 2003 03:34:37 -0000 1.19
@@ -122,7 +122,6 @@
val gcFields =
[
"canHandle",
- "currentSource",
"currentThread",
"frontier",
"cardMapForMutator",
1.48 +0 -1 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- compile.sml 20 Jan 2003 20:38:31 -0000 1.47
+++ compile.sml 23 Jan 2003 03:34:38 -0000 1.48
@@ -374,7 +374,6 @@
{
canHandle = get "canHandle",
cardMap = get "cardMapForMutator",
- currentSource = get "currentSource",
currentThread = get "currentThread",
frontier = get "frontier",
limit = get "limit",
1.121 +135 -79 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.120
retrieving revision 1.121
diff -u -r1.120 -r1.121
--- gc.c 18 Jan 2003 19:01:11 -0000 1.120
+++ gc.c 23 Jan 2003 03:34:38 -0000 1.121
@@ -592,14 +592,42 @@
return 0 == stack->used;
}
+static inline uint getFrameIndex (GC_state s, word returnAddress) {
+ uint res;
+
+ if (s->native) {
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "getFrameIndex (0x%08x) = ",
+ returnAddress);
+ res = *((uint*)(returnAddress - WORD_SIZE));
+ } else {
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "getFrameIndex (%u) = ", returnAddress);
+ res = (uint)returnAddress;
+ }
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "%u\n", res);
+ return res;
+}
+
+static inline uint topFrameIndex (GC_state s) {
+ uint res;
+
+ res = getFrameIndex (s, *(word*)(s->stackTop - WORD_SIZE));
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "topFrameIndex = %u\n", res);
+ return res;
+}
+
+static inline uint topFrameSourceSeqIndex (GC_state s) {
+ return s->frameSources[topFrameIndex (s)];
+}
+
static inline GC_frameLayout * getFrameLayout (GC_state s, word returnAddress) {
GC_frameLayout *layout;
uint index;
- if (s->native)
- index = *((uint*)(returnAddress - WORD_SIZE));
- else
- index = (uint)returnAddress;
+ index = getFrameIndex (s, returnAddress);
if (DEBUG_DETAILED)
fprintf (stderr, "returnAddress = 0x%08x index = %d frameLayoutsSize = %d\n",
returnAddress, index, s->frameLayoutsSize);
@@ -2461,17 +2489,15 @@
bool forceMajor,
bool mayResize) {
uint gcTime;
- uint oldSource = -1;
bool stackTopOk;
W64 stackBytesRequested;
struct rusage ru_start;
W64 totalBytesRequested;
if (s->profilingIsOn) {
- oldSource = s->currentSource;
if (s->profileStack)
GC_profileEnter (s);
- s->currentSource = SOURCE_SEQ_GC;
+ s->amInGC = TRUE;
}
if (DEBUG or s->messages)
fprintf (stderr, "Starting gc. Request %s nursery bytes and %s old gen bytes.\n",
@@ -2514,9 +2540,9 @@
assert (hasBytesFree (s, oldGenBytesRequested, nurseryBytesRequested));
assert (invariant (s));
if (s->profilingIsOn) {
- s->currentSource = oldSource;
if (s->profileStack)
GC_profileLeave (s);
+ s->amInGC = FALSE;
}
}
@@ -2793,12 +2819,7 @@
/* Profiling */
/* ---------------------------------------------------------------- */
-static void enterFrame (GC_state s, uint i) {
- s->currentSource = s->frameSources[i];
- GC_profileEnter (s);
- s->currentSource = CURRENT_SOURCE_UNDEFINED;
-}
-
+/* Apply f to the frame index of each frame in the current thread's stack. */
void GC_foreachStackFrame (GC_state s, void (*f) (GC_state s, uint i)) {
pointer bottom;
word index;
@@ -2815,7 +2836,7 @@
(uint)bottom, (uint)s->stackTop);
for (top = s->stackTop; top > bottom; top -= layout->numBytes) {
returnAddress = *(word*)(top - WORD_SIZE);
- index = *(word*)(returnAddress - WORD_SIZE);
+ index = getFrameIndex (s, returnAddress);
if (DEBUG_PROFILE)
fprintf (stderr, "top = 0x%08x index = %u\n",
(uint)top, index);
@@ -2831,9 +2852,13 @@
}
static inline void removeFromStack (GC_state s, GC_profile p, uint i) {
+ ullong totalInc;
+
+ totalInc = p->total - p->lastTotal[i];
if (DEBUG_PROFILE)
- fprintf (stderr, "removing %s from stack\n", s->sources[i]);
- p->countStack[i] += p->total - p->lastTotal[i];
+ fprintf (stderr, "removing %s from stack totalInc = %llu\n",
+ s->sources[i], totalInc);
+ p->countStack[i] += totalInc;
p->countStackGC[i] += p->totalGC - p->lastTotalGC[i];
}
@@ -2872,19 +2897,18 @@
}
}
-void GC_profileEnter (GC_state s) {
+static void profileEnter (GC_state s, uint sourceSeqIndex) {
int i;
GC_profile p;
uint sourceIndex;
uint *sourceSeq;
if (DEBUG_PROFILE)
- fprintf (stderr, "GC_profileEnter currentSource = %u\n",
- (uint)s->currentSource);
+ fprintf (stderr, "profileEnter (%u)\n", sourceSeqIndex);
assert (s->profileStack);
- assert (s->currentSource < s->sourceSeqsSize);
+ assert (sourceSeqIndex < s->sourceSeqsSize);
p = s->profile;
- sourceSeq = s->sourceSeqs[s->currentSource];
+ sourceSeq = s->sourceSeqs[sourceSeqIndex];
for (i = 1; i <= sourceSeq[0]; ++i) {
sourceIndex = sourceSeq[i];
if (DEBUG_PROFILE)
@@ -2898,53 +2922,22 @@
}
}
-/* Pre: s->currentSource is set. */
-void GC_profileInc (GC_state s, W32 amount) {
- uint source;
- uint *sourceSeq;
-
- if (DEBUG_PROFILE)
- fprintf (stderr, "GC_profileInc (%u) currentSource = %u\n",
- (uint)amount,
- s->currentSource);
- assert (s->currentSource < s->sourceSeqsSize);
- sourceSeq = s->sourceSeqs[s->currentSource];
- source = sourceSeq[0] > 0
- ? sourceSeq[sourceSeq[0]]
- : SOURCES_INDEX_UNKNOWN;
- if (DEBUG_PROFILE)
- fprintf (stderr, "bumping %s by %u\n",
- s->sources[source], (uint)amount);
- s->profile->countTop[source] += amount;
- if (s->profileStack)
- GC_profileEnter (s);
- if (SOURCES_INDEX_GC == source)
- s->profile->totalGC += amount;
- else
- s->profile->total += amount;
- if (s->profileStack)
- GC_profileLeave (s);
-}
-
-/* s->currentSource must be set. */
-void GC_profileAllocInc (GC_state s, W32 amount) {
- if (s->profilingIsOn and (PROFILE_ALLOC == s->profileKind))
- GC_profileInc (s, amount);
+static void enterFrame (GC_state s, uint i) {
+ profileEnter (s, s->frameSources[i]);
}
-void GC_profileLeave (GC_state s) {
+static void profileLeave (GC_state s, uint sourceSeqIndex) {
int i;
GC_profile p;
uint sourceIndex;
uint *sourceSeq;
if (DEBUG_PROFILE)
- fprintf (stderr, "GC_profileLeave currentSource = %u\n",
- s->currentSource);
+ fprintf (stderr, "profileLeave (%u)\n", sourceSeqIndex);
assert (s->profileStack);
- assert (s->currentSource < s->sourceSeqsSize);
+ assert (sourceSeqIndex < s->sourceSeqsSize);
p = s->profile;
- sourceSeq = s->sourceSeqs[s->currentSource];
+ sourceSeq = s->sourceSeqs[sourceSeqIndex];
for (i = sourceSeq[0]; i > 0; --i) {
sourceIndex = sourceSeq[i];
if (DEBUG_PROFILE)
@@ -2957,6 +2950,62 @@
}
}
+static inline void profileInc (GC_state s, W32 amount, uint sourceSeqIndex) {
+ uint *sourceSeq;
+ uint topSourceIndex;
+
+ assert (not s->amInGC);
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "profileInc (%u, %u)\n",
+ (uint)amount, sourceSeqIndex);
+ assert (sourceSeqIndex < s->sourceSeqsSize);
+ sourceSeq = s->sourceSeqs[sourceSeqIndex];
+ topSourceIndex = sourceSeq[0] > 0
+ ? sourceSeq[sourceSeq[0]]
+ : SOURCES_INDEX_UNKNOWN;
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "bumping %s by %u\n",
+ s->sources[topSourceIndex], (uint)amount);
+ s->profile->countTop[topSourceIndex] += amount;
+ if (s->profileStack)
+ profileEnter (s, sourceSeqIndex);
+ if (SOURCES_INDEX_GC == topSourceIndex)
+ s->profile->totalGC += amount;
+ else
+ s->profile->total += amount;
+ if (s->profileStack)
+ profileLeave (s, sourceSeqIndex);
+}
+
+void GC_profileEnter (GC_state s) {
+ profileEnter (s, topFrameSourceSeqIndex (s));
+}
+
+void GC_profileLeave (GC_state s) {
+ profileLeave (s, topFrameSourceSeqIndex (s));
+}
+
+void GC_profileInc (GC_state s, W32 amount) {
+ assert (not s->amInGC);
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "GC_profileInc (%u)\n", (uint)amount);
+ profileInc (s, amount, topFrameSourceSeqIndex (s));
+}
+
+void GC_profileAllocInc (GC_state s, W32 amount) {
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "GC_profileAllocInc (%u)\n", (uint)amount);
+ if (s->profilingIsOn and (PROFILE_ALLOC == s->profileKind)) {
+ if (s->amInGC) {
+ if (DEBUG_PROFILE)
+ fprintf (stderr, "amInGC\n");
+ s->profile->totalGC += amount;
+ return;
+ }
+ GC_profileInc (s, amount);
+ }
+}
+
static void showProf (GC_state s) {
int i;
int j;
@@ -3066,9 +3115,10 @@
* Called on each SIGPROF interrupt.
*/
static void catcher (int sig, siginfo_t *sip, ucontext_t *ucp) {
- GC_state s;
+ uint frameIndex;
pointer pc;
- bool undef;
+ GC_state s;
+ uint sourceSeqIndex;
s = catcherState;
#if (defined (__linux__))
@@ -3079,21 +3129,24 @@
#error pc not defined
#endif
if (DEBUG_PROFILE)
- fprintf (stderr, "pc = 0x%08x\n", (uint)pc);
- if (CURRENT_SOURCE_UNDEFINED == s->currentSource) {
- undef = TRUE;
+ fprintf (stderr, "catcher pc = 0x%08x\n", (uint)pc);
+ if (s->amInGC) {
+ s->profile->totalGC++;
+ return;
+ }
+ frameIndex = topFrameIndex (s);
+ if (s->frameLayouts[frameIndex].isC) {
+ sourceSeqIndex = s->frameSources[frameIndex];
+ } else {
if (s->textStart <= pc and pc < s->textEnd) {
- s->currentSource = s->textSources [pc - s->textStart];
+ sourceSeqIndex = s->textSources [pc - s->textStart];
} else {
if (DEBUG_PROFILE)
fprintf (stderr, "pc out of bounds\n");
- s->currentSource = SOURCE_SEQ_UNKNOWN;
+ sourceSeqIndex = SOURCE_SEQ_UNKNOWN;
}
- } else
- undef = FALSE;
- GC_profileInc (s, 1);
- if (undef)
- s->currentSource = CURRENT_SOURCE_UNDEFINED;
+ }
+ profileInc (s, 1, sourceSeqIndex);
}
/* To get the beginning and end of the text segment. */
@@ -3116,7 +3169,6 @@
uint sourceSeqsIndex;
s->profile = GC_profileNew (s);
- s->currentSource = CURRENT_SOURCE_UNDEFINED;
/* Sort sourceLabels by address. */
qsort (s->sourceLabels, s->sourceLabelsSize, sizeof(*s->sourceLabels),
compareProfileLabels);
@@ -3382,7 +3434,7 @@
int numElements;
s->bytesLive = 0;
- for (i = 0; s->intInfInits[i].mlstr != NULL; ++i) {
+ for (i = 0; i < s->intInfInitsSize; ++i) {
numElements = strlen (s->intInfInits[i].mlstr);
s->bytesLive +=
GC_ARRAY_HEADER_SIZE + WORD_SIZE // for the sign
@@ -3390,7 +3442,7 @@
? POINTER_SIZE
: wordAlign (numElements));
}
- for (i = 0; s->stringInits[i].str != NULL; ++i) {
+ for (i = 0; i < s->stringInitsSize; ++i) {
numElements = s->stringInits[i].size;
s->bytesLive +=
GC_ARRAY_HEADER_SIZE
@@ -3415,15 +3467,17 @@
uint slen,
llen,
alen,
- i;
+ i,
+ index;
bool neg,
hex;
bignum *bp;
char *cp;
- inits = s->intInfInits;
frontier = s->frontier;
- for (; (str = inits->mlstr) != NULL; ++inits) {
+ for (index = 0; index < s->intInfInitsSize; ++index) {
+ inits = &s->intInfInits[index];
+ str = inits->mlstr;
assert (inits->globalIndex < s->globalsSize);
neg = *str == '~';
if (neg)
@@ -3494,7 +3548,7 @@
inits = s->stringInits;
frontier = s->frontier;
- for (i = 0; inits[i].str != NULL; ++i) {
+ for (i = 0; i < s->stringInitsSize; ++i) {
uint numElements, numBytes;
numElements = inits[i].size;
@@ -3592,6 +3646,7 @@
char *worldFile;
int i;
+ s->amInGC = TRUE;
s->bytesAllocated = 0;
s->bytesCopied = 0;
s->bytesCopiedMinor = 0;
@@ -3600,7 +3655,6 @@
s->cardSize = 0x1 << s->cardSizeLog2;
s->copyRatio = 4.0;
s->copyGenerationalRatio = 4.0;
- s->currentSource = SOURCE_SEQ_GC;
s->currentThread = BOGUS_THREAD;
s->growRatio = 8.0;
s->inSignalHandler = FALSE;
@@ -3648,6 +3702,7 @@
/* Initialize profiling. */
if (s->sourcesSize > 0) {
s->profilingIsOn = TRUE;
+ assert (s->frameSourcesSize == s->frameLayoutsSize);
if (s->sourceLabelsSize > 0) {
s->profileKind = PROFILE_TIME;
profileTimeInit (s);
@@ -3780,6 +3835,7 @@
GC_foreachStackFrame (s, enterFrame);
}
assert (mutatorInvariant (s));
+ s->amInGC = FALSE;
return i;
}
1.56 +8 -10 mlton/runtime/gc.h
Index: gc.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.h,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- gc.h 18 Jan 2003 19:01:12 -0000 1.55
+++ gc.h 23 Jan 2003 03:34:38 -0000 1.56
@@ -109,9 +109,8 @@
/*
* GC_init uses the array of struct intInfInits in s at program start to
* allocate intInfs.
- * The array is terminated by an intInfInit with mlstr field NULL.
- * For each other entry, the globalIndex'th entry of the globals array in
- * s is set to the IntInf.int whose value corresponds to the mlstr string.
+ * The globalIndex'th entry of the globals array in s is set to the
+ * IntInf.int whose value corresponds to the mlstr string.
*
* The strings pointed to by the mlstr fields consist of
* an optional ~
@@ -138,6 +137,9 @@
typedef ushort *GC_offsets;
typedef struct GC_frameLayout {
+ /* isC is a boolean identifying whether or not the frame is for a C call.
+ */
+ char isC;
/* Number of bytes in frame, including space for return address. */
ushort numBytes;
/* Offsets from stackTop pointing at bottom of frame at which pointers
@@ -290,6 +292,7 @@
pointer stackTop;
pointer stackLimit; /* stackBottom + stackSize - maxFrameSize */
+ bool amInGC;
pointer back; /* Points at next available word in toSpace. */
ullong bytesAllocated;
ullong bytesCopied;
@@ -310,10 +313,6 @@
GC_heap crossMapHeap; /* only used during GC. */
pointer crossMap;
uint crossMapSize;
- /* currentSource is the index in sources of the currently executing
- * function.
- */
- uint currentSource;
GC_thread currentThread; /* This points to a thread in the heap. */
uint fixedHeapSize; /* Only meaningful if useFixedHeap. */
GC_frameLayout *frameLayouts;
@@ -334,6 +333,7 @@
* thread. This is used to implement critical sections.
*/
struct GC_intInfInit *intInfInits;
+ uint intInfInitsSize;
volatile int canHandle;
bool isOriginal;
pointer limitPlusSlop; /* limit + LIMIT_SLOP */
@@ -432,10 +432,8 @@
uint *sourceSuccessors;
pointer stackBottom; /* The bottom of the stack in the current thread. */
uint startTime; /* The time when GC_init or GC_loadWorld was called. */
- /* The inits array should be NULL terminated,
- * i.e.the final element should be {0, NULL, 0}.
- */
struct GC_stringInit *stringInits;
+ uint stringInitsSize;
/* If summary is TRUE, then print a summary of gc info when the program
* is done .
*/
-------------------------------------------------------
This SF.net email is sponsored by: Scholarships for Techies!
Can't afford IT training? All 2003 ictp students receive scholarships.
Get hands-on training in Microsoft, Cisco, Sun, Linux/UNIX, and more.
www.ictp.com/training/sourceforge.asp
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel