[MLton-devel] cvs commit: source-level profiling
Stephen Weeks
sweeks@users.sourceforge.net
Fri, 10 Jan 2003 10:36:16 -0800
sweeks 03/01/10 10:36:16
Modified: mlton mlton-stubs-1997.cm mlton-stubs.cm mlton.cm
mlton/atoms atoms.fun atoms.sig sources.cm
mlton/backend backend.fun implement-handlers.fun rssa.fun
mlton/closure-convert closure-convert.fun globalize.fun
lambda-free.fun
mlton/control control.sig control.sml
mlton/main main.sml
mlton/ssa analyze.fun direct-exp.fun direct-exp.sig
flat-lattice.fun flat-lattice.sig flatten.fun
shrink.fun sources.cm ssa-tree.fun ssa-tree.sig
type-check.fun
mlton/type-inference infer.fun
mlton/xml implement-exceptions.fun monomorphise.fun
polyvariance.fun scc-funs.fun simplify.fun
sources.cm type-check.fun xml-tree.fun xml-tree.sig
Added: mlton/atoms profile-exp.fun profile-exp.sig source-info.fun
source-info.sig
Removed: mlton/ssa profile-exp.sig source-info.fun source-info.sig
Log:
Moved insertion of Profile Enter/Leave statements to the Xml right
after type inference. This should eliminate any problems with missed
information due to (S)Xml inlining. Added flag: -profile-il
{xml|ssa}. This controls where the Enter/Leaves are inserted. For
now, -profile-il ssa behaves like profiling used to before this
checkin -- i.e., it inserts source level profiling information in each
SSA function just before the SSA simplifier pipeline. Very soon, once
I am completely convinced that -profile-il xml is working, I
anticipate changing the meaning of -profile-il ssa so that it instead
insterts Enter/Leaves for each SSA function and basic block at the end
of the SSA pipeline, *not* based on source information. This should
allow us to get old-style SSA based profiling information like we had
before source-level profiling that is often more useful for trying to
improve the optimizer.
Added optimization to SSA shrinker to turn a nontail call where the
cont and handler only do profile statements into a tail call where the
profile statements precede the tail call. This optimization is
necessary to undo stuff introduced by -profile xml, which turns all
tail calls into nontail calls because it wraps a handler around them.
After encountering yet more annoyances with HandlerPush/Pop while
working on this, I decided to go ahead and put in a couple of simple
strategies for implementing handlers that do not require
HandlerPush/Pop.
Added flag: -handlers {flow|pushpop|simple}
-handlers pushpop
the old way, using HandlerPush/Pop
-handlers simple
insert appropriate statements before each call, raise, and return
-handlers flow
like -handlers simple, but with some simple forward dataflow
analysis to eliminate redundant assignments
After benchmarks showed that using -flow was in the noise, I decided
to switch to that as the default. This means that we can eliminate
HandlerPush/Pop whenever we want.
Revision Changes Path
1.8 +18 -17 mlton/mlton/mlton-stubs-1997.cm
Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mlton-stubs-1997.cm 2 Jan 2003 17:45:09 -0000 1.7
+++ mlton-stubs-1997.cm 10 Jan 2003 18:36:03 -0000 1.8
@@ -231,8 +231,12 @@
atoms/type-ops.fun
atoms/type.fun
atoms/tycon.fun
+atoms/source-info.sig
+atoms/source-info.fun
atoms/generic-scheme.sig
atoms/scheme.sig
+atoms/profile-exp.sig
+atoms/profile-exp.fun
atoms/cons.sig
atoms/const.sig
atoms/prim.sig
@@ -244,8 +248,6 @@
atoms/atoms.fun
atoms/hash-type.sig
atoms/cases.sig
-ssa/source-info.sig
-ssa/profile-exp.sig
ssa/ssa-tree.sig
ssa/direct-exp.sig
ssa/analyze.sig
@@ -320,7 +322,6 @@
../lib/mlton/basic/clearable-promise.sml
atoms/hash-type.fun
atoms/cases.fun
-ssa/source-info.fun
ssa/ssa-tree.fun
ssa/ssa.fun
backend/mtype.sig
@@ -367,9 +368,19 @@
xml/xml-type.sig
xml/xml-tree.sig
xml/xml.sig
+xml/xml-tree.fun
+xml/type-check.sig
+xml/type-check.fun
+xml/simplify-types.sig
+xml/simplify-types.fun
+xml/scc-funs.sig
+xml/scc-funs.fun
+xml/simplify.sig
+xml/simplify.fun
+xml/xml.fun
xml/sxml.sig
-xml/implement-exceptions.sig
-xml/implement-exceptions.fun
+xml/polyvariance.sig
+xml/polyvariance.fun
../lib/smlnj/ord-key-sig.sml
../lib/smlnj/splaytree-sig.sml
../lib/smlnj/splaytree.sml
@@ -383,18 +394,8 @@
xml/sxml-exns.sig
xml/monomorphise.sig
xml/monomorphise.fun
-xml/polyvariance.sig
-xml/polyvariance.fun
-xml/xml-tree.fun
-xml/type-check.sig
-xml/type-check.fun
-xml/simplify-types.sig
-xml/simplify-types.fun
-xml/scc-funs.sig
-xml/scc-funs.fun
-xml/simplify.sig
-xml/simplify.fun
-xml/xml.fun
+xml/implement-exceptions.sig
+xml/implement-exceptions.fun
closure-convert/lambda-free.sig
closure-convert/lambda-free.fun
closure-convert/globalize.sig
1.13 +18 -17 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- mlton-stubs.cm 2 Jan 2003 17:45:09 -0000 1.12
+++ mlton-stubs.cm 10 Jan 2003 18:36:04 -0000 1.13
@@ -230,8 +230,12 @@
atoms/type-ops.fun
atoms/type.fun
atoms/tycon.fun
+atoms/source-info.sig
+atoms/source-info.fun
atoms/generic-scheme.sig
atoms/scheme.sig
+atoms/profile-exp.sig
+atoms/profile-exp.fun
atoms/cons.sig
atoms/const.sig
atoms/prim.sig
@@ -243,8 +247,6 @@
atoms/atoms.fun
atoms/hash-type.sig
atoms/cases.sig
-ssa/source-info.sig
-ssa/profile-exp.sig
ssa/ssa-tree.sig
ssa/direct-exp.sig
ssa/analyze.sig
@@ -319,7 +321,6 @@
../lib/mlton/basic/clearable-promise.sml
atoms/hash-type.fun
atoms/cases.fun
-ssa/source-info.fun
ssa/ssa-tree.fun
ssa/ssa.fun
backend/mtype.sig
@@ -366,9 +367,19 @@
xml/xml-type.sig
xml/xml-tree.sig
xml/xml.sig
+xml/xml-tree.fun
+xml/type-check.sig
+xml/type-check.fun
+xml/simplify-types.sig
+xml/simplify-types.fun
+xml/scc-funs.sig
+xml/scc-funs.fun
+xml/simplify.sig
+xml/simplify.fun
+xml/xml.fun
xml/sxml.sig
-xml/implement-exceptions.sig
-xml/implement-exceptions.fun
+xml/polyvariance.sig
+xml/polyvariance.fun
../lib/smlnj/ord-key-sig.sml
../lib/smlnj/splaytree-sig.sml
../lib/smlnj/splaytree.sml
@@ -382,18 +393,8 @@
xml/sxml-exns.sig
xml/monomorphise.sig
xml/monomorphise.fun
-xml/polyvariance.sig
-xml/polyvariance.fun
-xml/xml-tree.fun
-xml/type-check.sig
-xml/type-check.fun
-xml/simplify-types.sig
-xml/simplify-types.fun
-xml/scc-funs.sig
-xml/scc-funs.fun
-xml/simplify.sig
-xml/simplify.fun
-xml/xml.fun
+xml/implement-exceptions.sig
+xml/implement-exceptions.fun
closure-convert/lambda-free.sig
closure-convert/lambda-free.fun
closure-convert/globalize.sig
1.61 +18 -17 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -r1.60 -r1.61
--- mlton.cm 2 Jan 2003 17:45:09 -0000 1.60
+++ mlton.cm 10 Jan 2003 18:36:05 -0000 1.61
@@ -201,8 +201,12 @@
atoms/type-ops.fun
atoms/type.fun
atoms/tycon.fun
+atoms/source-info.sig
+atoms/source-info.fun
atoms/generic-scheme.sig
atoms/scheme.sig
+atoms/profile-exp.sig
+atoms/profile-exp.fun
atoms/cons.sig
atoms/const.sig
atoms/prim.sig
@@ -214,8 +218,6 @@
atoms/atoms.fun
atoms/hash-type.sig
atoms/cases.sig
-ssa/source-info.sig
-ssa/profile-exp.sig
ssa/ssa-tree.sig
ssa/direct-exp.sig
ssa/analyze.sig
@@ -290,7 +292,6 @@
../lib/mlton/basic/clearable-promise.sml
atoms/hash-type.fun
atoms/cases.fun
-ssa/source-info.fun
ssa/ssa-tree.fun
ssa/ssa.fun
backend/mtype.sig
@@ -337,9 +338,19 @@
xml/xml-type.sig
xml/xml-tree.sig
xml/xml.sig
+xml/xml-tree.fun
+xml/type-check.sig
+xml/type-check.fun
+xml/simplify-types.sig
+xml/simplify-types.fun
+xml/scc-funs.sig
+xml/scc-funs.fun
+xml/simplify.sig
+xml/simplify.fun
+xml/xml.fun
xml/sxml.sig
-xml/implement-exceptions.sig
-xml/implement-exceptions.fun
+xml/polyvariance.sig
+xml/polyvariance.fun
../lib/smlnj/ord-key-sig.sml
../lib/smlnj/splaytree-sig.sml
../lib/smlnj/splaytree.sml
@@ -353,18 +364,8 @@
xml/sxml-exns.sig
xml/monomorphise.sig
xml/monomorphise.fun
-xml/polyvariance.sig
-xml/polyvariance.fun
-xml/xml-tree.fun
-xml/type-check.sig
-xml/type-check.fun
-xml/simplify-types.sig
-xml/simplify-types.fun
-xml/scc-funs.sig
-xml/scc-funs.fun
-xml/simplify.sig
-xml/simplify.fun
-xml/xml.fun
+xml/implement-exceptions.sig
+xml/implement-exceptions.fun
closure-convert/lambda-free.sig
closure-convert/lambda-free.fun
closure-convert/globalize.sig
1.3 +2 -0 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- atoms.fun 10 Apr 2002 07:02:18 -0000 1.2
+++ atoms.fun 10 Jan 2003 18:36:08 -0000 1.3
@@ -12,6 +12,8 @@
struct
open S
+ structure SourceInfo = SourceInfo ()
+ structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
structure Var = Var (structure AstId = Ast.Var)
structure Tycon = Tycon (structure AstId = Ast.Tycon)
structure UnaryTycon = UnaryTycon (structure Tycon = Tycon)
1.3 +36 -24 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- atoms.sig 10 Apr 2002 07:02:18 -0000 1.2
+++ atoms.sig 10 Jan 2003 18:36:08 -0000 1.3
@@ -14,32 +14,21 @@
sig
include ATOMS_STRUCTS
- structure Con: CON sharing Con.AstId = Ast.Con
+ structure Con: CON
+ structure Cons: SET
structure Const: CONST
- structure Prim: PRIM sharing Con = Prim.Con sharing Const = Prim.Const
- structure Tycon: TYCON sharing Tycon.AstId = Ast.Tycon
- structure UnaryTycon: UNARY_TYCON sharing Tycon = UnaryTycon.Tycon
- structure Scheme: SCHEME
- structure Var: VAR sharing Var.AstId = Ast.Var
- sharing Tycon = Const.Tycon
- sharing Ast = Const.Ast = Prim.Type.Ast
- sharing Tycon = Scheme.Tycon
- sharing Ast.Tyvar = Scheme.Tyvar
- sharing Scheme = Prim.Scheme
-
+ structure Prim: PRIM
+ structure ProfileExp: PROFILE_EXP
structure Record: RECORD
- sharing Record = Ast.Record
+ structure Scheme: SCHEME
structure SortedRecord: RECORD
- sharing SortedRecord = Ast.SortedRecord
-
+ structure SourceInfo: SOURCE_INFO
+ structure Tycon: TYCON
+ structure Tycons: SET
structure Tyvar: TYVAR
- sharing Tyvar = Ast.Tyvar
-
- structure Tyvars: SET sharing type Tyvars.Element.t = Tyvar.t
- structure Cons: SET sharing type Cons.Element.t = Con.t
- structure Vars: SET sharing type Vars.Element.t = Var.t
- structure Tycons: SET sharing type Tycons.Element.t = Tycon.t
-
+ structure UnaryTycon: UNARY_TYCON
+ structure Var: VAR
+ structure Vars: SET
structure TyvarEnv:
sig
include MONO_ENV
@@ -50,8 +39,29 @@
*)
val rename: t * Tyvar.t vector -> t * Tyvar.t vector
end
- sharing type TyvarEnv.Domain.t = Tyvar.t
- sharing type TyvarEnv.Range.t = Tyvar.t
+ structure Tyvars: SET
+
+ sharing Ast = Const.Ast = Prim.Type.Ast
+ sharing Ast.Con = Con.AstId
+ sharing Ast.Tycon = Tycon.AstId
+ sharing Ast.Tyvar = Scheme.Tyvar
+ sharing Ast.Var = Var.AstId
+ sharing Con = Prim.Con
+ sharing Const = Prim.Const
+ sharing Record = Ast.Record
+ sharing Scheme = Prim.Scheme
+ sharing SortedRecord = Ast.SortedRecord
+ sharing SourceInfo = ProfileExp.SourceInfo
+ sharing Tycon = Const.Tycon
+ sharing Tycon = Scheme.Tycon
+ sharing Tycon = UnaryTycon.Tycon
+ sharing Tyvar = Ast.Tyvar
+ sharing type Con.t = Cons.Element.t
+ sharing type Tycon.t = Tycons.Element.t
+ sharing type Tyvar.t = TyvarEnv.Domain.t
+ sharing type Tyvar.t = TyvarEnv.Range.t
+ sharing type Tyvar.t = Tyvars.Element.t
+ sharing type Var.t = Vars.Element.t
end
signature ATOMS =
@@ -65,9 +75,11 @@
sharing Var = Atoms.Var
sharing Con = Atoms.Con
sharing Prim = Atoms.Prim
+ sharing ProfileExp = Atoms.ProfileExp
sharing Tycon = Atoms.Tycon
sharing Tyvar = Atoms.Tyvar
sharing Record = Atoms.Record
+ sharing SourceInfo = Atoms.SourceInfo
sharing Vars = Atoms.Vars
sharing Cons = Atoms.Cons
sharing Tycons = Atoms.Tycons
1.7 +6 -0 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- sources.cm 7 Dec 2002 02:21:51 -0000 1.6
+++ sources.cm 10 Jan 2003 18:36:08 -0000 1.7
@@ -17,8 +17,10 @@
signature HASH_ID
signature HASH_TYPE
signature PRIM
+signature PROFILE_EXP
signature RECORD
signature SCHEME
+signature SOURCE_INFO
signature TYCON
signature TYPE_OPS
signature TYPE
@@ -56,7 +58,11 @@
id.sig
prim.fun
prim.sig
+profile-exp.fun
+profile-exp.sig
scheme.sig
+source-info.fun
+source-info.sig
tycon.fun
tycon.sig
type-ops.fun
1.1 mlton/mlton/atoms/profile-exp.fun
Index: profile-exp.fun
===================================================================
functor ProfileExp (S: PROFILE_EXP_STRUCTS): PROFILE_EXP =
struct
open S
datatype t =
Enter of SourceInfo.t
| Leave of SourceInfo.t
val toString =
fn Enter si => concat ["Enter ", SourceInfo.toString si]
| Leave si => concat ["Leave " , SourceInfo.toString si]
val layout = Layout.str o toString
val equals =
fn (Enter si, Enter si') => SourceInfo.equals (si, si')
| (Leave si, Leave si') => SourceInfo.equals (si, si')
| _ => false
local
val newHash = Random.word
val enter = newHash ()
val leave = newHash ()
in
val hash =
fn Enter si => Word.xorb (enter, SourceInfo.hash si)
| Leave si => Word.xorb (leave, SourceInfo.hash si)
end
end
1.1 mlton/mlton/atoms/profile-exp.sig
Index: profile-exp.sig
===================================================================
type int = Int.t
type word = Word.t
signature PROFILE_EXP_STRUCTS =
sig
structure SourceInfo: SOURCE_INFO
end
signature PROFILE_EXP =
sig
include PROFILE_EXP_STRUCTS
datatype t =
Enter of SourceInfo.t
| Leave of SourceInfo.t
val equals: t * t -> bool
val hash: t -> word
val layout: t -> Layout.t
val toString: t -> string
end
1.1 mlton/mlton/atoms/source-info.fun
Index: source-info.fun
===================================================================
functor SourceInfo (S: SOURCE_INFO_STRUCTS): SOURCE_INFO =
struct
type t = string
fun toString s = s
val layout = Layout.str o toString
val equals: t * t -> bool = op =
val fromString = fn s => s
val hash = String.hash
val gc = "<gc>"
val main = "<main>"
val polyEqual = "<poly-equal>"
val unknown = "<unknown>"
val basisPrefix = "<basis>/"
fun fromRegion r =
case Region.left r of
NONE => "<unknown>"
| SOME (SourcePos.T {file, line, ...}) =>
let
val s = "/basis-library/"
val file =
case String.findSubstring {string = file, substring = s} of
NONE => file
| SOME i =>
concat [basisPrefix,
String.dropPrefix (file, i + String.size s)]
in
concat [file, ":", Int.toString line]
end
fun isBasis s =
String.isPrefix {prefix = basisPrefix,
string = s}
end
1.1 mlton/mlton/atoms/source-info.sig
Index: source-info.sig
===================================================================
type int = Int.t
type word = Word.t
signature SOURCE_INFO_STRUCTS =
sig
end
signature SOURCE_INFO =
sig
include SOURCE_INFO_STRUCTS
type t
val equals: t * t -> bool
val gc: t
val fromRegion: Region.t -> t
val fromString: string -> t
val hash: t -> word
val isBasis: t -> bool
val layout: t -> Layout.t
val main: t
val polyEqual: t
val toString: t -> string
val unknown: t
end
1.47 +1 -1 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- backend.fun 4 Jan 2003 02:00:27 -0000 1.46
+++ backend.fun 10 Jan 2003 18:36:08 -0000 1.47
@@ -152,6 +152,7 @@
val program = pass ("insertLimitChecks", LimitCheck.insert, program)
val program = pass ("insertSignalChecks", SignalCheck.insert, program)
val program = pass ("implementHandlers", ImplementHandlers.doit, program)
+ val _ = R.Program.checkHandlers program
val {frameProfileIndices, labels = profileLabels, program, sources,
sourceSeqs, sourceSuccessors} =
Control.passTypeCheck
@@ -162,7 +163,6 @@
suffix = "rssa",
thunk = fn () => Profile.profile program,
typeCheck = R.Program.typeCheck o #program}
- val _ = R.Program.checkHandlers program
val profileStack =
!Control.profile <> Control.ProfileNone
andalso !Control.profileStack
1.8 +363 -121 mlton/mlton/backend/implement-handlers.fun
Index: implement-handlers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/implement-handlers.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- implement-handlers.fun 2 Jan 2003 17:45:13 -0000 1.7
+++ implement-handlers.fun 10 Jan 2003 18:36:10 -0000 1.8
@@ -10,6 +10,8 @@
open S
open Rssa
+datatype z = datatype Statement.t
+datatype z = datatype Transfer.t
structure LabelInfo =
struct
@@ -25,134 +27,374 @@
("visited", Bool.layout (!visited))]
end
-fun doit (Program.T {functions, main, objectTypes}) =
+structure Function =
+ struct
+ open Function
+
+ fun hasHandler (f: t): bool =
+ let
+ val {blocks, ...} = dest f
+ in
+ Vector.exists
+ (blocks, fn Block.T {transfer, ...} =>
+ case transfer of
+ Transfer.Call
+ {return = (Return.NonTail
+ {handler = Handler.Handle _, ...}), ...} =>
+ true
+ | _ => false)
+ end
+ end
+
+structure HandlerLat = FlatLattice (structure Point = Label)
+
+structure ExnStack =
+ struct
+ local
+ structure ZPoint =
+ struct
+ datatype t = Local | Slot
+
+ val equals: t * t -> bool = op =
+
+ val toString =
+ fn Local => "Local"
+ | Slot => "Slot"
+
+ val layout = Layout.str o toString
+ end
+ structure L = FlatLattice (structure Point = ZPoint)
+ in
+ open L
+ structure Point = ZPoint
+ val locall = point Point.Local
+ val slot = point Point.Slot
+ end
+ end
+
+fun flow (f: Function.t): Function.t =
+ if not (Function.hasHandler f)
+ then f
+ else
let
- fun implementFunction (f: Function.t): Function.t =
+ val debug = false
+ val {args, blocks, name, raises, returns, start} =
+ Function.dest f
+ val {get = labelInfo: Label.t -> {global: ExnStack.t,
+ handler: HandlerLat.t}, ...} =
+ Property.get (Label.plist,
+ Property.initFun (fn _ =>
+ {global = ExnStack.new (),
+ handler = HandlerLat.new ()}))
+ val _ =
+ Vector.foreach
+ (blocks, fn Block.T {label, transfer, ...} =>
+ let
+ val {global, handler} = labelInfo label
+ val _ =
+ if Label.equals (label, start)
+ then (ExnStack.<= (ExnStack.slot, global)
+ ; HandlerLat.forceTop handler
+ ; ())
+ else ()
+ fun goto' {global = g, handler = h}: unit =
+ (ExnStack.<= (global, g)
+ ; HandlerLat.<= (handler, h)
+ ; ())
+ val goto = goto' o labelInfo
+ in
+ case transfer of
+ Call {return, ...} =>
+ (case return of
+ Return.Dead => ()
+ | Return.NonTail {cont, handler = h} =>
+ let
+ val li as {global = g', handler = h'} =
+ labelInfo cont
+ in
+ case h of
+ Handler.Caller =>
+ (ExnStack.<= (ExnStack.slot, g')
+ ; HandlerLat.<= (handler, h')
+ ; ())
+ | Handler.Dead => goto' li
+ | Handler.Handle l =>
+ let
+ fun doit {global = g'', handler = h''} =
+ (ExnStack.<= (ExnStack.locall, g'')
+ ; (HandlerLat.<=
+ (HandlerLat.point l, h'')))
+ in
+ doit (labelInfo l)
+ ; doit li
+ ; ()
+ end
+ end
+ | Return.Tail => ())
+ | _ => Transfer.foreachLabel (transfer, goto)
+ end)
+ val _ =
+ if debug
+ then
+ Layout.outputl
+ (Vector.layout
+ (fn Block.T {label, ...} =>
+ let
+ val {global, handler} = labelInfo label
+ in
+ Layout.record [("label", Label.layout label),
+ ("global", ExnStack.layout global),
+ ("handler", HandlerLat.layout handler)]
+ end)
+ blocks,
+ Out.error)
+ else ()
+ val blocks =
+ Vector.map
+ (blocks,
+ fn Block.T {args, kind, label, statements, transfer} =>
+ let
+ val {global, handler} = labelInfo label
+ fun setExnStackSlot () =
+ if ExnStack.isPointEq (global, ExnStack.Point.Slot)
+ then Vector.new0 ()
+ else Vector.new1 SetExnStackSlot
+ fun setExnStackLocal () =
+ if ExnStack.isPointEq (global, ExnStack.Point.Local)
+ then Vector.new0 ()
+ else Vector.new1 SetExnStackLocal
+ fun setHandler (l: Label.t) =
+ if HandlerLat.isPointEq (handler, l)
+ then Vector.new0 ()
+ else Vector.new1 (SetHandler l)
+ val post =
+ case transfer of
+ Call {args, func, return} =>
+ (case return of
+ Return.Dead => Vector.new0 ()
+ | Return.NonTail {cont, handler} =>
+ (case handler of
+ Handler.Caller => setExnStackSlot ()
+ | Handler.Dead => Vector.new0 ()
+ | Handler.Handle l =>
+ Vector.concat
+ [setHandler l, setExnStackLocal ()])
+ | Return.Tail => setExnStackSlot ())
+ | Raise _ => setExnStackSlot ()
+ | Return _ => setExnStackSlot ()
+ | _ => Vector.new0 ()
+ val statements = Vector.concat [statements, post]
+ in
+ Block.T {args = args,
+ kind = kind,
+ label = label,
+ statements = statements,
+ transfer = transfer}
+ end)
+ val newStart = Label.newNoname ()
+ val startBlock =
+ Block.T {args = Vector.new0 (),
+ kind = Kind.Jump,
+ label = newStart,
+ statements = Vector.new1 SetSlotExnStack,
+ transfer = Goto {args = Vector.new0 (),
+ dst = start}}
+ val blocks = Vector.concat [blocks, Vector.new1 startBlock]
+ in
+ Function.new {args = args,
+ blocks = blocks,
+ name = name,
+ raises = raises,
+ returns = returns,
+ start = newStart}
+ end
+
+fun pushPop (f: Function.t): Function.t =
+ let
+ val {args, blocks, name, raises, returns, start} =
+ Function.dest f
+ val {get = labelInfo: Label.t -> LabelInfo.t,
+ set = setLabelInfo, ...} =
+ Property.getSetOnce
+ (Label.plist, Property.initRaise ("info", Label.layout))
+ val _ =
+ Vector.foreach
+ (blocks, fn b as Block.T {label, ...} =>
+ setLabelInfo (label,
+ {block = b,
+ handlerStack = ref NONE,
+ replacement = ref NONE,
+ visited = ref false}))
+ (* Do a dfs from the start, figuring out the handler stack at
+ * each label.
+ *)
+ fun visit (l: Label.t, hs: Label.t list): unit =
let
- val {args, blocks, name, raises, returns, start} =
- Function.dest f
- val {get = labelInfo: Label.t -> LabelInfo.t,
- set = setLabelInfo, ...} =
- Property.getSetOnce
- (Label.plist, Property.initRaise ("info", Label.layout))
- val _ =
- Vector.foreach
- (blocks, fn b as Block.T {label, ...} =>
- setLabelInfo (label,
- {block = b,
- handlerStack = ref NONE,
- replacement = ref NONE,
- visited = ref false}))
- (* Do a dfs from the start, figuring out the handler stack at
- * each label.
- *)
- fun visit (l: Label.t, hs: Label.t list): unit =
+ val {block, handlerStack, replacement, visited} = labelInfo l
+ val Block.T {statements, transfer, ...} = block
+ in
+ if !visited
+ then ()
+ else
let
- val {block, handlerStack, replacement, visited} = labelInfo l
- val Block.T {statements, transfer, ...} = block
- in
- if !visited
- then ()
- else
- let
- val _ = visited := true
- fun bug msg =
- (Vector.layout
- (fn Block.T {label, ...} =>
- let open Layout
- in seq [Label.layout label,
- str " ",
- LabelInfo.layout (labelInfo label)]
- end)
- ; Error.bug (concat
- [msg, ": ", Label.toString l]))
- val _ =
- case !handlerStack of
- NONE => handlerStack := SOME hs
- | SOME hs' =>
- if List.equals (hs, hs', Label.equals)
- then ()
- else bug "handler stack mismatch"
- datatype z = datatype Statement.t
- val hs =
- if not (Vector.exists
- (statements, fn s =>
- case s of
- HandlerPop _ => true
- | HandlerPush _ => true
- | _ => false))
- (* An optimization to avoid recopying blocks
- * with no handlers.
- *)
- then (replacement := SOME statements
- ; hs)
- else
- let
- val (hs, ac) =
- Vector.fold
- (statements, (hs, []), fn (s, (hs, ac)) =>
- case s of
- HandlerPop _ =>
- (case hs of
- [] => bug "pop of empty handler stack"
- | _ :: hs =>
- let
- val s =
- case hs of
- [] =>
- Statement.SetExnStackSlot
- | h :: _ =>
- Statement.SetHandler h
- in (hs, s :: ac)
- end)
- | HandlerPush h =>
- let
- val ac =
- Statement.SetHandler h :: ac
- val ac =
- case hs of
- [] =>
- Statement.SetExnStackLocal
- :: Statement.SetSlotExnStack
- :: ac
- | _ => ac
- in
- (h :: hs, ac)
- end
- | _ => (hs, s :: ac))
- val _ =
- replacement := SOME (Vector.fromListRev ac)
- in
- hs
- end
+ val _ = visited := true
+ fun bug msg =
+ (Vector.layout
+ (fn Block.T {label, ...} =>
+ let open Layout
+ in seq [Label.layout label,
+ str " ",
+ LabelInfo.layout (labelInfo label)]
+ end)
+ ; Error.bug (concat
+ [msg, ": ", Label.toString l]))
+ val _ =
+ case !handlerStack of
+ NONE => handlerStack := SOME hs
+ | SOME hs' =>
+ if List.equals (hs, hs', Label.equals)
+ then ()
+ else bug "handler stack mismatch"
+ val hs =
+ if not (Vector.exists
+ (statements, fn s =>
+ case s of
+ HandlerPop _ => true
+ | HandlerPush _ => true
+ | _ => false))
+ (* An optimization to avoid recopying blocks
+ * with no handlers.
+ *)
+ then (replacement := SOME statements
+ ; hs)
+ else
+ let
+ val (hs, ac) =
+ Vector.fold
+ (statements, (hs, []), fn (s, (hs, ac)) =>
+ case s of
+ HandlerPop _ =>
+ (case hs of
+ [] => bug "pop of empty handler stack"
+ | _ :: hs =>
+ let
+ val s =
+ case hs of
+ [] => SetExnStackSlot
+ | h :: _ => SetHandler h
+ in (hs, s :: ac)
+ end)
+ | HandlerPush h =>
+ let
+ val ac = SetHandler h :: ac
+ val ac =
+ case hs of
+ [] =>
+ SetExnStackLocal
+ :: SetSlotExnStack
+ :: ac
+ | _ => ac
+ in
+ (h :: hs, ac)
+ end
+ | _ => (hs, s :: ac))
+ val _ =
+ replacement := SOME (Vector.fromListRev ac)
in
- Transfer.foreachLabel (transfer, fn l =>
- visit (l, hs))
+ hs
end
+ in
+ Transfer.foreachLabel (transfer, fn l =>
+ visit (l, hs))
end
- val _ = visit (start, [])
- val blocks =
- Vector.map
- (blocks, fn b as Block.T {args, kind, label, transfer, ...} =>
- let
- val {replacement, visited, ...} = labelInfo label
- in
- if !visited
- then Block.T {args = args,
- kind = kind,
- label = label,
- statements = valOf (! replacement),
- transfer = transfer}
- else b
- end)
- in
- Function.new {args = args,
- blocks = blocks,
- name = name,
- raises = raises,
- returns = returns,
- start = start}
end
+ val _ = visit (start, [])
+ val blocks =
+ Vector.map
+ (blocks, fn b as Block.T {args, kind, label, transfer, ...} =>
+ let
+ val {replacement, visited, ...} = labelInfo label
+ in
+ if !visited
+ then Block.T {args = args,
+ kind = kind,
+ label = label,
+ statements = valOf (! replacement),
+ transfer = transfer}
+ else b
+ end)
+ in
+ Function.new {args = args,
+ blocks = blocks,
+ name = name,
+ raises = raises,
+ returns = returns,
+ start = start}
+ end
+
+fun simple (f: Function.t): Function.t =
+ if not (Function.hasHandler f)
+ then f
+ else
+ let
+ val {args, blocks, name, raises, returns, start} =
+ Function.dest f
+ val blocks =
+ Vector.map
+ (blocks,
+ fn Block.T {args, kind, label, statements, transfer} =>
+ let
+ val post =
+ case transfer of
+ Call {args, func, return} =>
+ (case return of
+ Return.Dead => Vector.new0 ()
+ | Return.NonTail {cont, handler} =>
+ (case handler of
+ Handler.Caller =>
+ Vector.new1 SetExnStackSlot
+ | Handler.Dead => Vector.new0 ()
+ | Handler.Handle l =>
+ Vector.new2 (SetHandler l,
+ SetExnStackLocal))
+ | Return.Tail =>
+ Vector.new1 SetExnStackSlot)
+ | Raise _ => Vector.new1 SetExnStackSlot
+ | Return _ => Vector.new1 SetExnStackSlot
+ | _ => Vector.new0 ()
+ val statements = Vector.concat [statements, post]
+ in
+ Block.T {args = args,
+ kind = kind,
+ label = label,
+ statements = statements,
+ transfer = transfer}
+ end)
+ val newStart = Label.newNoname ()
+ val startBlock =
+ Block.T {args = Vector.new0 (),
+ kind = Kind.Jump,
+ label = newStart,
+ statements = Vector.new1 SetSlotExnStack,
+ transfer = Goto {args = Vector.new0 (),
+ dst = start}}
+ val blocks = Vector.concat [blocks, Vector.new1 startBlock]
+ in
+ Function.new {args = args,
+ blocks = blocks,
+ name = name,
+ raises = raises,
+ returns = returns,
+ start = newStart}
+ end
+
+fun doit (Program.T {functions, main, objectTypes}) =
+ let
+ val implementFunction =
+ case !Control.handlers of
+ Control.Flow => flow
+ | Control.PushPop => pushPop
+ | Control.Simple => simple
in
Program.T {functions = List.revMap (functions, implementFunction),
main = main,
1.27 +19 -2 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- rssa.fun 2 Jan 2003 17:45:15 -0000 1.26
+++ rssa.fun 10 Jan 2003 18:36:10 -0000 1.27
@@ -721,8 +721,12 @@
("handler", HandlerLat.layout handler)]
end
+ val traceGoto =
+ Trace.trace ("checkHandlers.goto", Label.layout, Unit.layout)
+
fun checkHandlers (T {functions, ...}) =
let
+ val debug = false
fun checkFunction (f: Function.t): unit =
let
val {name, start, blocks, ...} = Function.dest f
@@ -746,6 +750,18 @@
let
val _ = visited := true
val Block.T {label, statements, transfer, ...} = block
+ val _ =
+ if debug
+ then
+ let
+ open Layout
+ in
+ outputl
+ (seq [str "visiting ",
+ Label.layout label],
+ Out.error)
+ end
+ else ()
datatype z = datatype ExnStack.t
datatype z = datatype Statement.t
val {global, handler, slot} =
@@ -762,7 +778,7 @@
slot = slot}
| SetSlotExnStack => {global = global,
handler = handler,
- slot = slot}
+ slot = global}
| SetHandler l => {global = global,
handler = HandlerLat.point l,
slot = slot}
@@ -807,6 +823,7 @@
in
visitLabel l
end
+ val goto = traceGoto goto
fun tail name =
assert (name,
ExnStack.forcePoint
@@ -823,7 +840,7 @@
let
datatype z = datatype Return.t
in
- case (return) of
+ case return of
Dead => true
| NonTail {handler = h, ...} =>
(case h of
1.23 +207 -203 mlton/mlton/closure-convert/closure-convert.fun
Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- closure-convert.fun 2 Jan 2003 17:45:15 -0000 1.22
+++ closure-convert.fun 10 Jan 2003 18:36:10 -0000 1.23
@@ -334,6 +334,7 @@
set (Value.primApply {prim = prim,
args = varExps args,
resultTy = ty})
+ | Profile _ => (new (); ())
| Raise _ => (new (); ())
| Select {tuple, offset} =>
set (Value.select (varExp tuple, offset))
@@ -771,211 +772,214 @@
in (coerce (e', expValue e, v), ac)
end
fun simple e = (e, ac)
- in case e of
- SprimExp.Var y => simple (convertVarExp y)
- | SprimExp.Const c => simple (Dexp.const c)
- | SprimExp.PrimApp {prim, targs, args} =>
- let
- open Prim.Name
- fun arg i = Vector.sub (args, i)
- val v1 = Vector.new1
- val v2 = Vector.new2
- val v3 = Vector.new3
- fun primApp (targs, args) =
- Dexp.primApp {args = args,
- prim = prim,
- targs = targs,
- ty = ty}
- in
- if Prim.mayOverflow prim
- then simple (Dexp.arith
- {args = Vector.map (args, convertVarExp),
- overflow = Dexp.raisee (convertVar overflow),
- prim = prim,
- ty = ty})
- else
- let
- datatype z = datatype Prim.Name.t
- in
- simple
- (case Prim.name prim of
- Array_update =>
- let
- val a = varExpInfo (arg 0)
- val y = varExpInfo (arg 2)
- val v = Value.dearray (VarInfo.value a)
- in
- primApp (v1 (valueType v),
- v3 (convertVarInfo a,
- convertVarExp (arg 1),
- coerce (convertVarInfo y,
- VarInfo.value y, v)))
- end
- | MLton_eq =>
- let
- val a0 = varExpInfo (arg 0)
- val a1 = varExpInfo (arg 1)
- fun doit () =
- primApp (v1 (valueType (VarInfo.value a0)),
- v2 (convertVarInfo a0,
- convertVarInfo a1))
- in
- case (Value.dest (VarInfo.value a0),
- Value.dest (VarInfo.value a1)) of
- (Value.Lambdas l, Value.Lambdas l') =>
- if Lambdas.equals (l, l')
- then doit ()
- else Dexp.falsee
- | _ => doit ()
- end
- | MLton_handlesSignals =>
- if handlesSignals then Dexp.truee else Dexp.falsee
- | Ref_assign =>
- let
- val r = varExpInfo (arg 0)
- val y = varExpInfo (arg 1)
- val v = Value.deref (VarInfo.value r)
- in
- primApp (v1 (valueType v),
- v2 (convertVarInfo r,
- coerce (convertVarInfo y,
- VarInfo.value y, v)))
- end
- | Ref_ref =>
- let
- val y = varExpInfo (arg 0)
- val v = Value.deref v
- in
- primApp (v1 (valueType v),
- v1 (coerce (convertVarInfo y,
- VarInfo.value y, v)))
- end
- | MLton_serialize =>
- let
- val y = varExpInfo (arg 0)
- val v =
- Value.serialValue (Vector.sub (targs, 0))
- in
- primApp (v1 (valueType v),
- v1 (coerce (convertVarInfo y,
- VarInfo.value y, v)))
- end
- | _ =>
- let
- val args = Vector.map (args, varExpInfo)
- in
- primApp
- (Prim.extractTargs
- {prim = prim,
- args = Vector.map (args, varInfoType),
- result = ty,
- dearray = Type.dearray,
- dearrow = Type.dearrow,
- deref = Type.deref,
- devector = Type.devector},
- Vector.map (args, convertVarInfo))
- end)
- end
- end
- | SprimExp.Tuple xs =>
- simple (Dexp.tuple {exps = Vector.map (xs, convertVarExp),
- ty = ty})
- | SprimExp.Select {tuple, offset} =>
- simple (Dexp.select {tuple = convertVarExp tuple,
- offset = offset,
- ty = ty})
- | SprimExp.ConApp {con = con, arg, ...} =>
- simple
- (Dexp.conApp
- {con = con,
- ty = ty,
- args = (case (arg, conArg con) of
- (NONE, NONE) => Vector.new0 ()
- | (SOME arg, SOME conArg) =>
- let
- val arg = varExpInfo arg
- val argVal = VarInfo.value arg
- val arg = convertVarInfo arg
- in if Value.equals (argVal, conArg)
- then Vector.new1 arg
- else Vector.new1 (coerce (arg, argVal, conArg))
- end
- | _ => Error.bug "constructor mismatch")})
- | SprimExp.Raise {exn, ...} => simple (Dexp.raisee (convertVarExp exn))
- | SprimExp.Handle {try, catch = (catch, _), handler} =>
- let
- val catchInfo = varInfo catch
- val (try, ac) = convertJoin (try, ac)
- val catch = (newVarInfo (catch, catchInfo),
- varInfoType catchInfo)
- val (handler, ac) = convertJoin (handler, ac)
- in (Dexp.handlee {try = try, ty = ty,
- catch = catch, handler = handler},
- ac)
- end
- | SprimExp.Case {test, cases, default} =>
- let
- val (default, ac) =
- case default of
- NONE => (NONE, ac)
- | SOME (e, _) => let
- val (e, ac) = convertJoin (e, ac)
- in
- (SOME e, ac)
- end
- fun doCases (cases, finish, make) =
- let
- val (cases, ac) =
- Vector.mapAndFold
- (cases, ac, fn ((x, e), ac) =>
- let
- val make = make x
- val (body, ac) = convertJoin (e, ac)
- in (make body, ac)
- end)
- in (finish cases, ac)
- end
- fun doit (l, f) = doCases (l, f, fn i => fn e => (i, e))
- val (cases, ac) =
- case cases of
- Scases.Char l => doit (l, Dexp.Char)
- | Scases.Con cases =>
- doCases
- (cases, Dexp.Con,
- fn Spat.T {con, arg, ...} =>
- let
- val args =
- case (conArg con, arg) of
- (NONE, NONE) => Vector.new0 ()
- | (SOME v, SOME (arg, _)) =>
- Vector.new1 (newVar arg, valueType v)
- | _ => Error.bug "constructor mismatch"
- in fn body => {con = con, args = args, body = body}
- end)
- | Scases.Int l => doit (l, Dexp.Int)
- | Scases.Word l => doit (l, Dexp.Word)
- | Scases.Word8 l => doit (l, Dexp.Word8)
- in (Dexp.casee
- {test = convertVarExp test,
- ty = ty, cases = cases, default = default},
+ in
+ case e of
+ SprimExp.App {func, arg} =>
+ (apply {func = func, arg = arg, resultVal = v},
ac)
- end
- | SprimExp.Lambda l =>
- let
- val info = lambdaInfo l
- val ac = convertLambda (l, info, ac)
- val {cons, ...} = valueLambdasInfo v
- in case Vector.peek (cons, fn {lambda = l', ...} =>
- Slambda.equals (l, l')) of
- NONE => Error.bug "lambda must exist in its own set"
- | SOME {con, ...} =>
- (Dexp.conApp {con = con, ty = ty,
- args = Vector.new1 (lambdaInfoTuple info)},
+ | SprimExp.Case {test, cases, default} =>
+ let
+ val (default, ac) =
+ case default of
+ NONE => (NONE, ac)
+ | SOME (e, _) => let
+ val (e, ac) = convertJoin (e, ac)
+ in
+ (SOME e, ac)
+ end
+ fun doCases (cases, finish, make) =
+ let
+ val (cases, ac) =
+ Vector.mapAndFold
+ (cases, ac, fn ((x, e), ac) =>
+ let
+ val make = make x
+ val (body, ac) = convertJoin (e, ac)
+ in (make body, ac)
+ end)
+ in (finish cases, ac)
+ end
+ fun doit (l, f) = doCases (l, f, fn i => fn e => (i, e))
+ val (cases, ac) =
+ case cases of
+ Scases.Char l => doit (l, Dexp.Char)
+ | Scases.Con cases =>
+ doCases
+ (cases, Dexp.Con,
+ fn Spat.T {con, arg, ...} =>
+ let
+ val args =
+ case (conArg con, arg) of
+ (NONE, NONE) => Vector.new0 ()
+ | (SOME v, SOME (arg, _)) =>
+ Vector.new1 (newVar arg, valueType v)
+ | _ => Error.bug "constructor mismatch"
+ in fn body => {con = con, args = args, body = body}
+ end)
+ | Scases.Int l => doit (l, Dexp.Int)
+ | Scases.Word l => doit (l, Dexp.Word)
+ | Scases.Word8 l => doit (l, Dexp.Word8)
+ in (Dexp.casee
+ {test = convertVarExp test,
+ ty = ty, cases = cases, default = default},
ac)
- end
- | SprimExp.App {func, arg} =>
- (apply {func = func, arg = arg, resultVal = v},
- ac)
+ end
+ | SprimExp.ConApp {con = con, arg, ...} =>
+ simple
+ (Dexp.conApp
+ {con = con,
+ ty = ty,
+ args = (case (arg, conArg con) of
+ (NONE, NONE) => Vector.new0 ()
+ | (SOME arg, SOME conArg) =>
+ let
+ val arg = varExpInfo arg
+ val argVal = VarInfo.value arg
+ val arg = convertVarInfo arg
+ in if Value.equals (argVal, conArg)
+ then Vector.new1 arg
+ else Vector.new1 (coerce (arg, argVal, conArg))
+ end
+ | _ => Error.bug "constructor mismatch")})
+ | SprimExp.Const c => simple (Dexp.const c)
+ | SprimExp.Handle {try, catch = (catch, _), handler} =>
+ let
+ val catchInfo = varInfo catch
+ val (try, ac) = convertJoin (try, ac)
+ val catch = (newVarInfo (catch, catchInfo),
+ varInfoType catchInfo)
+ val (handler, ac) = convertJoin (handler, ac)
+ in (Dexp.handlee {try = try, ty = ty,
+ catch = catch, handler = handler},
+ ac)
+ end
+ | SprimExp.Lambda l =>
+ let
+ val info = lambdaInfo l
+ val ac = convertLambda (l, info, ac)
+ val {cons, ...} = valueLambdasInfo v
+ in case Vector.peek (cons, fn {lambda = l', ...} =>
+ Slambda.equals (l, l')) of
+ NONE => Error.bug "lambda must exist in its own set"
+ | SOME {con, ...} =>
+ (Dexp.conApp {con = con, ty = ty,
+ args = Vector.new1 (lambdaInfoTuple info)},
+ ac)
+ end
+ | SprimExp.PrimApp {prim, targs, args} =>
+ let
+ open Prim.Name
+ fun arg i = Vector.sub (args, i)
+ val v1 = Vector.new1
+ val v2 = Vector.new2
+ val v3 = Vector.new3
+ fun primApp (targs, args) =
+ Dexp.primApp {args = args,
+ prim = prim,
+ targs = targs,
+ ty = ty}
+ in
+ if Prim.mayOverflow prim
+ then simple (Dexp.arith
+ {args = Vector.map (args, convertVarExp),
+ overflow = Dexp.raisee (convertVar overflow),
+ prim = prim,
+ ty = ty})
+ else
+ let
+ datatype z = datatype Prim.Name.t
+ in
+ simple
+ (case Prim.name prim of
+ Array_update =>
+ let
+ val a = varExpInfo (arg 0)
+ val y = varExpInfo (arg 2)
+ val v = Value.dearray (VarInfo.value a)
+ in
+ primApp (v1 (valueType v),
+ v3 (convertVarInfo a,
+ convertVarExp (arg 1),
+ coerce (convertVarInfo y,
+ VarInfo.value y, v)))
+ end
+ | MLton_eq =>
+ let
+ val a0 = varExpInfo (arg 0)
+ val a1 = varExpInfo (arg 1)
+ fun doit () =
+ primApp (v1 (valueType (VarInfo.value a0)),
+ v2 (convertVarInfo a0,
+ convertVarInfo a1))
+ in
+ case (Value.dest (VarInfo.value a0),
+ Value.dest (VarInfo.value a1)) of
+ (Value.Lambdas l, Value.Lambdas l') =>
+ if Lambdas.equals (l, l')
+ then doit ()
+ else Dexp.falsee
+ | _ => doit ()
+ end
+ | MLton_handlesSignals =>
+ if handlesSignals then Dexp.truee else Dexp.falsee
+ | Ref_assign =>
+ let
+ val r = varExpInfo (arg 0)
+ val y = varExpInfo (arg 1)
+ val v = Value.deref (VarInfo.value r)
+ in
+ primApp (v1 (valueType v),
+ v2 (convertVarInfo r,
+ coerce (convertVarInfo y,
+ VarInfo.value y, v)))
+ end
+ | Ref_ref =>
+ let
+ val y = varExpInfo (arg 0)
+ val v = Value.deref v
+ in
+ primApp (v1 (valueType v),
+ v1 (coerce (convertVarInfo y,
+ VarInfo.value y, v)))
+ end
+ | MLton_serialize =>
+ let
+ val y = varExpInfo (arg 0)
+ val v =
+ Value.serialValue (Vector.sub (targs, 0))
+ in
+ primApp (v1 (valueType v),
+ v1 (coerce (convertVarInfo y,
+ VarInfo.value y, v)))
+ end
+ | _ =>
+ let
+ val args = Vector.map (args, varExpInfo)
+ in
+ primApp
+ (Prim.extractTargs
+ {prim = prim,
+ args = Vector.map (args, varInfoType),
+ result = ty,
+ dearray = Type.dearray,
+ dearrow = Type.dearrow,
+ deref = Type.deref,
+ devector = Type.devector},
+ Vector.map (args, convertVarInfo))
+ end)
+ end
+ end
+ | SprimExp.Profile e => simple (Dexp.profile e)
+ | SprimExp.Raise {exn, ...} =>
+ simple (Dexp.raisee (convertVarExp exn))
+ | SprimExp.Select {tuple, offset} =>
+ simple (Dexp.select {tuple = convertVarExp tuple,
+ offset = offset,
+ ty = ty})
+ | SprimExp.Tuple xs =>
+ simple (Dexp.tuple {exps = Vector.map (xs, convertVarExp),
+ ty = ty})
+ | SprimExp.Var y => simple (convertVarExp y)
end) arg
and convertLambda (lambda: Slambda.t,
info as LambdaInfo.T {frees, name, recs, ...},
1.6 +1 -0 mlton/mlton/closure-convert/globalize.fun
Index: globalize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/globalize.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- globalize.fun 12 Dec 2002 01:14:22 -0000 1.5
+++ globalize.fun 10 Jan 2003 18:36:11 -0000 1.6
@@ -119,6 +119,7 @@
in
(global, once)
end
+ | Profile _ => (false, once)
| Raise _ => (false, once)
| Select {tuple, ...} => (isGlobal tuple, once)
| Tuple xs => (areGlobal xs, once)
1.6 +15 -14 mlton/mlton/closure-convert/lambda-free.fun
Index: lambda-free.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/lambda-free.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- lambda-free.fun 12 Dec 2002 01:14:22 -0000 1.5
+++ lambda-free.fun 10 Jan 2003 18:36:11 -0000 1.6
@@ -108,30 +108,31 @@
end
and primExp (e, s) =
case e of
- Const _ => ()
- | Var x => varExp (x, s)
- | Tuple xs => varExps (xs, s)
- | Select {tuple, ...} => varExp (tuple, s)
+ App {func, arg} => (varExp (func, s); varExp (arg, s))
+ | Case {test, cases, default} =>
+ (varExp (test, s)
+ ; Option.app (default, fn (e, _) => exp (e, s))
+ ; Cases.foreach' (cases, fn e => exp (e, s),
+ fn Pat.T {arg, ...} =>
+ Option.app (arg, fn (x, _) => bind (x, s))))
+ | ConApp {arg, ...} => varExpOpt (arg, s)
+ | Const _ => ()
+ | Handle {try, catch, handler} =>
+ (exp (try, s); bind (#1 catch, s); exp (handler, s))
| Lambda l =>
let val xs = lambda l
in setFree (l, xs); vars (xs, s)
end
- | ConApp {arg, ...} => varExpOpt (arg, s)
| PrimApp {prim, args, ...} =>
(if Prim.mayOverflow prim
then var (overflowVar, s)
else ();
varExps (args, s))
- | App {func, arg} => (varExp (func, s); varExp (arg, s))
+ | Profile _ => ()
| Raise {exn, ...} => varExp (exn, s)
- | Handle {try, catch, handler} =>
- (exp (try, s); bind (#1 catch, s); exp (handler, s))
- | Case {test, cases, default} =>
- (varExp (test, s)
- ; Option.app (default, fn (e, _) => exp (e, s))
- ; Cases.foreach' (cases, fn e => exp (e, s),
- fn Pat.T {arg, ...} =>
- Option.app (arg, fn (x, _) => bind (x, s))))
+ | Select {tuple, ...} => varExp (tuple, s)
+ | Tuple xs => varExps (xs, s)
+ | Var x => varExp (x, s)
and lambda (l: Lambda.t) : Var.t vector =
let val {arg, body, ...} = Lambda.dest l
in newScope (fn s => (bind (arg, s); exp (body, s)))
1.60 +6 -0 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- control.sig 3 Jan 2003 06:14:16 -0000 1.59
+++ control.sig 10 Jan 2003 18:36:11 -0000 1.60
@@ -56,6 +56,9 @@
| Every
val gcCheck: gcCheck ref
+ datatype handlers = Flow | PushPop | Simple
+ val handlers: handlers ref
+
datatype host =
Cross of string
| Self
@@ -196,6 +199,9 @@
datatype profile = ProfileNone | ProfileAlloc | ProfileTime
val profile: profile ref
+ datatype profileIL = ProfileXML | ProfileSSA
+ val profileIL: profileIL ref
+
val profileStack: bool ref
(* Array bounds checking. *)
1.76 +31 -0 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- control.sml 3 Jan 2003 06:14:16 -0000 1.75
+++ control.sml 10 Jan 2003 18:36:11 -0000 1.76
@@ -89,6 +89,22 @@
default = Limit,
toString = GcCheck.toString}
+structure Handlers =
+ struct
+ datatype t = Flow | PushPop | Simple
+
+ val toString =
+ fn Flow => "Flow"
+ | PushPop => "PushPop"
+ | Simple => "Simple"
+ end
+
+datatype handlers = datatype Handlers.t
+
+val handlers = control {name = "handlers",
+ default = Flow,
+ toString = Handlers.toString}
+
structure Host =
struct
datatype t =
@@ -342,6 +358,21 @@
default = ProfileNone,
toString = Profile.toString}
+structure ProfileIL =
+ struct
+ datatype t = ProfileSSA | ProfileXML
+
+ val toString =
+ fn ProfileSSA => "ProfileSSA"
+ | ProfileXML => "ProfileXML"
+ end
+
+datatype profileIL = datatype ProfileIL.t
+
+val profileIL = control {name = "profile IL",
+ default = ProfileXML,
+ toString = ProfileIL.toString}
+
val profileStack = control {name = "profile stack",
default = false,
toString = Bool.toString}
1.107 +15 -0 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.106
retrieving revision 1.107
diff -u -r1.106 -r1.107
--- main.sml 3 Jan 2003 06:14:16 -0000 1.106
+++ main.sml 10 Jan 2003 18:36:12 -0000 1.107
@@ -138,6 +138,14 @@
| "first" => First
| "every" => Every
| _ => usage (concat ["invalid -gc-check flag: ", s])))),
+ (Expert, "handlers", " {flow|pushpop|simple}",
+ "how to implement handlers",
+ SpaceString (fn s =>
+ case s of
+ "flow" => handlers := Flow
+ | "pushpop" => handlers := PushPop
+ | "simple" => handlers := Simple
+ | _ => usage (concat ["invalid -handlers flag: ", s]))),
(Normal, "host",
concat [" {",
concat (List.separate (List.map (hostMap (), #host), "|")),
@@ -253,6 +261,13 @@
| "alloc" => ProfileAlloc
| "time" => ProfileTime
| _ => usage (concat ["invalid -profile arg: ", s])))),
+ (Expert, "profile-il", " {xml|ssa}", "where to insert profile exps",
+ SpaceString
+ (fn s =>
+ case s of
+ "ssa" => profileIL := ProfileSSA
+ | "xml" => profileIL := ProfileXML
+ | _ => usage (concat ["invalid -profile-il arg: ", s]))),
(Normal, "profile-stack", " {false|true}",
"profile the stack",
boolRef profileStack),
1.19 +18 -13 mlton/mlton/ssa/analyze.fun
Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- analyze.fun 2 Jan 2003 17:45:20 -0000 1.18
+++ analyze.fun 10 Jan 2003 18:36:13 -0000 1.19
@@ -20,9 +20,11 @@
select, tuple, useFromTypeOnBinds} =
let
val unit = fromType Type.unit
- fun coerces (from, to) =
- Vector.foreach2 (from, to, fn (from, to) =>
- coerce {from = from, to = to})
+ fun coerces (msg, from, to) =
+ if Vector.length from = Vector.length to
+ then Vector.foreach2 (from, to, fn (from, to) =>
+ coerce {from = from, to = to})
+ else Error.bug (concat ["coerces length mismatch: ", msg])
val {get = value: Var.t -> 'a, set = setValue, ...} =
Property.getSetOnce
(Var.plist,
@@ -60,7 +62,7 @@
shouldRaises: 'a vector option): unit =
(case t of
Arith {prim, args, overflow, success, ty} =>
- (coerces (Vector.new0 (), labelValues overflow)
+ (coerces ("arith", Vector.new0 (), labelValues overflow)
; coerce {from = primApp {prim = prim,
targs = Vector.new0 (),
args = values args,
@@ -71,14 +73,14 @@
| Call {func = f, args, return, ...} =>
let
val {args = formals, raises, returns} = func f
- val _ = coerces (values args, formals)
+ val _ = coerces ("formals", values args, formals)
fun noHandler () =
case (raises, shouldRaises) of
(NONE, NONE) => ()
| (NONE, SOME _) => ()
| (SOME _, NONE) =>
Error.bug "raise mismatch"
- | (SOME vs, SOME vs') => coerces (vs, vs')
+ | (SOME vs, SOME vs') => coerces ("noHandler", vs, vs')
datatype z = datatype Return.t
in
case return of
@@ -88,7 +90,7 @@
else ()
| NonTail {cont, handler} =>
(Option.app (returns, fn vs =>
- coerces (vs, labelValues cont))
+ coerces ("returns", vs, labelValues cont))
; (case handler of
Handler.Caller => noHandler ()
| Handler.Dead =>
@@ -100,7 +102,9 @@
val _ =
case raises of
NONE => ()
- | SOME vs => coerces (vs, labelValues h)
+ | SOME vs =>
+ coerces ("handle", vs,
+ labelValues h)
in
()
end))
@@ -113,7 +117,8 @@
| (NONE, SOME _) => ()
| (SOME _, NONE) =>
Error.bug "return mismatch at Tail"
- | (SOME vs, SOME vs') => coerces (vs, vs')
+ | (SOME vs, SOME vs') =>
+ coerces ("tail", vs, vs')
in
()
end
@@ -142,15 +147,15 @@
val _ = Option.app (default, ensureNullary)
in ()
end
- | Goto {dst, args} => coerces (values args, labelValues dst)
+ | Goto {dst, args} => coerces ("goto", values args, labelValues dst)
| Raise xs =>
(case shouldRaises of
NONE => raise Fail "raise mismatch at raise"
- | SOME vs => coerces (values xs, vs))
+ | SOME vs => coerces ("raise", values xs, vs))
| Return xs =>
(case shouldReturns of
NONE => raise Fail "return mismatch at return"
- | SOME vs => coerces (values xs, vs))
+ | SOME vs => coerces ("return", values xs, vs))
| Runtime {prim, args, return} =>
let
val xts = labelArgs return
@@ -230,7 +235,7 @@
(case exn of
Fail msg => msg
| _ => "")])
- val _ = coerces (Vector.new0 (), #args (func main))
+ val _ = coerces ("main", Vector.new0 (), #args (func main))
val _ = Vector.foreach (globals, loopStatement)
val _ =
List.foreach
1.12 +4 -0 mlton/mlton/ssa/direct-exp.fun
Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- direct-exp.fun 2 Jan 2003 17:45:20 -0000 1.11
+++ direct-exp.fun 10 Jan 2003 18:36:13 -0000 1.12
@@ -47,6 +47,7 @@
targs: Type.t vector,
args: t vector,
ty: Type.t}
+ | Profile of ProfileExp.t
| Raise of t
| Runtime of {args: t vector,
prim: Prim.t,
@@ -77,6 +78,7 @@
val handlee = Handle
val lett = Let
val name = Name
+val profile = Profile
val raisee = Raise
val select = Select
val seq = Seq
@@ -186,6 +188,7 @@
| Name _ => str "Name"
| PrimApp {prim, targs, args, ty} =>
Prim.layoutApp (prim, args, layout)
+ | Profile e => ProfileExp.layout e
| Raise e => seq [str "raise ", layout e]
| Runtime {args, prim, ...} =>
Prim.layoutApp (prim, args, layout)
@@ -532,6 +535,7 @@
Cont.sendExp (k, ty, Exp.PrimApp {prim = prim,
targs = targs,
args = xs}))
+ | Profile e => Cont.sendExp (k, Type.unit, Exp.Profile e)
| Raise e =>
loopf (e, h, fn (x, _) =>
{statements = [],
1.11 +2 -1 mlton/mlton/ssa/direct-exp.sig
Index: direct-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- direct-exp.sig 2 Jan 2003 17:45:20 -0000 1.10
+++ direct-exp.sig 10 Jan 2003 18:36:13 -0000 1.11
@@ -71,7 +71,8 @@
val primApp: {args: t vector,
prim: Prim.t,
targs: Type.t vector,
- ty: Type.t} -> t
+ ty: Type.t} -> t
+ val profile: ProfileExp.t -> t
val raisee: t -> t
val select: {tuple: t,
offset: int,
1.5 +10 -1 mlton/mlton/ssa/flat-lattice.fun
Index: flat-lattice.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flat-lattice.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- flat-lattice.fun 16 Apr 2002 12:10:53 -0000 1.4
+++ flat-lattice.fun 10 Jan 2003 18:36:13 -0000 1.5
@@ -37,7 +37,7 @@
fun new () = T {lessThan = ref [],
upperBound = ref NONE,
value = ref Bottom}
-
+
val isBottom =
fn (T {value = ref Bottom, ...}) => true
| _ => false
@@ -51,6 +51,11 @@
fn (T {value = ref Top, ...}) => true
| _ => false
+fun forceTop (T {upperBound, value, ...}): bool =
+ if isSome (!upperBound)
+ then false
+ else (value := Top; true)
+
fun up (T {lessThan, upperBound, value, ...}, e: Elt.t): bool =
let
fun continue e = List.forall (!lessThan, fn z => up (z, e))
@@ -76,6 +81,10 @@
fn (T {lessThan, value, ...}, e) =>
(List.push (lessThan, e)
; up (e, !value))
+
+val op <= =
+ Trace.trace2 ("FlatLattice.<=", layout, layout, Bool.layout)
+ (op <=)
fun lowerBound (e, p): bool = up (e, Point p)
1.4 +1 -0 mlton/mlton/ssa/flat-lattice.sig
Index: flat-lattice.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flat-lattice.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- flat-lattice.sig 16 Apr 2002 12:10:53 -0000 1.3
+++ flat-lattice.sig 10 Jan 2003 18:36:13 -0000 1.4
@@ -24,6 +24,7 @@
val <= : t * t -> bool
val forcePoint: t * Point.t -> bool
+ val forceTop: t -> bool
val layout: t -> Layout.t
val lowerBound: t * Point.t -> bool
val new: unit -> t
1.12 +8 -6 mlton/mlton/ssa/flatten.fun
Index: flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flatten.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- flatten.fun 2 Jan 2003 17:45:20 -0000 1.11
+++ flatten.fun 10 Jan 2003 18:36:13 -0000 1.12
@@ -123,8 +123,11 @@
fun doitStatement (Statement.T {var, ty, exp}) =
case exp of
- Tuple xs => setVarInfo (valOf var, {rep = Rep.new (),
- tuple = ref (SOME xs)})
+ Tuple xs =>
+ Option.app
+ (var, fn var =>
+ setVarInfo (var, {rep = Rep.new (),
+ tuple = ref (SOME xs)}))
| ConApp {con, args} => coerces (args, conArgs con)
| Var x => setVarInfo (valOf var, varInfo x)
| _ => ()
@@ -384,12 +387,9 @@
cases = Cases.Con cases,
default = default}
end
-
fun doitTransfer transfer =
case transfer of
- Return xs => Return (flattens (xs, valOf returnsReps))
- | Raise xs => Raise (flattens (xs, valOf raisesReps))
- | Call {func, args, return} =>
+ Call {func, args, return} =>
Call {func = func,
args = flattens (args, funcArgs func),
return = return}
@@ -400,6 +400,8 @@
| Goto {dst, args} =>
Goto {dst = dst,
args = flattens (args, labelArgs dst)}
+ | Raise xs => Raise (flattens (xs, valOf raisesReps))
+ | Return xs => Return (flattens (xs, valOf returnsReps))
| _ => transfer
fun doitBlock (Block.T {label, args, statements, transfer}) =
1.27 +123 -79 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- shrink.fun 2 Jan 2003 17:45:21 -0000 1.26
+++ shrink.fun 10 Jan 2003 18:36:13 -0000 1.27
@@ -137,8 +137,10 @@
default: Label.t option}
| Goto of {dst: t,
args: Positions.t}
- | Raise of Positions.t
- | Return of Positions.t
+ | Raise of {args: Positions.t,
+ canMove: Statement.t list}
+ | Return of {args: Positions.t,
+ canMove: Statement.t list}
local
fun make f (T r) = f r
@@ -160,11 +162,11 @@
| Goto {dst, args} =>
seq [str "Goto ",
tuple [layout dst, Positions.layout args]]
- | Raise ps => seq [str "Raise ", Positions.layout ps]
- | Return ps => seq [str "Return ", Positions.layout ps]]
+ | Raise {args, ...} =>
+ seq [str "Raise ", Positions.layout args]
+ | Return {args, ...} =>
+ seq [str "Return ", Positions.layout args]]
end
-
-
end
structure State =
@@ -312,9 +314,9 @@
let
val block as Block.T {label, args, statements, transfer, ...} =
Vector.sub (blocks, i)
- val _ = Vector.foreach
- (args, fn (x, ty) =>
- setVarInfo (x, VarInfo.new (x, SOME ty)))
+ val _ =
+ Vector.foreach (args, fn (x, ty) =>
+ setVarInfo (x, VarInfo.new (x, SOME ty)))
val _ =
Vector.foreach
(statements, fn s => Exp.foreachVar (Statement.exp s, incVar))
@@ -337,6 +339,32 @@
blockIndex = i,
label = Block.label (Vector.sub (blocks, i))}
fun normal () = doit LabelMeaning.Block
+ fun rr (xs: Var.t vector, make) =
+ let
+ val _ = incVars xs
+ val n = Vector.length statements
+ fun loop (i, ac) =
+ if i = n
+ then
+ if 0 = Vector.length xs
+ orelse 0 < Vector.length args
+ then doit (make {args = extract xs,
+ canMove = rev ac})
+ else normal ()
+ else
+ let
+ val s as Statement.T {exp, ...} =
+ Vector.sub (statements, i)
+ in
+ if (case exp of
+ Exp.Profile _ => true
+ | _ => false)
+ then loop (i + 1, s :: ac)
+ else normal ()
+ end
+ in
+ loop (0, [])
+ end
in
case transfer of
Arith {args, overflow, success, ...} =>
@@ -435,34 +463,20 @@
| Goto {dst, args} =>
Goto {dst = dst,
args = extract args}
- | Raise ps => Raise (extract ps)
- | Return ps => Return (extract ps)
+ | Raise {args, canMove} =>
+ Raise {args = extract args,
+ canMove = canMove}
+ | Return {args, canMove} =>
+ Return {args = extract args,
+ canMove = canMove}
in
doit a
end
end
end
- | Raise xs =>
- let
- val _ = incVars xs
- in
- if 0 = Vector.length statements
- andalso (0 = Vector.length xs
- orelse 0 < Vector.length args)
- then doit (LabelMeaning.Raise (extract xs))
- else normal ()
- end
- | Return xs =>
- let
- val _ = incVars xs
- in
- if 0 = Vector.length statements
- andalso (0 = Vector.length xs
- orelse 0 < Vector.length args)
- then doit (LabelMeaning.Return (extract xs))
- else normal ()
- end
- | Runtime {args, return, ...} =>
+ | Raise xs => rr (xs, LabelMeaning.Raise)
+ | Return xs => rr (xs, LabelMeaning.Return)
+ | Runtime {args, return, ...} =>
(incVars args
; incLabel return
; normal ())
@@ -476,6 +490,10 @@
Trace.trace ("Shrink.indexMeaning", Int.layout, LabelMeaning.layout)
indexMeaning
val labelMeaning = indexMeaning o labelIndex
+ val labelMeaning =
+ Trace.trace ("Shrink.labelMeaning",
+ Label.layout, LabelMeaning.layout)
+ labelMeaning
val labelIndex' = labelIndex
val labelIndex = LabelMeaning.blockIndex o labelMeaning
fun meaningLabel m =
@@ -703,6 +721,9 @@
| Position.Free x => x)
val (statements, transfer) =
let
+ fun rr ({args, canMove}, make) =
+ (canMove,
+ make (Vector.map (args, use o extract)))
datatype z = datatype LabelMeaning.aux
in
case aux of
@@ -711,12 +732,8 @@
| Case _ => simplifyBlock block
| Goto {dst, args} =>
gotoMeaning (dst, Vector.map (args, extract))
- | Raise ps =>
- ([],
- Transfer.Raise (Vector.map (ps, use o extract)))
- | Return ps =>
- ([],
- Transfer.Return (Vector.map (ps, use o extract)))
+ | Raise z => rr (z, Transfer.Raise)
+ | Return z => rr (z, Transfer.Return)
end
val _ =
List.push
@@ -791,34 +808,25 @@
| Bug => ([], Bug)
| Call {func, args, return} =>
let
- val return =
+ val (statements, return) =
case return of
Return.NonTail {cont, handler} =>
let
+ fun isEta (m: LabelMeaning.t,
+ ps: Position.t vector): bool =
+ Vector.length ps
+ = (Vector.length
+ (Block.args
+ (Vector.sub
+ (blocks, LabelMeaning.blockIndex m))))
+ andalso
+ Vector.foralli
+ (ps,
+ fn (i, Position.Formal i') => i = i'
+ | _ => false)
val m = labelMeaning cont
val i = LabelMeaning.blockIndex m
- val isTail =
- (case handler of
- Handler.Caller => true
- | Handler.Dead => true
- | Handler.Handle _ => false)
- andalso
- (case LabelMeaning.aux m of
- LabelMeaning.Bug => true
- | LabelMeaning.Return ps =>
- Vector.length ps =
- (Vector.length
- (Block.args (Vector.sub (blocks, i))))
- andalso
- Vector.foralli
- (ps,
- fn (i, Position.Formal i') => i = i'
- | _ => false)
- | _ => false)
- in
- if isTail
- then (deleteLabelMeaning m; Return.Tail)
- else
+ fun nonTail () =
let
val _ = forceMeaningBlock m
val handler =
@@ -831,15 +839,48 @@
meaningLabel m
end)
in
- Return.NonTail {cont = meaningLabel m,
- handler = handler}
+ ([],
+ Return.NonTail {cont = meaningLabel m,
+ handler = handler})
end
+ fun tail statements =
+ (deleteLabelMeaning m
+ ; (statements, Return.Tail))
+ fun cont (handlerIsEta: bool) =
+ case LabelMeaning.aux m of
+ LabelMeaning.Bug =>
+ if handlerIsEta
+ then nonTail ()
+ else tail []
+ | LabelMeaning.Return {args, canMove} =>
+ if isEta (m, args)
+ then tail canMove
+ else nonTail ()
+ | _ => nonTail ()
+
+ in
+ case handler of
+ Handler.Caller => cont false
+ | Handler.Dead => cont false
+ | Handler.Handle l =>
+ let
+ val m = labelMeaning l
+ in
+ case LabelMeaning.aux m of
+ LabelMeaning.Bug => cont false
+ | LabelMeaning.Raise {args, ...} =>
+ if isEta (m, args)
+ then cont true
+ else nonTail ()
+ | _ => nonTail ()
+ end
end
- | _ => return
+ | _ => ([], return)
in
- ([], Call {func = func,
- args = simplifyVars args,
- return = return})
+ (statements,
+ Call {func = func,
+ args = simplifyVars args,
+ return = return})
end
| Case {test, cases, default} =>
let
@@ -905,9 +946,13 @@
(Vector.sub (blocks, i)))
| Bug => false
| Goto {args, ...} => Positions.usesFormal args
- | Raise ps => Positions.usesFormal ps
- | Return ps => Positions.usesFormal ps
+ | Raise {args, ...} => Positions.usesFormal args
+ | Return {args, ...} => Positions.usesFormal args
| _ => true
+ fun rr ({args = a, canMove = c},
+ {args = a', canMove = c'}) =
+ Positions.equals (a, a')
+ andalso List.equals (c, c', Statement.equals)
fun equals (m: t, m': t): bool =
case (aux m, aux m') of
(Block, Block) => blockIndex m = blockIndex m'
@@ -916,8 +961,8 @@
Goto {dst = dst', args = args'}) =>
equals (dst, dst')
andalso Positions.equals (args, args')
- | (Raise ps, Raise ps') => Positions.equals (ps, ps')
- | (Return ps, Return ps') => Positions.equals (ps, ps')
+ | (Raise z, Raise z') => rr (z, z')
+ | (Return z, Return z') => rr (z, z')
| _ => false
end
fun isOk (l: Label.t): bool =
@@ -1033,6 +1078,8 @@
case p of
Position.Formal n => Vector.sub (args, n)
| Position.Free x => varInfo x
+ fun rr ({args, canMove}, make) =
+ (canMove, make (Vector.map (args, use o extract)))
datatype z = datatype LabelMeaning.aux
in
case aux of
@@ -1059,10 +1106,8 @@
in
gotoMeaning (dst, Vector.map (args, extract))
end
- | Raise ps =>
- ([], Transfer.Raise (Vector.map (ps, use o extract)))
- | Return ps =>
- ([], Transfer.Return (Vector.map (ps, use o extract)))
+ | Raise z => rr (z, Transfer.Raise)
+ | Return z => rr (z, Transfer.Return)
end) arg
and evalStatement arg : Statement.t list -> Statement.t list =
traceEvalStatement
@@ -1208,7 +1253,8 @@
case DynamicWind.withEscape
(fn escape =>
Vector.foldri
- (xs, NONE, fn (i, VarInfo.T {value, ...}, tuple') =>
+ (xs, NONE,
+ fn (i, VarInfo.T {value, ...}, tuple') =>
case !value of
SOME (Value.Select {offset, tuple}) =>
if offset = i
@@ -1316,9 +1362,7 @@
end
val traceShrinkFunction =
- Trace.trace ("Shrink.shrinkFunction",
- Func.layout o Function.name,
- Func.layout o Function.name)
+ Trace.trace ("Shrink.shrinkFunction", Function.layout, Function.layout)
val shrinkFunction =
fn g =>
1.32 +0 -5 mlton/mlton/ssa/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/sources.cm,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- sources.cm 2 Jan 2003 17:45:21 -0000 1.31
+++ sources.cm 10 Jan 2003 18:36:14 -0000 1.32
@@ -8,9 +8,7 @@
Group
signature HANDLER
-signature PROFILE_EXP
signature RETURN
-signature SOURCE_INFO
signature SSA
functor FlatLattice
@@ -60,7 +58,6 @@
n-point-lattice.sig
poly-equal.fun
poly-equal.sig
-profile-exp.sig
redundant.fun
redundant.sig
redundant-tests.fun
@@ -75,8 +72,6 @@
simplify.sig
simplify-types.fun
simplify-types.sig
-source-info.fun
-source-info.sig
ssa-tree.fun
ssa-tree.sig
ssa.fun
1.52 +28 -38 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- ssa-tree.fun 2 Jan 2003 17:45:21 -0000 1.51
+++ ssa-tree.fun 10 Jan 2003 18:36:14 -0000 1.52
@@ -10,8 +10,6 @@
open S
-structure SourceInfo = SourceInfo ()
-
structure Type =
struct
local structure T = HashType (S)
@@ -148,36 +146,6 @@
xs)
end
-structure ProfileExp =
- struct
- structure SourceInfo = SourceInfo
-
- datatype t =
- Enter of SourceInfo.t
- | Leave of SourceInfo.t
-
- val toString =
- fn Enter si => concat ["Enter ", SourceInfo.toString si]
- | Leave si => concat ["Leave " , SourceInfo.toString si]
-
- val layout = Layout.str o toString
-
- val equals =
- fn (Enter si, Enter si') => SourceInfo.equals (si, si')
- | (Leave si, Leave si') => SourceInfo.equals (si, si')
- | _ => false
-
- local
- val newHash = Random.word
- val enter = newHash ()
- val leave = newHash ()
- in
- val hash =
- fn Enter si => Word.xorb (enter, SourceInfo.hash si)
- | Leave si => Word.xorb (leave, SourceInfo.hash si)
- end
- end
-
structure Exp =
struct
datatype t =
@@ -393,14 +361,31 @@
val toString = Layout.toString o layout
+ fun equals (T {exp = e, ty = t, var = v},
+ T {exp = e', ty = t', var = v'}): bool =
+ Option.equals (v, v', Var.equals)
+ andalso Type.equals (t, t')
+ andalso Exp.equals (e, e')
+
+ local
+ fun make f x =
+ T {var = NONE,
+ ty = Type.unit,
+ exp = f x}
+ in
+ val profile = make Exp.Profile
+ end
+
local
- fun make (e: Exp.t) =
+ fun make f x =
T {var = NONE,
ty = Type.unit,
- exp = e}
+ exp = if !Control.handlers = Control.PushPop
+ then f x
+ else Exp.unit}
in
- fun handlerPop h = make (Exp.HandlerPop h)
- fun handlerPush h = make (Exp.HandlerPush h)
+ val handlerPop = make Exp.HandlerPop
+ val handlerPush = make Exp.HandlerPush
end
fun clear s = Option.app (var s, Var.clear)
@@ -1395,6 +1380,7 @@
fun profile (f: t, sourceInfo): t =
if !Control.profile = Control.ProfileNone
+ orelse !Control.profileIL <> Control.ProfileSSA
then f
else
let
@@ -1453,8 +1439,8 @@
let
val xs = Vector.map (ts, fn _ => Var.newNoname ())
val l = Label.newNoname ()
- val pop = make (HandlerPop l)
- val push = make (HandlerPush l)
+ val pop = Statement.handlerPop l
+ val push = Statement.handlerPush l
val _ =
List.push
(extraBlocks,
@@ -1523,6 +1509,10 @@
in
f
end
+
+ val profile =
+ Trace.trace2 ("Ssa.Function.profile", layout, SourceInfo.layout, layout)
+ profile
end
structure Program =
1.43 +2 -4 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- ssa-tree.sig 2 Jan 2003 17:45:21 -0000 1.42
+++ ssa-tree.sig 10 Jan 2003 18:36:14 -0000 1.43
@@ -56,8 +56,6 @@
sig
include SSA_TREE_STRUCTS
- structure SourceInfo: SOURCE_INFO
-
structure Type:
sig
include HASH_TYPE
@@ -85,8 +83,6 @@
structure Func: HASH_ID
structure Label: LABEL
- structure ProfileExp: PROFILE_EXP
- sharing SourceInfo = ProfileExp.SourceInfo
structure Exp:
sig
@@ -128,11 +124,13 @@
exp: Exp.t}
val clear: t -> unit (* clear the var *)
+ val equals: t * t -> bool
val exp: t -> Exp.t
val handlerPop: Label.t -> t
val handlerPush: Label.t -> t
val layout: t -> Layout.t
val prettifyGlobals: t vector -> (Var.t -> string option)
+ val profile: ProfileExp.t -> t
val var: t -> Var.t option
end
1.21 +25 -1 mlton/mlton/ssa/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- type-check.fun 2 Jan 2003 17:45:21 -0000 1.20
+++ type-check.fun 10 Jan 2003 18:36:15 -0000 1.21
@@ -307,7 +307,7 @@
end
end
-fun checkHandlers (program as Program.T {datatypes, functions, ...}): unit =
+fun checkHandlers (program as Program.T {functions, ...}): unit =
let
fun checkFunction (f: Function.t): unit =
let
@@ -425,6 +425,30 @@
in
()
end
+
+val checkHandlers =
+ fn p =>
+ if !Control.handlers = Control.PushPop
+ then checkHandlers p
+ else let
+ val Program.T {functions, ...} = p
+ in
+ List.foreach (functions, fn f =>
+ let
+ val {blocks, ...} = Function.dest f
+ in
+ Vector.foreach
+ (blocks, fn Block.T {statements, ...} =>
+ Vector.foreach
+ (statements, fn Statement.T {exp, ...} =>
+ if (case exp of
+ Exp.HandlerPop _ => true
+ | Exp.HandlerPush _ => true
+ | _ => false)
+ then Error.bug "superfluous HandlerPush/Pop"
+ else ()))
+ end)
+ end
val checkHandlers = Control.trace (Control.Pass, "checkHandlers") checkHandlers
1.18 +46 -19 mlton/mlton/type-inference/infer.fun
Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- infer.fun 12 Dec 2002 01:14:23 -0000 1.17
+++ infer.fun 10 Jan 2003 18:36:15 -0000 1.18
@@ -527,6 +527,7 @@
{tuple = Xexp.monoVar (arg, argType),
components = vars,
body = e}),
+ bodyType = caseType,
region = region})}
fun finish rename =
Xexp.app
@@ -645,6 +646,7 @@
resultType))]),
caseType = resultType,
region = region})),
+ bodyType = resultType,
region = region}
end
fun forceRulesMatch (rs, region) =
@@ -891,9 +893,28 @@
{tyvars = bound (),
decs = (Vector.map
(decs, fn {var, region, rules, ty} =>
- {var = var,
- ty = Type.toXml (ty, region),
- lambda = forceRulesMatch (rules, region)}))}]),
+ let
+ val {arg, argType, body, bodyType,
+ ...} =
+ Xlambda.dest
+ (forceRulesMatch (rules, region))
+ val body =
+ Xml.Exp.enterLeave
+ (body,
+ bodyType,
+ SourceInfo.fromRegion region)
+ val lambda =
+ Xlambda.new
+ {arg = arg,
+ argType = argType,
+ body = body,
+ bodyType = bodyType,
+ region = region}
+ in
+ {var = var,
+ ty = Type.toXml (ty, region),
+ lambda = lambda}
+ end))}]),
env)
end
| Cdec.Overload {var, scheme = CoreML.Scheme.T {tyvars, ty}, ovlds} =>
@@ -923,7 +944,6 @@
(*------------------------------------*)
(* inferExp *)
(*------------------------------------*)
-
and inferExp arg: expCode =
traceInferExp
(fn (e, env) =>
@@ -977,18 +997,22 @@
let
val rs as {argType, resultType, rules, ...} =
inferMatch (m, env)
- in (fn () =>
+ in
+ (fn () =>
let
val {arg, argType, body, ...} =
Xlambda.dest (forceRulesMatch (rs, region))
val resultType = Type.toXml (resultType, region)
+ val body =
+ Xml.Exp.enterLeave (body,
+ resultType,
+ SourceInfo.fromRegion region)
in
- Xexp.lambda
- {arg = arg,
- argType = argType,
- body = Xexp.fromExp (body, resultType),
- bodyType = resultType,
- region = region}
+ Xexp.lambda {arg = arg,
+ argType = argType,
+ body = Xexp.fromExp (body, resultType),
+ bodyType = resultType,
+ region = region}
end,
Type.arrow (argType, resultType),
region)
@@ -1093,7 +1117,15 @@
end
in
case Cexp.node e1 of
- Cexp.Con con =>
+ Cexp.App (e1, e2) =>
+ let
+ val e = apply (e1, env, SOME (inferExp (e2, env)))
+ in
+ case arg of
+ NONE => e
+ | SOME e' => applyOne (e, e')
+ end
+ | Cexp.Con con =>
let
val {instance, args} = instCon con
in
@@ -1117,7 +1149,8 @@
let
val {instance, args = targs} =
instantiatePrim (Prim.scheme prim, region)
- in eta (instance, fn (arg, resultType) =>
+ in
+ eta (instance, fn (arg, resultType) =>
let
fun constant c =
let
@@ -1161,12 +1194,6 @@
(* FIXME -- should use Control.error? *)
Error.bug "primApp mismatch"
end)
- end
- | Cexp.App (e1, e2) =>
- let val e = apply (e1, env, SOME (inferExp (e2, env)))
- in case arg of
- NONE => e
- | SOME e' => applyOne (e, e')
end
| _ =>
let val e1 = inferExp (e1, env)
1.6 +132 -130 mlton/mlton/xml/implement-exceptions.fun
Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- implement-exceptions.fun 12 Dec 2002 01:14:23 -0000 1.5
+++ implement-exceptions.fun 10 Jan 2003 18:36:15 -0000 1.6
@@ -289,143 +289,144 @@
fun makeExp e = Dexp.vall {var = var, exp = e}
in
case exp of
- Lambda l => primExp (Lambda (loopLambda l))
- | PrimApp {prim, targs, args} =>
- let
- datatype z = datatype Prim.Name.t
- fun assign (var, ty) =
- primExp
- (PrimApp {prim = Prim.assign,
- targs = Vector.new1 ty,
- args = Vector.new2 (VarExp.mono var,
- Vector.sub (args, 0))})
- in
- case Prim.name prim of
- Exn_extra => makeExp (extra (VarExp.var
- (Vector.sub (args, 0))))
- | Exn_name =>
- primExp (App {func = VarExp.mono exnName,
- arg = Vector.sub (args, 0)})
- | Exn_setExtendExtra => []
- | Exn_setInitExtra => []
- | Exn_setTopLevelHandler =>
- assign (topLevelHandler,
- Type.arrow (Type.exn, Type.unit))
- | _ => primExp exp
- end
- | ConApp {con, arg, ...} =>
- (case exconInfo con of
- NONE => keep ()
- | SOME {make, ...} => makeExp (make arg))
- | Handle {try, catch = (catch, ty), handler} =>
- primExp (Handle {try = loop try,
- catch = (catch, ty),
- handler = loop handler})
- | Case {test, cases, default} =>
- let
- fun normal () =
- primExp (Case {cases = Cases.map (cases, loop),
- default = Option.map (default, fn (e, r) =>
- (loop e, r)),
- test = test})
- in
- case cases of
- Cases.Con cases =>
- if Vector.isEmpty cases
- then normal ()
- else
- let
- val (Pat.T {con, ...}, _) = Vector.sub (cases, 0)
- in
- if not (isExcon con)
- then normal ()
- else (* convert to an exception match *)
- let
- open Dexp
- val defaultVar = Var.newString "default"
- fun callDefault () =
- app {func = monoVar (defaultVar,
- Type.arrow (Type.unit, ty)),
- arg = unit (),
- ty = ty}
- val unit = Var.newString "unit"
- val (body, region) =
- case default of
- NONE =>
- Error.bug "no default for exception case"
- | SOME (e, r) =>
- (fromExp (loop e, ty), r)
- val decs =
- vall
- {var = defaultVar,
- exp = lambda {arg = unit,
- argType = Type.unit,
- bodyType = ty,
- body = body,
- region = region}}
- in makeExp
- (lett
- {decs = decs,
- body =
- extract
- (VarExp.var test, ty, fn tuple =>
- casee
- {test = extractSum tuple,
- ty = ty,
- default = SOME (callDefault (), region),
- cases =
- Cases.Con
- (Vector.map
- (cases, fn (Pat.T {con, arg, ...}, e) =>
- let
- val refVar = Var.newNoname ()
- val body =
- iff {test =
- equal
- (monoVar
- (refVar, Type.unitRef),
- monoVar
- (#refVar (valOf (exconInfo con)),
- Type.unitRef)),
- ty = ty,
- thenn = fromExp (loop e, ty),
- elsee = callDefault ()}
- fun make (arg, body) =
- (Pat.T {con = con,
- targs = Vector.new0 (),
- arg = SOME arg},
- body)
- in case arg of
- NONE => make ((refVar, Type.unitRef), body)
- | SOME (x, t) =>
- let
- val tuple =
- (Var.newNoname (),
- Type.tuple (Vector.new2
- (Type.unitRef, t)))
- in make (tuple,
- detupleBind
- {tuple = monoVar tuple,
- components =
- Vector.new2 (refVar, x),
- body = body})
- end
- end))})})
- end
- end
- | _ => normal ()
- end
- | Raise {exn, filePos} =>
- raisee {var = var, ty = ty, exn = exn, filePos = filePos}
- | _ => keep ()
+ Case {test, cases, default} =>
+ let
+ fun normal () =
+ primExp (Case {cases = Cases.map (cases, loop),
+ default = Option.map (default, fn (e, r) =>
+ (loop e, r)),
+ test = test})
+ in
+ case cases of
+ Cases.Con cases =>
+ if Vector.isEmpty cases
+ then normal ()
+ else
+ let
+ val (Pat.T {con, ...}, _) = Vector.sub (cases, 0)
+ in
+ if not (isExcon con)
+ then normal ()
+ else (* convert to an exception match *)
+ let
+ open Dexp
+ val defaultVar = Var.newString "default"
+ fun callDefault () =
+ app {func = monoVar (defaultVar,
+ Type.arrow (Type.unit, ty)),
+ arg = unit (),
+ ty = ty}
+ val unit = Var.newString "unit"
+ val (body, region) =
+ case default of
+ NONE =>
+ Error.bug "no default for exception case"
+ | SOME (e, r) =>
+ (fromExp (loop e, ty), r)
+ val decs =
+ vall
+ {var = defaultVar,
+ exp = lambda {arg = unit,
+ argType = Type.unit,
+ bodyType = ty,
+ body = body,
+ region = region}}
+ in makeExp
+ (lett
+ {decs = decs,
+ body =
+ extract
+ (VarExp.var test, ty, fn tuple =>
+ casee
+ {test = extractSum tuple,
+ ty = ty,
+ default = SOME (callDefault (), region),
+ cases =
+ Cases.Con
+ (Vector.map
+ (cases, fn (Pat.T {con, arg, ...}, e) =>
+ let
+ val refVar = Var.newNoname ()
+ val body =
+ iff {test =
+ equal
+ (monoVar
+ (refVar, Type.unitRef),
+ monoVar
+ (#refVar (valOf (exconInfo con)),
+ Type.unitRef)),
+ ty = ty,
+ thenn = fromExp (loop e, ty),
+ elsee = callDefault ()}
+ fun make (arg, body) =
+ (Pat.T {con = con,
+ targs = Vector.new0 (),
+ arg = SOME arg},
+ body)
+ in case arg of
+ NONE => make ((refVar, Type.unitRef), body)
+ | SOME (x, t) =>
+ let
+ val tuple =
+ (Var.newNoname (),
+ Type.tuple (Vector.new2
+ (Type.unitRef, t)))
+ in make (tuple,
+ detupleBind
+ {tuple = monoVar tuple,
+ components =
+ Vector.new2 (refVar, x),
+ body = body})
+ end
+ end))})})
+ end
+ end
+ | _ => normal ()
+ end
+ | ConApp {con, arg, ...} =>
+ (case exconInfo con of
+ NONE => keep ()
+ | SOME {make, ...} => makeExp (make arg))
+ | Handle {try, catch = (catch, ty), handler} =>
+ primExp (Handle {try = loop try,
+ catch = (catch, ty),
+ handler = loop handler})
+ | Lambda l => primExp (Lambda (loopLambda l))
+ | PrimApp {prim, targs, args} =>
+ let
+ datatype z = datatype Prim.Name.t
+ fun assign (var, ty) =
+ primExp
+ (PrimApp {prim = Prim.assign,
+ targs = Vector.new1 ty,
+ args = Vector.new2 (VarExp.mono var,
+ Vector.sub (args, 0))})
+ in
+ case Prim.name prim of
+ Exn_extra => makeExp (extra (VarExp.var
+ (Vector.sub (args, 0))))
+ | Exn_name =>
+ primExp (App {func = VarExp.mono exnName,
+ arg = Vector.sub (args, 0)})
+ | Exn_setExtendExtra => primExp (Tuple (Vector.new0 ()))
+ | Exn_setInitExtra => primExp (Tuple (Vector.new0 ()))
+ | Exn_setTopLevelHandler =>
+ assign (topLevelHandler,
+ Type.arrow (Type.exn, Type.unit))
+ | _ => primExp exp
+ end
+ | Raise {exn, filePos} =>
+ raisee {var = var, ty = ty, exn = exn, filePos = filePos}
+ | _ => keep ()
end
and loopLambda l =
let
- val {arg, argType, body, region} = Lambda.dest l
+ val {arg, argType, body, bodyType, region} = Lambda.dest l
in
Lambda.new {arg = arg,
argType = argType,
body = loop body,
+ bodyType = bodyType,
region = region}
end
val body =
@@ -500,6 +501,7 @@
default = NONE,
ty = Type.string}))
end,
+ bodyType = Type.string,
region = Region.bogus})
end}
in
1.7 +26 -24 mlton/mlton/xml/monomorphise.fun
Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- monomorphise.fun 12 Dec 2002 01:14:23 -0000 1.6
+++ monomorphise.fun 10 Jan 2003 18:36:15 -0000 1.7
@@ -355,30 +355,8 @@
end) arg
and monoPrimExp (e: XprimExp.t): SprimExp.t =
case e of
- XprimExp.Const c => SprimExp.Const c
- | XprimExp.Var x => SprimExp.Var (monoVarExp x)
- | XprimExp.Tuple xs => SprimExp.Tuple (monoVarExps xs)
- | XprimExp.Select {tuple, offset} =>
- SprimExp.Select {tuple = monoVarExp tuple, offset = offset}
- | XprimExp.Lambda l => SprimExp.Lambda (monoLambda l)
- | XprimExp.ConApp {con, targs, arg} =>
- let val con = monoCon (con, targs)
- in SprimExp.ConApp {con = con, targs = Vector.new0 (),
- arg = Option.map (arg, monoVarExp)}
- end
- | XprimExp.PrimApp {prim, targs, args} =>
- SprimExp.PrimApp {prim = prim,
- targs = monoTypes targs,
- args = monoVarExps args}
- | XprimExp.App {func, arg} =>
+ XprimExp.App {func, arg} =>
SprimExp.App {func = monoVarExp func, arg = monoVarExp arg}
- | XprimExp.Raise {exn, filePos} =>
- SprimExp.Raise {exn = monoVarExp exn,
- filePos = filePos}
- | XprimExp.Handle {try, catch, handler} =>
- SprimExp.Handle {try = monoExp try,
- catch = renameMono catch,
- handler = monoExp handler}
| XprimExp.Case {test, cases, default} =>
let
fun doit cases =
@@ -399,14 +377,38 @@
default = Option.map (default, fn (e, r) =>
(monoExp e, r))}
end
+ | XprimExp.ConApp {con, targs, arg} =>
+ let val con = monoCon (con, targs)
+ in SprimExp.ConApp {con = con, targs = Vector.new0 (),
+ arg = Option.map (arg, monoVarExp)}
+ end
+ | XprimExp.Const c => SprimExp.Const c
+ | XprimExp.Handle {try, catch, handler} =>
+ SprimExp.Handle {try = monoExp try,
+ catch = renameMono catch,
+ handler = monoExp handler}
+ | XprimExp.Lambda l => SprimExp.Lambda (monoLambda l)
+ | XprimExp.PrimApp {prim, targs, args} =>
+ SprimExp.PrimApp {prim = prim,
+ targs = monoTypes targs,
+ args = monoVarExps args}
+ | XprimExp.Profile e => SprimExp.Profile e
+ | XprimExp.Raise {exn, filePos} =>
+ SprimExp.Raise {exn = monoVarExp exn,
+ filePos = filePos}
+ | XprimExp.Select {tuple, offset} =>
+ SprimExp.Select {tuple = monoVarExp tuple, offset = offset}
+ | XprimExp.Tuple xs => SprimExp.Tuple (monoVarExps xs)
+ | XprimExp.Var x => SprimExp.Var (monoVarExp x)
and monoLambda l: Slambda.t =
let
- val {arg, argType, body, region} = Xlambda.dest l
+ val {arg, argType, body, bodyType, region} = Xlambda.dest l
val (arg, argType) = renameMono (arg, argType)
in
Slambda.new {arg = arg,
argType = argType,
body = monoExp body,
+ bodyType = monoType bodyType,
region = region}
end
(*------------------------------------*)
1.8 +63 -49 mlton/mlton/xml/polyvariance.fun
Index: polyvariance.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/polyvariance.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- polyvariance.fun 12 Dec 2002 01:14:23 -0000 1.7
+++ polyvariance.fun 10 Jan 2003 18:36:15 -0000 1.8
@@ -14,7 +14,8 @@
struct
open S
-open Dec PrimExp
+datatype z = datatype Dec.t
+datatype z = datatype PrimExp.t
structure Type =
struct
@@ -53,16 +54,21 @@
and loopPrimExp (e: PrimExp.t, n: int): int =
case e of
Case {cases, default, ...} =>
- Cases.fold
- (cases,
- (case default of
- NONE => n
- | SOME (e, _) => loopExp (e, n)),
- fn (e, n) => loopExp (e, n))
+ let
+ val n = n + 1
+ in
+ Cases.fold
+ (cases,
+ (case default of
+ NONE => n
+ | SOME (e, _) => loopExp (e, n)),
+ fn (e, n) => loopExp (e, n))
+ end
| Handle {try, handler, ...} =>
- loopExp (try, loopExp (handler, n))
- | Lambda l => loopLambda (l, n)
- | _ => n
+ loopExp (try, loopExp (handler, n + 1))
+ | Lambda l => loopLambda (l, n + 1)
+ | Profile _ => n
+ | _ => n + 1
in loopExp (body, 0)
; size
end
@@ -122,25 +128,30 @@
let
val loopExp =
fn e => loopExp (e, numDuplicates)
- in (case exp of
- Const _ => ()
- | Var x => loopVar x
- | Tuple xs => loopVars xs
- | Select {tuple, ...} => loopVar tuple
- | ConApp {arg, ...} =>
- Option.app (arg, loopVar)
- | PrimApp {args, ...} => loopVars args
- | App {func, arg} =>
- (loopVar func; loopVar arg)
- | Raise {exn, ...} => loopVar exn
- | Case {test, cases, default} =>
- (loopVar test
- ; Cases.foreach (cases, loopExp)
- ; Option.app (default, loopExp o #1))
- | Handle {try, handler, ...} =>
- (loopExp try; loopExp handler)
- | _ => Error.bug "unexpected primExp")
- ; loopDecs decs
+ val _ =
+ case exp of
+ App {func, arg} =>
+ (loopVar func; loopVar arg)
+ | Case {test, cases, default} =>
+ (loopVar test
+ ; Cases.foreach (cases, loopExp)
+ ; (Option.app
+ (default, loopExp o #1)))
+ | ConApp {arg, ...} =>
+ Option.app (arg, loopVar)
+ | Const _ => ()
+ | Handle {try, handler, ...} =>
+ (loopExp try; loopExp handler)
+ | Lambda _ =>
+ Error.bug "unexpected Lambda"
+ | PrimApp {args, ...} => loopVars args
+ | Profile _ => ()
+ | Raise {exn, ...} => loopVar exn
+ | Select {tuple, ...} => loopVar tuple
+ | Tuple xs => loopVars xs
+ | Var x => loopVar x
+ in
+ loopDecs decs
end)
| Fun {decs = lambdas, ...} =>
let
@@ -258,11 +269,12 @@
end
and loopLambda (l: Lambda.t): Lambda.t =
let
- val {arg, argType, body, region} = Lambda.dest l
+ val {arg, argType, body, bodyType, region} = Lambda.dest l
in
Lambda.new {arg = bind arg,
argType = argType,
body = loopExp body,
+ bodyType = bodyType,
region = region}
end
and loopDecs (ds: Dec.t list, result): {decs: Dec.t list,
@@ -295,26 +307,9 @@
let
val exp =
case exp of
- Const _ => exp
- | Var x => Var (loopVar x)
- | Tuple xs => Tuple (loopVars xs)
- | Select {tuple, offset} =>
- Select {tuple = loopVar tuple,
- offset = offset}
- | ConApp {con, targs, arg} =>
- ConApp {con = con,
- targs = targs,
- arg = Option.map (arg, loopVar)}
- | PrimApp {prim, targs, args} =>
- PrimApp {prim = prim,
- targs = targs,
- args = loopVars args}
- | App {func, arg} =>
+ App {func, arg} =>
App {func = loopVar func,
arg = loopVar arg}
- | Raise {exn, filePos} =>
- Raise {exn = loopVar exn,
- filePos = filePos}
| Case {test, cases, default} =>
let
datatype z = datatype Cases.t
@@ -341,11 +336,30 @@
(default, fn (e, r) =>
(loopExp e, r))}
end
+ | ConApp {con, targs, arg} =>
+ ConApp {con = con,
+ targs = targs,
+ arg = Option.map (arg, loopVar)}
+ | Const _ => exp
| Handle {try, catch, handler} =>
Handle {try = loopExp try,
catch = bindVarType catch,
handler = loopExp handler}
- | _ => Error.bug "unexpected primExp"
+ | Lambda _ =>
+ Error.bug "unexpected Lambda"
+ | PrimApp {prim, targs, args} =>
+ PrimApp {prim = prim,
+ targs = targs,
+ args = loopVars args}
+ | Profile _ => exp
+ | Raise {exn, filePos} =>
+ Raise {exn = loopVar exn,
+ filePos = filePos}
+ | Select {tuple, offset} =>
+ Select {tuple = loopVar tuple,
+ offset = offset}
+ | Tuple xs => Tuple (loopVars xs)
+ | Var x => Var (loopVar x)
val var = bind var
val {decs, result} = loopDecs (ds, result)
in {decs = (MonoVal {var = var, ty = ty, exp = exp}
1.7 +12 -10 mlton/mlton/xml/scc-funs.fun
Index: scc-funs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/scc-funs.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- scc-funs.fun 12 Dec 2002 01:14:23 -0000 1.6
+++ scc-funs.fun 10 Jan 2003 18:36:15 -0000 1.7
@@ -37,34 +37,36 @@
fun loopVarExps xs = Vector.foreach (xs, loopVarExp)
fun loopLambda (l: Lambda.t): Lambda.t =
let
- val {arg, argType, body, region} = Lambda.dest l
+ val {arg, argType, body, bodyType, region} = Lambda.dest l
in
Lambda.new {arg = arg,
argType = argType,
body = loopExp body,
+ bodyType = bodyType,
region = region}
end
and loopPrimExp (e: PrimExp.t): PrimExp.t =
case e of
- Const _ => e
- | Var x => (loopVarExp x; e)
- | Tuple xs => (loopVarExps xs; e)
- | Select {tuple, ...} => (loopVarExp tuple; e)
- | Lambda l => Lambda (loopLambda l)
- | ConApp {arg, ...} => (Option.app (arg, loopVarExp); e)
- | PrimApp {args, ...} => (loopVarExps args; e)
- | App {func, arg} => (loopVarExp func; loopVarExp arg; e)
- | Raise {exn, ...} => (loopVarExp exn; e)
+ App {func, arg} => (loopVarExp func; loopVarExp arg; e)
| Case {test, cases, default} =>
(loopVarExp test
; Case {cases = Cases.map (cases, loopExp),
default = Option.map (default, fn (e, r) =>
(loopExp e, r)),
test = test})
+ | ConApp {arg, ...} => (Option.app (arg, loopVarExp); e)
+ | Const _ => e
| Handle {try, catch, handler} =>
Handle {try = loopExp try,
catch = catch,
handler = loopExp handler}
+ | Lambda l => Lambda (loopLambda l)
+ | PrimApp {args, ...} => (loopVarExps args; e)
+ | Profile _ => e
+ | Raise {exn, ...} => (loopVarExp exn; e)
+ | Select {tuple, ...} => (loopVarExp tuple; e)
+ | Tuple xs => (loopVarExps xs; e)
+ | Var x => (loopVarExp x; e)
and loopExp (e: Exp.t): Exp.t =
let val {decs, result} = Exp.dest e
val decs =
1.11 +116 -113 mlton/mlton/xml/simplify.fun
Index: simplify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- simplify.fun 12 Dec 2002 01:14:23 -0000 1.10
+++ simplify.fun 10 Jan 2003 18:36:15 -0000 1.11
@@ -309,33 +309,78 @@
end
in
case exp of
- Const c => nonExpansiveCon (fn () => (), Value.Const c)
- | Var x => let val x = varExpInfo x
- in replaceInfo (var, info, x)
- ; VarInfo.inc (x, ~1)
- ; rest ()
- end
- | Tuple xs =>
- let val xs = varExpInfos xs
- in nonExpansiveCon (fn () => VarInfo.deletes xs,
- Value.Tuple xs)
- end
- | Select {tuple, offset} =>
+ Case {test, cases, default} =>
let
- fun normal x = Select {tuple = x, offset = offset}
- in case varExpInfo tuple of
- VarInfo.Poly x => finish (normal x, rest ())
- | VarInfo.Mono {numOccurrences, value, varExp, ...} =>
- nonExpansive
- (fn () => inc (numOccurrences, ~1),
- fn () =>
- case !value of
- NONE => SOME (fn () => normal varExp)
- | SOME (Value.Tuple vs) =>
- (inc (numOccurrences, ~1)
- ; replaceInfo (var, info, Vector.sub (vs, offset))
- ; NONE)
- | _ => Error.bug "simplifyMonoVal: Select")
+ fun match (cases, f): Dec.t list =
+ let
+ val _ = deleteVarExp test
+ fun step (i, (c, e), ()) =
+ if f c
+ then
+ (Vector.foreachR (cases, i + 1,
+ Vector.length cases,
+ deleteExp o #2)
+ ; Option.app (default, deleteExp o #1)
+ ; Vector.Done (expression e))
+ else (deleteExp e; Vector.Continue ())
+ fun done () =
+ case default of
+ SOME (e, _) => expression e
+ | NONE => Error.bug "simplifyPrimExp: Case"
+ in Vector.fold' (cases, 0, (), step, done)
+ end
+ fun normal test =
+ let
+ (* Eliminate redundant default case. *)
+ val default =
+ if isExhaustive cases
+ then (Option.app (default, deleteExp o #1)
+ ; NONE)
+ else Option.map (default, fn (e, r) =>
+ (simplifyExp e, r))
+ in
+ expansive
+ (Case {test = test,
+ cases = Cases.map (cases, simplifyExp),
+ default = default})
+ end
+ in
+ case varExpInfo test of
+ VarInfo.Poly test => normal test
+ | VarInfo.Mono {value, varExp, ...} =>
+ case (cases, !value) of
+ (Cases.Con cases,
+ SOME (Value.ConApp {con = c, arg, ...})) =>
+ let
+ val match =
+ fn f =>
+ match (cases,
+ fn Pat.T {con = c', arg, ...} =>
+ Con.equals (c, c')
+ andalso f arg)
+ in case arg of
+ NONE => match Option.isNone
+ | SOME v =>
+ match
+ (fn SOME (x, _) => (replace (x, v); true)
+ | _ => false)
+ end
+ | (_, SOME (Value.Const c)) =>
+ let
+ fun doit (l, z) = match (l, fn z' => z = z')
+ in case (cases, Const.node c) of
+ (Cases.Char l, Const.Node.Char c) =>
+ doit (l, c)
+ | (Cases.Int l, Const.Node.Int i) =>
+ doit (l, i)
+ | (Cases.Word l, Const.Node.Word w) =>
+ doit (l, w)
+ | (Cases.Word8 l, Const.Node.Word w) =>
+ doit (l, Word8.fromWord w)
+ | _ => Error.bug "strange case"
+ end
+ | (_, NONE) => normal varExp
+ | _ => Error.bug "simplifyMonoVal"
end
| ConApp {con, targs, arg} =>
if Con.equals (con, Con.overflow)
@@ -352,6 +397,19 @@
(fn () => Option.app (arg, VarInfo.delete),
Value.ConApp {con = con, targs = targs, arg = arg})
end
+ | Const c => nonExpansiveCon (fn () => (), Value.Const c)
+ | Handle {try, catch, handler} =>
+ expansive (Handle {try = simplifyExp try,
+ catch = catch,
+ handler = simplifyExp handler})
+ | Lambda l =>
+ let val isInlined = ref false
+ in nonExpansive
+ (fn () => if !isInlined then () else deleteLambda l,
+ fn () => (value := SOME (Value.Lambda {isInlined = isInlined,
+ lam = l})
+ ; SOME (fn () => Lambda (simplifyLambda l))))
+ end
| PrimApp {prim, args, targs} =>
let
fun make () =
@@ -361,14 +419,37 @@
then expansive (make ())
else nonExpansive (fn () => (), fn () => SOME make)
end
- | Lambda l =>
- let val isInlined = ref false
- in nonExpansive
- (fn () => if !isInlined then () else deleteLambda l,
- fn () => (value := SOME (Value.Lambda {isInlined = isInlined,
- lam = l})
- ; SOME (fn () => Lambda (simplifyLambda l))))
+ | Profile _ => expansive exp
+ | Raise {exn, filePos} =>
+ expansive (Raise {exn = simplifyVarExp exn,
+ filePos = filePos})
+ | Select {tuple, offset} =>
+ let
+ fun normal x = Select {tuple = x, offset = offset}
+ in case varExpInfo tuple of
+ VarInfo.Poly x => finish (normal x, rest ())
+ | VarInfo.Mono {numOccurrences, value, varExp, ...} =>
+ nonExpansive
+ (fn () => inc (numOccurrences, ~1),
+ fn () =>
+ case !value of
+ NONE => SOME (fn () => normal varExp)
+ | SOME (Value.Tuple vs) =>
+ (inc (numOccurrences, ~1)
+ ; replaceInfo (var, info, Vector.sub (vs, offset))
+ ; NONE)
+ | _ => Error.bug "simplifyMonoVal: Select")
+ end
+ | Tuple xs =>
+ let val xs = varExpInfos xs
+ in nonExpansiveCon (fn () => VarInfo.deletes xs,
+ Value.Tuple xs)
end
+ | Var x => let val x = varExpInfo x
+ in replaceInfo (var, info, x)
+ ; VarInfo.inc (x, ~1)
+ ; rest ()
+ end
| App {func, arg} =>
let
val arg = varExpInfo arg
@@ -390,95 +471,17 @@
end
| _ => normal varExp
end
- | Raise {exn, filePos} =>
- expansive (Raise {exn = simplifyVarExp exn,
- filePos = filePos})
- | Handle {try, catch, handler} =>
- expansive (Handle {try = simplifyExp try,
- catch = catch,
- handler = simplifyExp handler})
- | Case {test, cases, default} =>
- let
- fun match (cases, f): Dec.t list =
- let
- val _ = deleteVarExp test
- fun step (i, (c, e), ()) =
- if f c
- then
- (Vector.foreachR (cases, i + 1,
- Vector.length cases,
- deleteExp o #2)
- ; Option.app (default, deleteExp o #1)
- ; Vector.Done (expression e))
- else (deleteExp e; Vector.Continue ())
- fun done () =
- case default of
- SOME (e, _) => expression e
- | NONE => Error.bug "simplifyPrimExp: Case"
- in Vector.fold' (cases, 0, (), step, done)
- end
- fun normal test =
- let
- (* Eliminate redundant default case. *)
- val default =
- if isExhaustive cases
- then (Option.app (default, deleteExp o #1)
- ; NONE)
- else Option.map (default, fn (e, r) =>
- (simplifyExp e, r))
- in
- expansive
- (Case {test = test,
- cases = Cases.map (cases, simplifyExp),
- default = default})
- end
- in case varExpInfo test of
- VarInfo.Poly test => normal test
- | VarInfo.Mono {value, varExp, ...} =>
- case (cases, !value) of
- (Cases.Con cases,
- SOME (Value.ConApp {con = c, arg, ...})) =>
- let
- val match =
- fn f =>
- match (cases,
- fn Pat.T {con = c', arg, ...} =>
- Con.equals (c, c')
- andalso f arg)
- in case arg of
- NONE => match Option.isNone
- | SOME v =>
- match
- (fn SOME (x, _) => (replace (x, v); true)
- | _ => false)
- end
- | (_, SOME (Value.Const c)) =>
- let
- fun doit (l, z) = match (l, fn z' => z = z')
- in case (cases, Const.node c) of
- (Cases.Char l, Const.Node.Char c) =>
- doit (l, c)
- | (Cases.Int l, Const.Node.Int i) =>
- doit (l, i)
- | (Cases.Word l, Const.Node.Word w) =>
- doit (l, w)
- | (Cases.Word8 l, Const.Node.Word w) =>
- doit (l, Word8.fromWord w)
- | _ => Error.bug "strange case"
- end
- | (_, NONE) => normal varExp
- | _ => Error.bug "simplifyMonoVal"
- end
end
and simplifyLambda l: Lambda.t =
traceSimplifyLambda
(fn l =>
let
- val {arg, argType, body, region} = Lambda.dest l
+ val {arg, argType, body, bodyType, region} = Lambda.dest l
in
Lambda.new {arg = arg,
argType = argType,
body = simplifyExp body,
+ bodyType = bodyType,
region = region}
end) l
val _ = countExp body
1.3 +18 -18 mlton/mlton/xml/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/sources.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.cm 16 Apr 2002 12:10:53 -0000 1.2
+++ sources.cm 10 Jan 2003 18:36:16 -0000 1.3
@@ -23,24 +23,24 @@
../control/sources.cm
../../lib/mlton/sources.cm
-xml-type.sig
-xml-tree.sig
-xml-tree.fun
-xml.sig
-type-check.sig
-type-check.fun
-simplify-types.sig
-simplify-types.fun
-scc-funs.sig
+implement-exceptions.fun
+implement-exceptions.sig
+monomorphise.fun
+monomorphise.sig
+polyvariance.fun
+polyvariance.sig
scc-funs.fun
-simplify.sig
+scc-funs.sig
+simplify-types.fun
+simplify-types.sig
simplify.fun
-xml.fun
-sxml.sig
-polyvariance.sig
-polyvariance.fun
+simplify.sig
sxml-exns.sig
-monomorphise.sig
-monomorphise.fun
-implement-exceptions.sig
-implement-exceptions.fun
+sxml.sig
+type-check.fun
+type-check.sig
+xml-tree.fun
+xml-tree.sig
+xml-type.sig
+xml.fun
+xml.sig
1.7 +58 -52 mlton/mlton/xml/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- type-check.fun 12 Dec 2002 01:14:23 -0000 1.6
+++ type-check.fun 10 Jan 2003 18:36:16 -0000 1.7
@@ -153,56 +153,7 @@
List.fold (es, t, fn (e, t) => checkApp (t, e))
in
case e of
- Var x => checkVarExp x
- | Const c => Type.ofConst c
- | Tuple xs =>
- if 1 = Vector.length xs
- then error "unary tuple"
- else Type.tuple (checkVarExps xs)
- | Select {tuple, offset} =>
- (case Type.detupleOpt (checkVarExp tuple) of
- SOME ts => Vector.sub (ts, offset)
- | NONE => error "selection from nontuple")
- | Lambda l => checkLambda l
- | PrimApp {prim, targs, args} =>
- let
- val _ = checkTypes targs
- in
- case Prim.checkApp {prim = prim,
- targs = targs,
- args = checkVarExps args,
- con = Type.con,
- equals = Type.equals,
- dearrowOpt = Type.dearrowOpt,
- detupleOpt = Type.detupleOpt,
- isUnit = Type.isUnit
- } of
- NONE => error "bad primapp"
- | SOME t => t
- end
- | ConApp {con, targs, arg} =>
- let
- val t = checkConExp (con, targs)
- in case arg of
- NONE => t
- | SOME e => checkApp (t, e)
- end
- | App {func, arg} => checkApp (checkVarExp func, arg)
- | Raise {exn, ...} => if isExnType (checkVarExp exn)
- then ty
- else error "bad raise"
- | Handle {try, catch = (catch, catchType), handler, ...} =>
- let
- val _ = if isExnType catchType
- then ()
- else error "handle with non-exn type for catch"
- val ty = checkExp try
- val _ = setVar (catch, {tyvars = Vector.new0 (),
- ty = catchType})
- val ty' = checkExp handler
- in if Type.equals (ty, ty') then ty
- else error "bad handle"
- end
+ App {func, arg} => checkApp (checkVarExp func, arg)
| Case {test, cases, default} =>
let
val ty = checkVarExp test
@@ -244,14 +195,69 @@
else error "default of wrong type"
else error "test and patterns of different types"
end
+ | ConApp {con, targs, arg} =>
+ let
+ val t = checkConExp (con, targs)
+ in case arg of
+ NONE => t
+ | SOME e => checkApp (t, e)
+ end
+ | Const c => Type.ofConst c
+ | Handle {try, catch = (catch, catchType), handler, ...} =>
+ let
+ val _ = if isExnType catchType
+ then ()
+ else error "handle with non-exn type for catch"
+ val ty = checkExp try
+ val _ = setVar (catch, {tyvars = Vector.new0 (),
+ ty = catchType})
+ val ty' = checkExp handler
+ in if Type.equals (ty, ty') then ty
+ else error "bad handle"
+ end
+ | Lambda l => checkLambda l
+ | PrimApp {prim, targs, args} =>
+ let
+ val _ = checkTypes targs
+ in
+ case Prim.checkApp {prim = prim,
+ targs = targs,
+ args = checkVarExps args,
+ con = Type.con,
+ equals = Type.equals,
+ dearrowOpt = Type.dearrowOpt,
+ detupleOpt = Type.detupleOpt,
+ isUnit = Type.isUnit
+ } of
+ NONE => error "bad primapp"
+ | SOME t => t
+ end
+ | Profile _ => Type.unit
+ | Raise {exn, ...} => if isExnType (checkVarExp exn)
+ then ty
+ else error "bad raise"
+ | Select {tuple, offset} =>
+ (case Type.detupleOpt (checkVarExp tuple) of
+ SOME ts => Vector.sub (ts, offset)
+ | NONE => error "selection from nontuple")
+ | Tuple xs =>
+ if 1 = Vector.length xs
+ then error "unary tuple"
+ else Type.tuple (checkVarExps xs)
+ | Var x => checkVarExp x
end) arg
and checkLambda l: Type.t =
let
- val {arg, argType, body, ...} = Lambda.dest l
+ val {arg, argType, body, bodyType, ...} = Lambda.dest l
val _ = checkType argType
val _ = setVar (arg, {tyvars = Vector.new0 (), ty = argType})
+ val _ =
+ if Type.equals (bodyType, checkExp body)
+ then ()
+ else Type.error ("lambda body of wrong type",
+ Lambda.layout l)
in
- Type.arrow (argType, checkExp body)
+ Type.arrow (argType, bodyType)
end
and checkDec d =
let
1.12 +93 -40 mlton/mlton/xml/xml-tree.fun
Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- xml-tree.fun 12 Dec 2002 01:14:23 -0000 1.11
+++ xml-tree.fun 10 Jan 2003 18:36:16 -0000 1.12
@@ -125,6 +125,7 @@
| PrimApp of {prim: Prim.t,
targs: Type.t vector,
args: VarExp.t vector}
+ | Profile of ProfileExp.t
| Raise of {exn: VarExp.t,
filePos: string}
| Select of {tuple: VarExp.t,
@@ -148,6 +149,7 @@
and lambda = Lam of {arg: Var.t,
argType: Type.t,
body: exp,
+ bodyType: Type.t,
plist: PropertyList.t,
region: Region.t}
@@ -200,40 +202,7 @@
end
and primExpToAst e : Aexp.t =
case e of
- Const c => Const.toAstExp c
- | Var x => VarExp.toAst x
- | Tuple xs => Aexp.tuple (Vector.map (xs, VarExp.toAst))
- | Select {tuple, offset} =>
- Aexp.select {tuple = VarExp.toAst tuple,
- offset = offset}
- | Lambda lambda => Aexp.fnn (lambdaToAst lambda)
- | ConApp {con, arg, ...} =>
- let val con = Aexp.con (Con.toAst con)
- in case arg of
- NONE => con
- | SOME e => Aexp.app (con, VarExp.toAst e)
- end
- | PrimApp {prim, args, ...} =>
- let
- val p = Aexp.longvid (Ast.Longvid.short
- (Ast.Longvid.Id.fromString
- (Prim.toString prim,
- Region.bogus)))
- in
- case Prim.numArgs prim of
- NONE => p
- | SOME _ => Aexp.app (p, Aexp.tuple (Vector.map
- (args, VarExp.toAst)))
- end
- | App {func, arg} => Aexp.app (VarExp.toAst func, VarExp.toAst arg)
- | Raise {exn, filePos} => Aexp.raisee {exn = VarExp.toAst exn,
- filePos = filePos}
- | Handle {try, catch, handler} =>
- Aexp.handlee
- (expToAst try,
- Amatch.T {filePos = "",
- rules = Vector.new1 (Apat.var (Var.toAst (#1 catch)),
- expToAst handler)})
+ App {func, arg} => Aexp.app (VarExp.toAst func, VarExp.toAst arg)
| Case {test, cases, default, ...} =>
let
fun doit (l, f) =
@@ -260,6 +229,52 @@
Amatch.T {rules = cases,
filePos = ""})
end
+ | ConApp {con, arg, ...} =>
+ let val con = Aexp.con (Con.toAst con)
+ in case arg of
+ NONE => con
+ | SOME e => Aexp.app (con, VarExp.toAst e)
+ end
+ | Const c => Const.toAstExp c
+ | Handle {try, catch, handler} =>
+ Aexp.handlee
+ (expToAst try,
+ Amatch.T {filePos = "",
+ rules = Vector.new1 (Apat.var (Var.toAst (#1 catch)),
+ expToAst handler)})
+ | Lambda lambda => Aexp.fnn (lambdaToAst lambda)
+ | PrimApp {prim, args, ...} =>
+ let
+ val p = Aexp.longvid (Ast.Longvid.short
+ (Ast.Longvid.Id.fromString
+ (Prim.toString prim,
+ Region.bogus)))
+ in
+ case Prim.numArgs prim of
+ NONE => p
+ | SOME _ => Aexp.app (p, Aexp.tuple (Vector.map
+ (args, VarExp.toAst)))
+ end
+ | Profile s =>
+ let
+ val (oper, si) =
+ case s of
+ ProfileExp.Enter si => ("ProfileEnter", si)
+ | ProfileExp.Leave si => ("ProfileLeave", si)
+ in
+ Aexp.app
+ (Aexp.var (Ast.Var.fromString (oper, Region.bogus)),
+ Aexp.const (Ast.Const.makeRegion
+ (Ast.Const.String (SourceInfo.toString si),
+ Region.bogus)))
+ end
+ | Raise {exn, filePos} => Aexp.raisee {exn = VarExp.toAst exn,
+ filePos = filePos}
+ | Select {tuple, offset} =>
+ Aexp.select {tuple = VarExp.toAst tuple,
+ offset = offset}
+ | Tuple xs => Aexp.tuple (Vector.map (xs, VarExp.toAst))
+ | Var x => VarExp.toAst x
and lambdaToAst (Lam {arg, body, argType, ...}): Amatch.t =
Amatch.T
@@ -324,6 +339,40 @@
val toAst = expToAst
val layout = Ast.Exp.layout o toAst
+ fun enterLeave (e: t, ty: Type.t, si: SourceInfo.t): t =
+ if !Control.profile = Control.ProfileNone
+ orelse !Control.profileIL <> Control.ProfileXML
+ then e
+ else
+ let
+ datatype z = datatype Dec.t
+ datatype z = datatype PrimExp.t
+ fun prof f =
+ MonoVal {exp = Profile (f si),
+ ty = Type.unit,
+ var = Var.newNoname ()}
+ val exn = Var.newNoname ()
+ val res = Var.newNoname ()
+ val handler =
+ new {decs = [prof ProfileExp.Leave,
+ MonoVal {exp = Raise {exn = VarExp.mono exn,
+ filePos = ""},
+ ty = ty,
+ var = res}],
+ result = VarExp.mono res}
+ val {decs, result} = dest e
+ val decs =
+ List.concat [[prof ProfileExp.Enter],
+ decs,
+ [prof ProfileExp.Leave]]
+ val try = new {decs = decs, result = result}
+ in
+ fromPrimExp (Handle {catch = (exn, Type.exn),
+ handler = handler,
+ try = try},
+ ty)
+ end
+
(*------------------------------------*)
(* foreach *)
(*------------------------------------*)
@@ -350,6 +399,7 @@
| Select {tuple, ...} => handleVarExp tuple
| Lambda lambda => loopLambda lambda
| PrimApp {args, ...} => handleVarExps args
+ | Profile _ => ()
| ConApp {arg, ...} => (case arg of
NONE => ()
| SOME x => handleVarExp x)
@@ -493,15 +543,18 @@
val region = make #region
end
- fun new {arg, argType, body, region} =
+ fun new {arg, argType, body, bodyType, region} =
Lam {arg = arg,
argType = argType,
body = body,
+ bodyType = bodyType,
plist = PropertyList.new (),
region = region}
- fun dest (Lam {arg, argType, body, region, ...}) =
- {arg = arg, argType = argType, body = body, region = region}
+ fun dest (Lam {arg, argType, body, bodyType, region, ...}) =
+ {arg = arg, argType = argType,
+ body = body, bodyType = bodyType,
+ region = region}
fun plist (Lam {plist, ...}) = plist
@@ -537,7 +590,7 @@
end
type t = Cont.t -> Exp.t
-
+
fun send (e: t, k: Cont.t): Exp.t = e k
fun toExp e = send (e, Cont.id)
@@ -700,14 +753,14 @@
Exp.prefix (send (body, k),
Dec.MonoVal {var = var, ty = ty, exp = exp}))
-
fun lambda {arg, argType, body, bodyType, region} =
simple (Lambda (Lambda.new {arg = arg,
argType = argType,
body = toExp body,
+ bodyType = bodyType,
region = region}),
Type.arrow (argType, bodyType))
-
+
fun detupleGen (e: PrimExp.t,
t: Type.t,
components: Var.t vector,
1.8 +28 -24 mlton/mlton/xml/xml-tree.sig
Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- xml-tree.sig 12 Dec 2002 01:14:23 -0000 1.7
+++ xml-tree.sig 10 Jan 2003 18:36:16 -0000 1.8
@@ -54,12 +54,14 @@
val dest: t -> {arg: Var.t,
argType: Type.t,
body: exp,
+ bodyType: Type.t,
region: Region.t}
val equals: t * t -> bool
val layout: t -> Layout.t
val new: {arg: Var.t,
argType: Type.t,
body: exp,
+ bodyType: Type.t,
region: Region.t} -> t
val plist: t -> PropertyList.t
val region: t -> Region.t
@@ -83,27 +85,28 @@
sig
type exp = Lambda.exp
datatype t =
- App of {func: VarExp.t,
- arg: VarExp.t}
- | Case of {test: VarExp.t,
- cases: exp Cases.t,
- default: (exp * Region.t) option}
- | ConApp of {con: Con.t,
- targs: Type.t vector,
- arg: VarExp.t option}
+ App of {arg: VarExp.t,
+ func: VarExp.t}
+ | Case of {cases: exp Cases.t,
+ default: (exp * Region.t) option,
+ test: VarExp.t}
+ | ConApp of {arg: VarExp.t option,
+ con: Con.t,
+ targs: Type.t vector}
| Const of Const.t
- | Handle of {try: exp,
- (* catch binds the exception in the handler. *)
+ | Handle of {(* catch binds the exception in the handler. *)
catch: Var.t * Type.t,
- handler: exp}
+ handler: exp,
+ try: exp}
| Lambda of Lambda.t
- | PrimApp of {prim: Prim.t,
- targs: Type.t vector,
- args: VarExp.t vector}
+ | PrimApp of {args: VarExp.t vector,
+ prim: Prim.t,
+ targs: Type.t vector}
+ | Profile of ProfileExp.t
| Raise of {exn: VarExp.t,
filePos: string}
- | Select of {tuple: VarExp.t,
- offset: int}
+ | Select of {offset: int,
+ tuple: VarExp.t}
| Tuple of VarExp.t vector
| Var of VarExp.t
@@ -117,17 +120,17 @@
datatype t =
Exception of {con: Con.t,
arg: Type.t option}
- | Fun of {tyvars: Tyvar.t vector,
- decs: {var: Var.t,
+ | Fun of {decs: {lambda: Lambda.t,
ty: Type.t,
- lambda: Lambda.t} vector}
- | MonoVal of {var: Var.t,
+ var: Var.t} vector,
+ tyvars: Tyvar.t vector}
+ | MonoVal of {exp: PrimExp.t,
ty: Type.t,
- exp: PrimExp.t}
- | PolyVal of {var: Var.t,
- tyvars: Tyvar.t vector,
+ var: Var.t}
+ | PolyVal of {exp: exp,
ty: Type.t,
- exp: exp}
+ tyvars: Tyvar.t vector,
+ var: Var.t}
val toAst: t -> Ast.Dec.t
val layout: t -> Layout.t
@@ -140,6 +143,7 @@
val clear: t -> unit
val decs: t -> Dec.t list
val dest: t -> {decs: Dec.t list, result: VarExp.t}
+ val enterLeave: t * Type.t * SourceInfo.t -> t
(* foreach {exp, handleExp, handleBoundVar, handleVarExp}
* applies handleExp to each subexpresison of e (including e)
* applies handleBoundVar to each variable bound in e
-------------------------------------------------------
This SF.NET email is sponsored by:
SourceForge Enterprise Edition + IBM + LinuxWorld = Something 2 See!
http://www.vasoftware.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel