[MLton] cvs commit: added flags -show-def-use, -warn-unused
Stephen Weeks
sweeks@mlton.org
Mon, 16 Feb 2004 14:42:11 -0800
sweeks 04/02/16 14:42:11
Modified: doc changelog
doc/user-guide man-page.tex
mlton mlton-stubs.cm
mlton/ast ast.fun ast.sig
mlton/control control.sig control.sml region.sig region.sml
source-pos.sig source-pos.sml
mlton/elaborate elaborate-core.fun elaborate-env.fun
elaborate-env.sig elaborate-sigexp.fun
elaborate.fun elaborate.sig interface.fun
interface.sig sources.cm type-str.fun
mlton/front-end ml.grm ml.lex
mlton/main compile.fun main.fun
Log:
MAIL added flags -show-def-use, -warn-unused
Both of these deal with def-use information (as does
-show-basis-used).
-show-def-use <file>
Causes MLton to output def-use information to file.
-warn-unused true
Causes MLton to report unused identifiers.
The elaborator now keeps track of def-use information, which records
for each identifier (variable, signature, structure, functor, or type)
where each of its uses is. Def-use information is a whole-program
property, and is tracked through structures and functor applications.
-show-def-use printsone line for each definition, and follows that
with an indented line for each use, showing the source position of
each use. With an input program, -show-def-use and -warn-unused
report information for that program. With no input, they report
information for the basis library.
-warn-unused reports all identifiers that have no uses, with a few
exceptions to cut down on spurious warnings. First, identifers that
are still in scope are not reported. Second, identifiers that are
defined in functor bodies of unused functors are not reported if they
are either exported by the functor or are passed as arguments to other
functors. Third, types defined as datatypes are not reported, since
often the constructors are used but the type is not.
With these, I was able to go through the basis library and eliminate
all unused identifier warnings. Most of the warnings were reasonable.
A few even showed a bug, where a variable should have been used but
wasn't. For the few remaining cases, I have added a bogus use to
quell the warning.
Implementing this required some restructuring of the elaborator so
that I could track use information with constructors accessed via
their type structure. For example, in
----------------------------------------
structure S =
struct
datatype t = A
end
structure T =
struct
datatype z = datatype S.t
val _ = A
end
----------------------------------------
we would like to match up the definition of A with its use. This
required augmenting type structures with use information. This was a
bit messy, because the same code was used for type structures in
signatures as in structures. I decided to split the implementation of
type structures into two, which on the whole was cleaner.
In adding -show-def-use, I cleaned up the code that calls the
elaborator and took Henry's suggestions to change -export-header,
-show-basis, and -show-basis-used to take a file name argument. They
can be used together, or as part of a normal compilation.
I also cleaned up some hardwired stuff in compile.fun dealing with the
basis environment. I added a new form of topdec, only to be used at
the end of the basis, that looks as follows
_basis_done <longstrid>
The use looks like
_basis_done MLtonFFI
Here, MLtonFFI identifies the structure that provides the primitives
that are needed in order to expand _export in the elaborator.
_basis_done also tells the elaborator that rebinding "=" is no longer
allowed.
There are still some more changes that will help cut down on spurious
warnings and will improve the output for -show-def-use. But things
are working well enough that I'd like feedback. Please try out
-show-def-use and -warn-unused on your programs and see what you
think.
Also, there are about 2300 unused warnings on MLton itself. It would
be wortwhile to start plowing through those and understanding if they
are bugs, unused variables, or spurious warnings.
Revision Changes Path
1.104 +6 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.103
retrieving revision 1.104
diff -u -r1.103 -r1.104
--- changelog 13 Feb 2004 17:05:55 -0000 1.103
+++ changelog 16 Feb 2004 22:42:08 -0000 1.104
@@ -1,5 +1,11 @@
Here are the changes since version 20030716.
+* 2004-02-16
+ - Changed -export-header, -show-basis, -show-basis-used to take a
+ file name argument, and they no longer force compilation to halt.
+ - Added -show-def-use and -warn-unused, which deal with def-use
+ information.
+
* 2004-02-13
- Added flag -sequence-unit, which imposes the constraint that in
the sequence expression (e1; e2), e1 must be of type unit.
1.49 +20 -12 mlton/doc/user-guide/man-page.tex
Index: man-page.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/man-page.tex,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- man-page.tex 13 Feb 2004 17:05:56 -0000 1.48
+++ man-page.tex 16 Feb 2004 22:42:08 -0000 1.49
@@ -69,10 +69,10 @@
exceptions and in run time, because of additional work that must be
performed at each exception construction, raise, and handle.
-\option{-export-header \falseTrue}
-Causes {\mlton} to print a C header file with prototypes for all of
-the functions exported from SML, and then exit. This flag is useful
-for programs that use {\export} expressions (see \secref{export}).
+\option{-export-header {\it file}}
+Causes {\mlton} to create {\it file} with C prototypes for all of the
+functions exported from SML to C. This flag is useful for programs
+that use {\export} expressions (see \secref{export}).
\option{-ieee-fp \falseTrue}
Control whether or not the native code generator is pedantic about following
@@ -140,14 +140,19 @@
detecting curried applications that are mistakenly not fully applied.
To silence spurious errors, you can use {\tt ignore e1}.
-\option{-show-basis \falseTrue}
-If true, {\mlton} prints the basis library and exits. When used with
-an input file, {\mlton} prints the basis defined by the input program.
-
-\option{-show-basis-used \falseTrue}
-If true, {\mlton} prints the types, values, signatures, structures,
-and functors from the basis library that the input program uses, and
-then exits.
+\option{-show-basis {\it file}}
+Causes {\mlton} to pretty print to {\it file} the basis defined by the
+input program. When used with no input, {\mlton} pretty prints the
+entire basis library.
+
+\option{-show-basis-used {\it file}}
+Causes {\mlton} to pretty print to {\it file} the portion of the basis
+library that the input program uses.
+
+\option{-show-def-use {\it file}}
+Causes {\mlton} to output def-use information to {\it file}. Each
+identifier that is defined appears on a line, follwed on subequent
+lines by the position of each use.
\option{-stop \choiceFour{f}{g}{o}{sml}}
Secify pass to stop at.\\
@@ -179,6 +184,9 @@
\option{-warn-match \trueFalse}
Whether or not to display nonexhaustive and redundant match warnings.
+
+\option{-warn-unused \falseTrue}
+Whether or not to report unused identifiers.
\end{description}
1.42 +1 -3 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- mlton-stubs.cm 5 Feb 2004 06:11:40 -0000 1.41
+++ mlton-stubs.cm 16 Feb 2004 22:42:09 -0000 1.42
@@ -231,7 +231,6 @@
atoms/c-type.sig
backend/runtime.sig
backend/profile-label.sig
-ast/symbol.sig
atoms/id.sig
atoms/c-function.sig
codegen/x86-codegen/x86.sig
@@ -286,6 +285,7 @@
atoms/type-ops.sig
ast/wrapped.sig
ast/tyvar.sig
+ast/symbol.sig
ast/field.sig
ast/record.sig
atoms/var.sig
@@ -355,7 +355,6 @@
elaborate/scope.sig
elaborate/scope.fun
core-ml/core-ml.sig
-elaborate/type-str.sig
elaborate/interface.sig
elaborate/decs.sig
elaborate/type-env.sig
@@ -371,7 +370,6 @@
control/pretty.sml
atoms/generic-scheme.sig
atoms/generic-scheme.fun
-elaborate/type-str.fun
elaborate/interface.fun
elaborate/decs.fun
elaborate/elaborate-env.fun
1.15 +13 -10 mlton/mlton/ast/ast.fun
Index: ast.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- ast.fun 7 Feb 2004 03:02:36 -0000 1.14
+++ ast.fun 16 Feb 2004 22:42:09 -0000 1.15
@@ -353,7 +353,8 @@
struct
open Wrap
datatype node =
- Functor of {arg: FctArg.t,
+ BasisDone of {ffi: Longstrid.t}
+ | Functor of {arg: FctArg.t,
body: Strexp.t,
name: Fctid.t,
result: SigConst.t} vector
@@ -365,15 +366,7 @@
fun layout d =
case node d of
- Strdec d => Strdec.layout d
- | Signature sigbs =>
- layoutAndsBind ("signature", "=", Vector.toList sigbs,
- fn (name, def) =>
- (case Sigexp.node def of
- Sigexp.Var _ => OneLine
- | _ => Split 3,
- Sigid.layout name,
- Sigexp.layout def))
+ BasisDone {ffi} => seq [str "_basis_done ", Longstrid.layout ffi]
| Functor fctbs =>
layoutAndsBind ("functor", "=", Vector.toList fctbs,
fn {name, arg, result, body} =>
@@ -382,6 +375,16 @@
paren (FctArg.layout arg),
layoutSigConst result],
layoutStrexp body))
+ | Signature sigbs =>
+ layoutAndsBind ("signature", "=", Vector.toList sigbs,
+ fn (name, def) =>
+ (case Sigexp.node def of
+ Sigexp.Var _ => OneLine
+ | _ => Split 3,
+ Sigid.layout name,
+ Sigexp.layout def))
+ | Strdec d => Strdec.layout d
+
fun make n = makeRegion (n, Region.bogus)
val fromExp = make o Strdec o Strdec.fromExp
1.10 +2 -1 mlton/mlton/ast/ast.sig
Index: ast.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- ast.sig 31 Jan 2004 06:00:30 -0000 1.9
+++ ast.sig 16 Feb 2004 22:42:09 -0000 1.10
@@ -147,7 +147,8 @@
sig
type t
datatype node =
- Functor of {arg: FctArg.t,
+ BasisDone of {ffi: Longstrid.t}
+ | Functor of {arg: FctArg.t,
body: Strexp.t,
name: Fctid.t,
result: SigConst.t} vector
1.90 +22 -15 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.89
retrieving revision 1.90
diff -u -r1.89 -r1.90
--- control.sig 13 Feb 2004 17:05:56 -0000 1.89
+++ control.sig 16 Feb 2004 22:42:09 -0000 1.90
@@ -59,7 +59,7 @@
(* whether optimization passes should eliminate useless overflow tests *)
val eliminateOverflow: bool ref
- val exportHeader: bool ref
+ val exportHeader: File.t option ref
val exnHistory: bool ref
@@ -91,24 +91,26 @@
(* call count instrumentation *)
val instrument: bool ref
- (* Save the Machine to a file. *)
- val keepMachine: bool ref
-
- (* Save the RSSA to a file. *)
- val keepRSSA: bool ref
-
- (* Save the SSA to a file. *)
- val keepSSA: bool ref
-
+ val keepDefUse: bool ref
+
(* List of pass names to keep diagnostic info on. *)
val keepDiagnostics: Regexp.Compiled.t list ref
(* Keep dot files for whatever SSA files are produced. *)
val keepDot: bool ref
+ (* Save the Machine to a file. *)
+ val keepMachine: bool ref
+
(* List of pass names to save the result of. *)
val keepPasses: Regexp.Compiled.t list ref
+ (* Save the RSSA to a file. *)
+ val keepRSSA: bool ref
+
+ (* Save the SSA to a file. *)
+ val keepSSA: bool ref
+
(* lib/mlton directory *)
val libDir: Dir.t ref
@@ -135,7 +137,7 @@
(* Number of times to loop through optimization passes. *)
val loopPasses: int ref
-
+
(* Should the mutator mark cards? *)
val markCards: bool ref
@@ -214,11 +216,14 @@
(* in (e1; e2), require e1: unit. *)
val sequenceUnit: bool ref
- (* Show the basis library and exit. *)
- val showBasis: bool ref
+ (* Show the basis library. *)
+ val showBasis: File.t option ref
- (* Show the basis library used and exit. *)
- val showBasisUsed: bool ref
+ (* Show the basis library used. *)
+ val showBasisUsed: File.t option ref
+
+ (* Show def-use information. *)
+ val showDefUse: File.t option ref
(* Should types be printed in ILs. *)
val showTypes: bool ref
@@ -278,6 +283,8 @@
val warnNonExhaustive: bool ref
val warnRedundant: bool ref
+
+ val warnUnused: bool ref
(* XML Passes *)
val xmlPassesSet: (string -> string list Result.t) ref
1.110 +18 -6 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.109
retrieving revision 1.110
diff -u -r1.109 -r1.110
--- control.sml 13 Feb 2004 17:05:56 -0000 1.109
+++ control.sml 16 Feb 2004 22:42:10 -0000 1.110
@@ -97,8 +97,8 @@
val exportHeader =
control {name = "export header",
- default = false,
- toString = Bool.toString}
+ default = NONE,
+ toString = Option.toString File.toString}
val exnHistory = control {name = "exn history",
default = false,
@@ -196,6 +196,10 @@
default = false,
toString = Bool.toString}
+val keepDefUse = control {name = "keep def-use",
+ default = false,
+ toString = Bool.toString}
+
val keepMachine = control {name = "keep Machine",
default = false,
toString = Bool.toString}
@@ -398,12 +402,16 @@
toString = Bool.toString}
val showBasis = control {name = "show basis",
- default = false,
- toString = Bool.toString}
+ default = NONE,
+ toString = Option.toString File.toString}
val showBasisUsed = control {name = "show basis used",
- default = false,
- toString = Bool.toString}
+ default = NONE,
+ toString = Option.toString File.toString}
+
+val showDefUse = control {name = "show def-use",
+ default = NONE,
+ toString = Option.toString File.toString}
val showTypes = control {name = "show types",
default = false,
@@ -548,6 +556,10 @@
val warnRedundant = control {name = "warn redundant",
default = true,
toString = Bool.toString}
+
+val warnUnused = control {name = "warn unused",
+ default = false,
+ toString = Bool.toString}
val xmlPassesSet : (string -> string list Result.t) ref =
control {name = "xmlPassesSet",
1.6 +3 -0 mlton/mlton/control/region.sig
Index: region.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/region.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- region.sig 12 Dec 2002 01:14:22 -0000 1.5
+++ region.sig 16 Feb 2004 22:42:10 -0000 1.6
@@ -17,8 +17,11 @@
type t
+ val <= : t * t -> bool
val append: t * t -> t
val bogus: t
+ val compare: t * t -> Relation.t
+ val equals: t * t -> bool
val extendRight: t * SourcePos.t -> t
val left: t -> SourcePos.t option
val layout: t -> Layout.t
1.7 +18 -0 mlton/mlton/control/region.sml
Index: region.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/region.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- region.sml 11 Feb 2003 18:05:47 -0000 1.6
+++ region.sml 16 Feb 2004 22:42:10 -0000 1.7
@@ -46,6 +46,24 @@
fun list (xs, reg) = List.fold (xs, Bogus, fn (x, r) => append (reg x, r))
+fun compare (r, r') =
+ case (left r, left r') of
+ (NONE, NONE) => EQUAL
+ | (NONE, _) => LESS
+ | (_, NONE) => GREATER
+ | (SOME p, SOME p') => SourcePos.compare (p, p')
+
+val compare =
+ Trace.trace2 ("Region.compare", layout, layout, Relation.layout) compare
+
+fun equals (r, r') = compare (r, r') = EQUAL
+
+fun r <= r' =
+ case compare (r, r') of
+ EQUAL => true
+ | GREATER => false
+ | LESS => true
+
structure Wrap =
struct
type region = t
1.5 +1 -0 mlton/mlton/control/source-pos.sig
Index: source-pos.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/source-pos.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- source-pos.sig 11 Feb 2003 18:05:48 -0000 1.4
+++ source-pos.sig 16 Feb 2004 22:42:10 -0000 1.5
@@ -19,6 +19,7 @@
val bogus: t
val column: t -> int
+ val compare: t * t -> Relation.t
val equals: t * t -> bool
val file: t -> File.t
val isBasis: t -> bool
1.7 +9 -0 mlton/mlton/control/source-pos.sml
Index: source-pos.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/source-pos.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- source-pos.sml 9 Oct 2003 18:17:32 -0000 1.6
+++ source-pos.sml 16 Feb 2004 22:42:10 -0000 1.7
@@ -19,6 +19,15 @@
val line = f #line
end
+fun compare (T {column = c, file = f, line = l},
+ T {column = c', file = f', line = l'}) =
+ case String.compare (f, f') of
+ EQUAL =>
+ (case Int.compare (l, l') of
+ EQUAL => Int.compare (c, c')
+ | r => r)
+ | r => r
+
fun equals (T r, T r') = r = r'
fun make {column, file, line} =
1.84 +71 -44 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.83
retrieving revision 1.84
diff -u -r1.83 -r1.84
--- elaborate-core.fun 13 Feb 2004 17:05:56 -0000 1.83
+++ elaborate-core.fun 16 Feb 2004 22:42:10 -0000 1.84
@@ -344,15 +344,15 @@
local
val eq = Avar.fromSymbol (Symbol.equal, Region.bogus)
in
- fun extendVar (E, x, x', s, region) =
+ fun ensureNotEquals x =
if not (!allowRebindEquals) andalso Avar.equals (x, eq)
then
let
open Layout
in
- Control.error (region, str "= can't be redefined", empty)
+ Control.error (Avar.region x, str "= can't be redefined", empty)
end
- else Env.extendVar (E, x, x', s)
+ else ()
end
fun approximate (l: Layout.t): Layout.t =
@@ -368,18 +368,19 @@
val elaboratePat:
unit
- -> Apat.t * Env.t * (unit -> unit)
+ -> Apat.t * Env.t * {bind: bool} * (unit -> unit)
-> Cpat.t * (Avar.t * Var.t * Type.t) vector =
fn () =>
let
val others: (Apat.t * (Avar.t * Var.t * Type.t) vector) list ref = ref []
in
- fn (p: Apat.t, E: Env.t, preError: unit -> unit) =>
+ fn (p: Apat.t, E: Env.t, {bind}, preError: unit -> unit) =>
let
val region = Apat.region p
val xts: (Avar.t * Var.t * Type.t) list ref = ref []
fun bindToType (x: Avar.t, t: Type.t): Var.t =
let
+ val _ = ensureNotEquals x
val x' = Var.fromAst x
val _ =
if List.exists (!xts, fn (x', _, _) => Avar.equals (x, x'))
@@ -419,7 +420,11 @@
end
val _ = List.push (xts, (x, x', t))
- val _ = extendVar (E, x, x', Scheme.fromType t, region)
+ val _ =
+ if bind
+ then Env.extendVar (E, x, x', Scheme.fromType t,
+ {isRebind = false})
+ else ()
in
x'
end
@@ -953,7 +958,7 @@
in
Vector.foreach2
(types, strs, fn ({tycon, ...}, str) =>
- Env.extendTycon (E, tycon, str))
+ Env.extendTycon (E, tycon, str, {isRebind = false}))
end
fun elabDatBind (datBind: DatBind.t, nest: string list)
: Decs.t * {tycon: Ast.Tycon.t,
@@ -965,7 +970,7 @@
(* Build enough of an env so that that the withtypes and the
* constructor argument types can be elaborated.
*)
- val tycons =
+ val datatypes =
Vector.map
(datatypes, fn {cons, tycon = name, tyvars} =>
let
@@ -977,25 +982,38 @@
".")),
kind,
AdmitsEquality.Sometimes)
- val _ = Env.extendTycon (E, name, TypeStr.tycon (tycon, kind))
+ val _ = Env.extendTycon (E, name, TypeStr.tycon (tycon, kind),
+ {isRebind = false})
+ val cons =
+ Vector.map
+ (cons, fn (name, arg) =>
+ {con = Con.fromAst name,
+ name = name,
+ arg = arg})
+ val makeCons =
+ Env.newCons (E, Vector.map (cons, fn {con, name, ...} =>
+ {con = con, name = name}))
in
- tycon
+ {cons = cons,
+ makeCons = makeCons,
+ name = name,
+ tycon = tycon,
+ tyvars = tyvars}
end)
val change = ref false
fun elabAll () =
(elabTypBind withtypes
- ; (Vector.map2
- (tycons, datatypes,
- fn (tycon, {cons, tycon = astTycon, tyvars, ...}) =>
+ ; (Vector.map
+ (datatypes,
+ fn {cons, makeCons, name, tycon, tyvars} =>
let
val resultType: Type.t =
Type.con (tycon, Vector.map (tyvars, Type.var))
- val (cons, datatypeCons) =
+ val (schemes, datatypeCons) =
Vector.unzip
(Vector.map
- (cons, fn (name, arg) =>
+ (cons, fn {arg, con, name} =>
let
- val con = Con.fromAst name
val (arg, ty) =
case arg of
NONE => (NONE, resultType)
@@ -1009,10 +1027,8 @@
Scheme.make {canGeneralize = true,
ty = ty,
tyvars = tyvars}
- val _ = Env.extendCon (E, name, con, scheme)
in
- ({con = con, name = name, scheme = scheme},
- {arg = arg, con = con})
+ (scheme, {arg = arg, con = con})
end))
val _ =
let
@@ -1038,13 +1054,13 @@
val typeStr =
TypeStr.data (tycon,
Kind.Arity (Vector.length tyvars),
- Cons.T cons)
- val _ = Env.extendTycon (E, astTycon, typeStr)
+ makeCons schemes)
+ val _ = Env.extendTycon (E, name, typeStr, {isRebind = true})
in
({cons = datatypeCons,
tycon = tycon,
tyvars = tyvars},
- {tycon = astTycon,
+ {tycon = name,
typeStr = typeStr})
end)))
(* Maximize equality. *)
@@ -1120,7 +1136,8 @@
val _ =
Vector.foreach
(strs, fn {tycon, typeStr} =>
- Env.extendTycon (E, tycon, TypeStr.abs typeStr))
+ Env.extendTycon (E, tycon, TypeStr.abs typeStr,
+ {isRebind = false}))
in
Decs.append (decs, decs')
end
@@ -1130,13 +1147,9 @@
#1 (elabDatBind (datBind, nest))
| DatatypeRhs.Repl {lhs, rhs} => (* rule 18 *)
let
- val tyStr = Env.lookupLongtycon (E, rhs)
- val _ = Env.extendTycon (E, lhs, tyStr)
- val TypeStr.Cons.T v = TypeStr.cons tyStr
- val _ =
- Vector.foreach
- (v, fn {con, name, scheme} =>
- Env.extendCon (E, name, con, scheme))
+ val s = Env.lookupLongtycon (E, rhs)
+ val _ = Env.extendTycon (E, lhs, s,
+ {isRebind = false})
in
Decs.empty
end)
@@ -1275,7 +1288,8 @@
val var = Var.fromAst func
val ty = Type.new ()
val _ = Env.extendVar (E, func, var,
- Scheme.fromType ty)
+ Scheme.fromType ty,
+ {isRebind = false})
val _ = markFunc var
val _ =
Acon.ensureRedefine
@@ -1326,7 +1340,8 @@
Vector.map
(args, fn p =>
{pat = #1 (elaboratePat
- (p, E, preError)),
+ (p, E, {bind = true},
+ preError)),
region = Apat.region p})
val bodyRegion = Aexp.region body
val body = elabExp (body, nest, NONE)
@@ -1469,7 +1484,8 @@
Vector.foreach3
(fbs, decs, schemes,
fn ({func, ...}, {var, ...}, scheme) =>
- (Env.extendVar (E, func, var, scheme)
+ (Env.extendVar (E, func, var, scheme,
+ {isRebind = true})
; unmarkFunc var))
val decs =
Vector.map (decs, fn {lambda, var, ...} =>
@@ -1586,7 +1602,8 @@
(rvbs, fn {pat, match} =>
let
val region = Apat.region pat
- val (pat, bound) = elaboratePat (pat, E, preError)
+ val (pat, bound) =
+ elaboratePat (pat, E, {bind = false}, preError)
val (nest, var, ty) =
if 0 = Vector.length bound
then ("anon" :: nest,
@@ -1605,7 +1622,9 @@
(bound, fn (x, _, _) =>
(Acon.ensureRedefine (Avid.toCon
(Avid.fromVar x))
- ; Env.extendVar (E, x, var, scheme)
+ ; ensureNotEquals x
+ ; Env.extendVar (E, x, var, scheme,
+ {isRebind = false})
; (x, var, ty)))
in
{bound = bound,
@@ -1615,8 +1634,6 @@
region = region,
var = var}
end)
- val boundVars =
- Vector.concatV (Vector.map (rvbs, #bound))
val rvbs =
Vector.map
(rvbs, fn {bound, match, nest, pat, region, var, ...} =>
@@ -1654,6 +1671,10 @@
lambda = lambda,
var = var}
end)
+ val boundVars =
+ Vector.map
+ (Vector.concatV (Vector.map (rvbs, #bound)),
+ fn x => (x, {isRebind = true}))
val rvbs =
Vector.map
(rvbs, fn {bound, lambda, var} =>
@@ -1665,7 +1686,8 @@
(vbs,
fn {exp = e, expRegion, lay, pat, patRegion, ...} =>
let
- val (p, bound) = elaboratePat (pat, E, preError)
+ val (p, bound) =
+ elaboratePat (pat, E, {bind = false}, preError)
val _ =
unify
(Cpat.ty p, Cexp.ty e, fn (p, e) =>
@@ -1684,16 +1706,20 @@
end)
val boundVars =
Vector.concat
- [boundVars, Vector.concatV (Vector.map (vbs, #bound))]
- val {bound, schemes} = close (Vector.map (boundVars, #3))
+ [boundVars,
+ Vector.map
+ (Vector.concatV (Vector.map (vbs, #bound)),
+ fn x => (x, {isRebind = false}))]
+ val {bound, schemes} =
+ close (Vector.map (boundVars, #3 o #1))
val _ = checkSchemes (Vector.zip
- (Vector.map (boundVars, #2),
+ (Vector.map (boundVars, #2 o #1),
schemes))
val _ = setBound bound
val _ =
Vector.foreach2
- (boundVars, schemes, fn ((x, x', _), scheme) =>
- Env.extendVar (E, x, x', scheme))
+ (boundVars, schemes, fn (((x, x', _), ir), scheme) =>
+ Env.extendVar (E, x, x', scheme, ir))
val vbs =
Vector.map (vbs, fn {exp, lay, pat, patRegion, ...} =>
{exp = exp,
@@ -2254,7 +2280,8 @@
approximate
(seq [Apat.layout pat, str " => ", Aexp.layout exp])
end
- val (p, xts) = elaboratePat () (pat, E, preError)
+ val (p, xts) =
+ elaboratePat () (pat, E, {bind = true}, preError)
val _ =
unify
(Cpat.ty p, argType, preError, fn (l1, l2) =>
1.67 +797 -170 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- elaborate-env.fun 13 Feb 2004 17:05:56 -0000 1.66
+++ elaborate-env.fun 16 Feb 2004 22:42:10 -0000 1.67
@@ -68,6 +68,8 @@
structure TypeScheme = Scheme
+val insideFunctor = ref false
+
structure Scope =
struct
structure Unique = UniqueId ()
@@ -88,6 +90,45 @@
fun equals (s, s') = Unique.equals (unique s, unique s')
end
+structure Uses:
+ sig
+ type 'a t
+
+ val add: 'a t * 'a -> unit
+ val all: 'a t -> 'a list
+ val clear: 'a t -> unit
+ val forceUsed: 'a t -> unit
+ val hasUse: 'a t -> bool
+ val isUsed: 'a t -> bool
+ val new: unit -> 'a t
+ end =
+ struct
+ datatype 'a t = T of {direct: 'a list ref,
+ forceUsed: bool ref}
+
+ fun new () = T {direct = ref [],
+ forceUsed = ref false}
+
+ fun add (T {direct, ...}, a) = List.push (direct, a)
+
+ fun forceUsed (T {forceUsed = r, ...}) = r := true
+
+ fun clear (T {direct, ...}) = direct := []
+
+ fun wrap u = u
+
+ fun 'a accum (T {direct, ...}, ac: 'a list): 'a list =
+ List.fold (!direct, ac, op ::)
+
+ fun all (T {direct, ...}) = !direct
+
+ fun hasUse (T {direct, ...}): bool =
+ not (List.isEmpty (!direct))
+
+ fun isUsed (u as T {forceUsed, ...}): bool =
+ !forceUsed orelse hasUse u
+ end
+
structure Vid =
struct
datatype t =
@@ -140,44 +181,149 @@
fun layoutSize z = Int.layout (MLton.size z)
-structure TypeStr = TypeStr (structure AdmitsEquality = AdmitsEquality
- structure Con = Con
- structure Kind = Tycon.Kind
- structure Name = Ast.Con
- structure Record = SortedRecord
- structure Scheme =
- struct
- open Scheme
-
- val make =
- fn (tyvars, ty) =>
- make {canGeneralize = true,
- ty = ty,
- tyvars = tyvars}
- end
- structure Tycon =
- struct
- open Tycon
-
- val admitsEquality =
- TypeEnv.tyconAdmitsEquality
-
- val make = newNoname
- end
- structure Type =
- struct
- open Type
-
- val bogus = new ()
-
- fun hom (t, {con, record, var}) =
- Type.hom (t, {con = con,
- expandOpaque = false,
- record = record,
- replaceCharWithWord8 = false,
- var = var})
- end
- structure Tyvar = Tyvar)
+structure TypeStr =
+ struct
+ structure AdmitsEquality = AdmitsEquality
+ structure Kind = Kind
+ structure Scheme =
+ struct
+ open Scheme
+
+ val make =
+ fn (tyvars, ty) =>
+ make {canGeneralize = true,
+ ty = ty,
+ tyvars = tyvars}
+ end
+
+ structure Tycon =
+ struct
+ open Tycon
+
+ val admitsEquality = TypeEnv.tyconAdmitsEquality
+
+ val make = newNoname
+ end
+
+ structure Type =
+ struct
+ open Type
+
+ fun hom (t, {con, record, var}) =
+ Type.hom (t, {con = con,
+ expandOpaque = false,
+ record = record,
+ replaceCharWithWord8 = false,
+ var = var})
+ end
+
+ structure Cons =
+ struct
+ datatype t = T of {con: Con.t,
+ name: Ast.Con.t,
+ scheme: Scheme.t,
+ uses: Ast.Vid.t Uses.t} vector
+
+ val empty = T (Vector.new0 ())
+
+ fun layout (T v) =
+ Vector.layout (fn {name, scheme, ...} =>
+ let
+ open Layout
+ in
+ seq [Ast.Con.layout name,
+ str ": ", Scheme.layout scheme]
+ end)
+ v
+ end
+
+ datatype node =
+ Datatype of {cons: Cons.t,
+ tycon: Tycon.t}
+ | Scheme of Scheme.t
+ | Tycon of Tycon.t
+
+ datatype t = T of {kind: Kind.t,
+ node: node}
+
+ local
+ fun make f (T r) = f r
+ in
+ val kind = make #kind
+ val node = make #node
+ end
+
+ fun layout t =
+ let
+ open Layout
+ in
+ case node t of
+ Datatype {tycon, cons} =>
+ seq [str "Datatype ",
+ record [("tycon", Tycon.layout tycon),
+ ("cons", Cons.layout cons)]]
+ | Scheme s => Scheme.layout s
+ | Tycon t => seq [str "Tycon ", Tycon.layout t]
+ end
+
+ fun admitsEquality (s: t): AdmitsEquality.t =
+ case node s of
+ Datatype {tycon = c, ...} => ! (Tycon.admitsEquality c)
+ | Scheme s => if Scheme.admitsEquality s
+ then AdmitsEquality.Sometimes
+ else AdmitsEquality.Never
+ | Tycon c => ! (Tycon.admitsEquality c)
+
+ fun bogus (k: Kind.t): t =
+ T {kind = k,
+ node = Scheme (Scheme.bogus ())}
+
+ fun abs t =
+ case node t of
+ Datatype {tycon, ...} => T {kind = kind t,
+ node = Tycon tycon}
+ | _ => t
+
+ fun apply (t: t, tys: Type.t vector): Type.t =
+ case node t of
+ Datatype {tycon, ...} => Type.con (tycon, tys)
+ | Scheme s => Scheme.apply (s, tys)
+ | Tycon t => Type.con (t, tys)
+
+ fun cons t =
+ case node t of
+ Datatype {cons, ...} => cons
+ | _ => Cons.empty
+
+ fun data (tycon, kind, cons) =
+ T {kind = kind,
+ node = Datatype {tycon = tycon, cons = cons}}
+
+ fun def (s: Scheme.t, k: Kind.t) =
+ let
+ val (tyvars, ty) = Scheme.dest s
+ in
+ T {kind = k,
+ node = (case Type.deEta (ty, tyvars) of
+ NONE => Scheme s
+ | SOME c => Tycon c)}
+ end
+
+ fun isTycon s =
+ case node s of
+ Datatype _ => false
+ | Scheme _ => false
+ | Tycon _ => true
+
+ fun toTyconOpt s =
+ case node s of
+ Datatype {tycon, ...} => SOME tycon
+ | Scheme _ => NONE
+ | Tycon c => SOME c
+
+ fun tycon (c, kind) = T {kind = kind,
+ node = Tycon c}
+ end
local
open TypeStr
@@ -195,6 +341,158 @@
structure Status = Status
end
+structure Interface =
+ struct
+ structure Econs = Cons
+ structure Escheme = Scheme
+ structure Etycon = Tycon
+ structure Etype = Type
+ structure EtypeStr = TypeStr
+ open Interface
+
+ fun flexibleTyconToEnv (c: FlexibleTycon.t): EtypeStr.t =
+ let
+ datatype z = datatype FlexibleTycon.dest
+ in
+ case FlexibleTycon.dest c of
+ ETypeStr s => s
+ | TypeStr s => typeStrToEnv s
+ end
+ and tyconToEnv (t: Tycon.t): EtypeStr.t =
+ let
+ open Tycon
+ in
+ case t of
+ Flexible c => flexibleTyconToEnv c
+ | Rigid (c, k) => EtypeStr.tycon (c, k)
+ end
+ and typeToEnv (t: Type.t): Etype.t =
+ Type.hom (t, {con = fn (c, ts) => EtypeStr.apply (tyconToEnv c, ts),
+ record = Etype.record,
+ var = Etype.var})
+ and schemeToEnv (Scheme.T {ty, tyvars}): Escheme.t =
+ Escheme.make {canGeneralize = true,
+ ty = typeToEnv ty,
+ tyvars = tyvars}
+ and consToEnv (Cons.T v): Econs.t =
+ Econs.T (Vector.map (v, fn {name, scheme} =>
+ {con = Con.newNoname (),
+ name = name,
+ scheme = schemeToEnv scheme,
+ uses = Uses.new ()}))
+ and typeStrToEnv (s: TypeStr.t): EtypeStr.t =
+ let
+ val k = TypeStr.kind s
+ datatype z = datatype TypeStr.node
+ in
+ case TypeStr.node s of
+ Datatype {cons, tycon} =>
+ let
+ val tycon: Etycon.t =
+ case tycon of
+ Tycon.Flexible c =>
+ let
+ val typeStr = flexibleTyconToEnv c
+ in
+ case EtypeStr.node typeStr of
+ EtypeStr.Datatype {tycon, ...} => tycon
+ | EtypeStr.Tycon c => c
+ | _ =>
+ let
+ open Layout
+ in
+ Error.bug
+ (toString
+ (seq [str "datatype ",
+ TypeStr.layout s,
+ str " realized with scheme ",
+ EtypeStr.layout typeStr]))
+ end
+ end
+ | Tycon.Rigid (c, _) => c
+ in
+ EtypeStr.data (tycon, k, consToEnv cons)
+ end
+ | Scheme s => EtypeStr.def (schemeToEnv s, k)
+ | Tycon c => EtypeStr.abs (tyconToEnv c)
+ end
+
+ structure Tycon =
+ struct
+ open Tycon
+
+ val fromEnv = Rigid
+ end
+
+ structure Type =
+ struct
+ open Type
+
+ fun fromEnv (t: Etype.t): t =
+ let
+ fun con (c, ts) =
+ Type.con (Tycon.fromEnv (c, Kind.Arity (Vector.length ts)),
+ ts)
+ in
+ Etype.hom (t, {con = con,
+ expandOpaque = false,
+ record = record,
+ replaceCharWithWord8 = false,
+ var = var})
+ end
+ end
+
+ structure Scheme =
+ struct
+ open Scheme
+
+ val toEnv = schemeToEnv
+
+ fun fromEnv (s: Escheme.t): t =
+ let
+ val (tyvars, ty) = Escheme.dest s
+ in
+ Scheme.T {ty = Type.fromEnv ty,
+ tyvars = tyvars}
+ end
+ end
+
+ structure Cons =
+ struct
+ open Cons
+
+ fun fromEnv (Econs.T v): t =
+ T (Vector.map (v, fn {name, scheme, ...} =>
+ {name = name,
+ scheme = Scheme.fromEnv scheme}))
+ end
+
+ structure TypeStr =
+ struct
+ open TypeStr
+
+ val toEnv = typeStrToEnv
+
+ fun fromEnv (s: EtypeStr.t) =
+ let
+ val kind = EtypeStr.kind s
+ in
+ case EtypeStr.node s of
+ EtypeStr.Datatype {cons, tycon} =>
+ data (Tycon.fromEnv (tycon, kind),
+ kind,
+ Cons.fromEnv cons)
+ | EtypeStr.Scheme s => def (Scheme.fromEnv s, kind)
+ | EtypeStr.Tycon c =>
+ tycon (Tycon.fromEnv (c, kind), kind)
+ end
+
+ val fromEnv =
+ Trace.trace ("Interface.TypeStr.fromEnv", EtypeStr.layout, layout)
+ fromEnv
+ end
+ end
+
structure Status =
struct
open Status
@@ -209,8 +507,8 @@
struct
(* The array is sorted by domain element. *)
datatype ('a, 'b) t = T of {domain: 'a,
- isUsed: bool ref,
- range: 'b} array
+ range: 'b,
+ uses: 'a Uses.t} array
fun bogus () = T (Array.tabulate (0, fn _ => Error.bug "impossible"))
@@ -222,32 +520,34 @@
fun foreach (T a, f) =
Array.foreach (a, fn {domain, range, ...} => f (domain, range))
+ fun forceUsed (T a) = Array.foreach (a, Uses.forceUsed o #uses)
+
fun peek (T a, domain: 'a, toSymbol: 'a -> Symbol.t) =
Option.map
(BinarySearch.search (a, fn {domain = d, ...} =>
Symbol.compare (toSymbol domain, toSymbol d)),
fn i =>
let
- val v as {isUsed, ...} = Array.sub (a, i)
- val _ = isUsed := !Control.showBasisUsed
+ val v as {uses, ...} = Array.sub (a, i)
+ val _ = Uses.add (uses, domain)
in
v
end)
val map: ('a, 'b) t * ('b -> 'b) -> ('a, 'b) t =
fn (T a, f) =>
- T (Array.map (a, fn {domain, range, ...} =>
+ T (Array.map (a, fn {domain, range, uses} =>
{domain = domain,
- isUsed = ref false,
- range = f range}))
+ range = f range,
+ uses = uses}))
val map2: ('a, 'b) t * ('a, 'b) t * ('b * 'b -> 'b) -> ('a, 'b) t =
fn (T a, T a', f) =>
T (Array.map2
- (a, a', fn ({domain, range = r, ...}, {range = r', ...}) =>
+ (a, a', fn ({domain, range = r, uses}, {range = r', ...}) =>
{domain = domain,
- isUsed = ref false,
- range = f (r, r')}))
+ range = f (r, r'),
+ uses = uses}))
end
val allTycons: Tycon.t list ref = ref (List.map (Tycon.prims, #1))
@@ -325,6 +625,42 @@
Trace.trace2 ("Structure.hasInterface", layout, Interface.layout,
Bool.layout) hasInterface
+ local
+ datatype handleUses = Clear | Force
+ fun make handleUses =
+ let
+ fun loop (T f) =
+ let
+ fun doit (sel, forceRange) =
+ let
+ val Info.T a = sel f
+ in
+ Array.foreach
+ (a, fn {range, uses, ...} =>
+ let
+ val _ =
+ case handleUses of
+ Clear => Uses.clear uses
+ | Force => Uses.forceUsed uses
+ val _ = forceRange range
+ in
+ ()
+ end)
+ end
+ val _ = doit (#strs, loop)
+ val _ = doit (#types, ignore)
+ val _ = doit (#vals, ignore)
+ in
+ ()
+ end
+ in
+ loop
+ end
+ in
+ val clearUsed = make Clear
+ val forceUsed = make Force
+ end
+
fun realize (S: t, I: Interface.t, realizeTycon) =
let
type data = {nest: Strid.t list,
@@ -429,12 +765,13 @@
let
fun doit (Info.T a, layout) =
align (Array.foldr
- (a, [], fn ({domain, isUsed, range, ...}, ac) =>
- if not showUsed orelse !isUsed
- then (case layout (domain, range) of
- NONE => ac
- | SOME l => l :: ac)
- else ac))
+ (a, [], fn ({domain, range, uses}, ac) =>
+ if showUsed andalso not (Uses.hasUse uses)
+ then ac
+ else
+ case layout (domain, range) of
+ NONE => ac
+ | SOME l => l :: ac))
in
align
[str "sig",
@@ -519,10 +856,10 @@
fun make toSymbol =
let
val r = ref []
- fun add {domain, range} =
+ fun add {domain, range, uses} =
List.push (r, {domain = domain,
- isUsed = ref false,
- range = range})
+ range = range,
+ uses = uses})
fun done () =
Info.T
(QuickSort.sortArray
@@ -563,6 +900,7 @@
fun make f (T r) = f r
in
val argInterface = make #argInt
+ val result = make #result
end
fun layout _ = Layout.str "<functor closure>"
@@ -611,40 +949,59 @@
structure Values =
struct
type ('a, 'b) value = {domain: 'a,
- isUsed: bool ref,
range: 'b,
scope: Scope.t,
- time: Time.t}
+ time: Time.t,
+ uses: 'a Uses.t}
(* The domains of all elements in a values list have the same symbol. *)
datatype ('a, 'b) t = T of ('a, 'b) value list ref
fun new (): ('a, 'b) t = T (ref [])
- fun pop (T r) = List.pop r
-
fun isEmpty (T r) = List.isEmpty (Ref.! r)
fun ! (T r) = Ref.! r
+
+ fun pop (T r) = List.pop r
end
structure NameSpace =
struct
- datatype ('a, 'b) t = T of {current: ('a, 'b) Values.t list ref,
- lookup: 'a -> ('a, 'b) Values.t,
- toSymbol: 'a -> Symbol.t}
+ datatype ('a, 'b) t =
+ T of {class: string,
+ current: ('a, 'b) Values.t list ref,
+ defUses: {def: 'a,
+ time: Time.t,
+ uses: 'a Uses.t} list ref,
+ lookup: 'a -> ('a, 'b) Values.t,
+ region: 'a -> Region.t,
+ toSymbol: 'a -> Symbol.t}
fun values (T {lookup, ...}, a) = lookup a
- fun new {lookup, toSymbol} =
- T {current = ref [],
+ fun new {class, lookup, region, toSymbol} =
+ T {class = class,
+ current = ref [],
+ defUses = ref [],
lookup = lookup,
+ region = region,
toSymbol = toSymbol}
- fun peek (ns, a) =
+ fun newUses (T {defUses, ...}, def, time) =
+ let
+ val u = Uses.new ()
+ val _ = List.push (defUses, {def = def,
+ time = time,
+ uses = u})
+ in
+ u
+ end
+
+ fun peek (ns as T {toSymbol, ...}, a, {markUse: bool}) =
case Values.! (values (ns, a)) of
[] => NONE
- | {isUsed, range, ...} :: _ =>
- (isUsed := !Control.showBasisUsed
+ | {range, uses, ...} :: _ =>
+ (if markUse then Uses.add (uses, a) else ()
; SOME range)
fun collect (T {current, toSymbol, ...}: ('a, 'b) t)
@@ -658,12 +1015,12 @@
val elts =
List.revMap (!current, fn values =>
let
- val {domain, isUsed, range, ...} =
+ val {domain, range, uses, ...} =
Values.pop values
in
{domain = domain,
- isUsed = isUsed,
- range = range}
+ range = range,
+ uses = uses}
end)
val _ = current := old
val a =
@@ -729,7 +1086,9 @@
val {get = maybeAddTop: Symbol.t -> unit, ...} =
Property.get (Symbol.plist,
Property.initFun (fn s => List.push (topSymbols, s)))
- fun ('a, 'b) make (toSymbol,
+ fun ('a, 'b) make (class: string,
+ region: 'a -> Region.t,
+ toSymbol: 'a -> Symbol.t,
extract: All.t -> ('a, 'b) Values.t option,
make: ('a, 'b) Values.t -> All.t)
: ('a, 'b) NameSpace.t =
@@ -749,20 +1108,34 @@
| SOME v => v
end
in
- NameSpace.new {lookup = lookup,
+ NameSpace.new {class = class,
+ lookup = lookup,
+ region = region,
toSymbol = toSymbol}
end
+ val fcts = make ("functor", Fctid.region, Fctid.toSymbol,
+ All.fctOpt, All.Fct)
+ val fixs = make ("fixity", Ast.Vid.region, Ast.Vid.toSymbol,
+ All.fixOpt, All.Fix)
+ val sigs = make ("signature", Sigid.region, Sigid.toSymbol,
+ All.sigOpt, All.Sig)
+ val strs = make ("structure", Strid.region, Strid.toSymbol,
+ All.strOpt, All.Str)
+ val types = make ("type", Ast.Tycon.region, Ast.Tycon.toSymbol,
+ All.tycOpt, All.Tyc)
+ val vals = make ("variable", Ast.Vid.region, Ast.Vid.toSymbol,
+ All.valOpt, All.Val)
in
T {currentScope = ref (Scope.new {isTop = true}),
- fcts = make (Fctid.toSymbol, All.fctOpt, All.Fct),
- fixs = make (Ast.Vid.toSymbol, All.fixOpt, All.Fix),
+ fcts = fcts,
+ fixs = fixs,
lookup = lookupAll,
maybeAddTop = maybeAddTop,
- sigs = make (Sigid.toSymbol, All.sigOpt, All.Sig),
- strs = make (Strid.toSymbol, All.strOpt, All.Str),
+ sigs = sigs,
+ strs = strs,
topSymbols = topSymbols,
- types = make (Ast.Tycon.toSymbol, All.tycOpt, All.Tyc),
- vals = make (Ast.Vid.toSymbol, All.valOpt, All.Val)}
+ types = types,
+ vals = vals}
end
local
@@ -789,7 +1162,7 @@
end
fun collect (E as T r,
- keep: {isUsed: bool, scope: Scope.t} -> bool,
+ keep: {hasUse: bool, scope: Scope.t} -> bool,
le: {domain: Symbol.t, time: Time.t}
* {domain: Symbol.t, time: Time.t} -> bool) =
let
@@ -801,8 +1174,8 @@
fun doit ac vs =
case Values.! vs of
[] => ()
- | (z as {isUsed, scope, ...}) :: _ =>
- if keep {isUsed = !isUsed, scope = scope}
+ | (z as {scope, uses, ...}) :: _ =>
+ if keep {hasUse = Uses.hasUse uses, scope = scope}
then List.push (ac, z)
else ()
val _ =
@@ -930,13 +1303,13 @@
val strs =
Array.map (strs, fn (name, I) =>
{domain = name,
- isUsed = ref false,
- range = get I})
+ range = get I,
+ uses = Uses.new ()})
val types =
Array.map (types, fn (name, s) =>
{domain = name,
- isUsed = ref false,
- range = Interface.TypeStr.toEnv s})
+ range = Interface.TypeStr.toEnv s,
+ uses = Uses.new ()})
val vals =
Array.map (vals, fn (name, (status, scheme)) =>
let
@@ -949,8 +1322,8 @@
| Status.Var => Vid.Var (var name)
in
{domain = name,
- isUsed = ref false,
- range = (vid, Interface.Scheme.toEnv scheme)}
+ range = (vid, Interface.Scheme.toEnv scheme),
+ uses = Uses.new ()}
end)
in
Structure.T {interface = SOME I,
@@ -964,7 +1337,7 @@
List.foreach (tycons, fn (long, c) =>
case Structure.peekLongtycon (S', long) of
NONE => Error.bug "structure missing longtycon"
- | SOME s=> f (c, s))
+ | SOME s => f (c, s))
in
(S, instantiate)
end
@@ -1033,14 +1406,190 @@
{showUsed = false})
end
-fun layoutUsed (E: t): Layout.t = layout' (E, #isUsed, {showUsed = true})
+fun layoutUsed (E: t): Layout.t = layout' (E, #hasUse, {showUsed = true})
+
+fun clearDefUses (E as T f) =
+ let
+ fun doit sel =
+ let
+ val NameSpace.T {defUses, ...} = sel f
+ in
+ defUses := []
+ end
+ val _ = doit #fcts
+ val _ = doit #fixs
+ val _ = doit #sigs
+ val _ = doit #strs
+ val _ = doit #types
+ val _ = doit #vals
+ fun doit clearRange (Values.T r) =
+ case !r of
+ [] => ()
+ | {range, uses, ...} :: _ =>
+ (Uses.clear uses
+ ; clearRange range)
+ val _ =
+ foreachDefinedSymbol
+ (E, {fcts = doit ignore,
+ fixs = doit ignore,
+ sigs = doit ignore,
+ strs = doit Structure.clearUsed,
+ types = doit ignore,
+ vals = doit ignore})
+ in
+ ()
+ end
+
+(* Force everything that is currently in scope to be marked as used. *)
+fun forceUsed (E as T f) =
+ let
+ fun doit forceRange (Values.T r) =
+ case !r of
+ [] => ()
+ | {uses, range, ...} :: _ =>
+ (Uses.forceUsed uses
+ ; forceRange range)
+ val _ =
+ foreachDefinedSymbol
+ (E, {fcts = doit (fn f => Option.app (FunctorClosure.result f,
+ Structure.forceUsed)),
+ fixs = doit ignore,
+ sigs = doit ignore,
+ strs = doit Structure.forceUsed,
+ types = doit ignore,
+ vals = doit ignore})
+ in
+ ()
+ end
+
+fun processDefUse (E as T f) =
+ let
+ val _ = forceUsed E
+ val all: {class: string,
+ def: Layout.t,
+ isUsed: bool,
+ region: Region.t,
+ uses: Region.t list} list ref = ref []
+ fun doit sel =
+ let
+ val NameSpace.T {class, defUses, region, toSymbol, ...} = sel f
+ in
+ List.foreach
+ (!defUses, fn {def, uses, ...} =>
+ List.push
+ (all, {class = class,
+ def = Symbol.layout (toSymbol def),
+ isUsed = Uses.isUsed uses,
+ region = region def,
+ uses = List.fold (Uses.all uses, [], fn (u, ac) =>
+ region u :: ac)}))
+ end
+ val _ = doit #fcts
+ val _ = doit #sigs
+ val _ = doit #strs
+ val _ = doit #types
+ val _ = doit #vals
+ val a = Array.fromList (!all)
+ val _ =
+ QuickSort.sortArray (a, fn ({region = r, ...}, {region = r', ...}) =>
+ Region.<= (r, r'))
+ val l =
+ Array.foldr
+ (a, [], fn (z as {class, def, isUsed, region, uses}, ac) =>
+ case ac of
+ [] => [z]
+ | (z' as {isUsed = i', region = r', uses = u', ...}) :: ac' =>
+ if Region.equals (region, r')
+ then {class = class,
+ def = def,
+ isUsed = isUsed orelse i',
+ region = region,
+ uses = uses @ u'} :: ac'
+ else z :: ac)
+ val _ =
+ if not (!Control.warnUnused)
+ then ()
+ else
+ List.foreach
+ (l, fn {class, def, isUsed, region, ...} =>
+ if isUsed orelse Option.isNone (Region.left region)
+ then ()
+ else
+ let
+ open Layout
+ in
+ Control.warning
+ (region,
+ seq [str (concat ["unused ", class, ": "]), def],
+ empty)
+ end)
+ val _ =
+ case !Control.showDefUse of
+ NONE => ()
+ | SOME f =>
+ File.withOut
+ (f, fn out =>
+ List.foreach
+ (l, fn {def, region, uses, ...} =>
+ case Region.left region of
+ NONE => ()
+ | SOME p =>
+ let
+ val uses = Array.fromList uses
+ val _ = QuickSort.sortArray (uses, Region.<=)
+ val uses =
+ Array.foldr
+ (uses, [], fn (r, ac) =>
+ case ac of
+ [] => [r]
+ | r' :: _ =>
+ if Region.equals (r, r')
+ then ac
+ else r :: ac)
+ open Layout
+ in
+ outputl
+ (align [seq [str (concat [SourcePos.toString p, " "]),
+ def],
+ indent
+ (align
+ (List.map
+ (uses, fn r =>
+ str (concat [case Region.left r of
+ NONE => "NONE"
+ | SOME p =>
+ SourcePos.toString p,
+ " "]))),
+ 4)],
+ out)
+ end))
+ in
+ ()
+ end
+
+fun newCons (T {vals, ...}, v) =
+ let
+ val v =
+ Vector.map (v, fn {con, name} =>
+ {con = con,
+ name = name,
+ uses = NameSpace.newUses (vals, Ast.Vid.fromCon name,
+ Time.now ())})
+ in
+ fn v' => Cons.T (Vector.map2
+ (v, v', fn ({con, name, uses}, scheme) =>
+ {con = con,
+ name = name,
+ scheme = scheme,
+ uses = uses}))
+ end
(* ------------------------------------------------- *)
(* peek *)
(* ------------------------------------------------- *)
local
- fun make sel (T r, a) = NameSpace.peek (sel r, a)
+ fun make sel (T r, a) = NameSpace.peek (sel r, a, {markUse = true})
in
val peekFctid = make #fcts
val peekFix = make #fixs
@@ -1054,8 +1603,8 @@
| SOME (vid, s) => Option.map (Vid.deVar vid, fn x => (x, s))
end
-fun peekCon (E: t, c: Ast.Con.t): (Con.t * Scheme.t) option =
- case peekVid (E, Ast.Vid.fromCon c) of
+fun peekCon (T {vals, ...}, c: Ast.Con.t): (Con.t * Scheme.t) option =
+ case NameSpace.peek (vals, Ast.Vid.fromCon c, {markUse = false}) of
NONE => NONE
| SOME (vid, s) => Option.map (Vid.deCon vid, fn c => (c, s))
@@ -1212,19 +1761,51 @@
(* extend *)
(* ------------------------------------------------- *)
-val extend: t * ('a, 'b) NameSpace.t * {domain: 'a,
- isUsed: bool ref,
- range: 'b,
- scope: Scope.t,
- time: Time.t} -> unit =
+structure ExtendUses =
+ struct
+ datatype 'a t =
+ New
+ | Old of 'a Uses.t
+ | Rebind
+
+ fun fromIsRebind {isRebind} = if isRebind then Rebind else New
+ end
+
+val extend:
+ t * ('a, 'b) NameSpace.t * {domain: 'a,
+ forceUsed: bool,
+ range: 'b,
+ scope: Scope.t,
+ time: Time.t,
+ uses: 'a ExtendUses.t} -> unit =
fn (T {maybeAddTop, ...},
- NameSpace.T {current, lookup, toSymbol, ...},
- value as {domain, isUsed, range, scope, time}) =>
+ ns as NameSpace.T {current, defUses, lookup, toSymbol, ...},
+ {domain, forceUsed, range, scope, time, uses}) =>
let
+ fun newUses () =
+ let
+ val u = NameSpace.newUses (ns, domain, time)
+ val _ = if forceUsed then Uses.forceUsed u else ()
+ in
+ u
+ end
val values as Values.T r = lookup domain
+ datatype z = datatype ExtendUses.t
fun new () =
- (List.push (current, values)
- ; List.push (r, value))
+ let
+ val _ = List.push (current, values)
+ val uses =
+ case uses of
+ New => newUses ()
+ | Old u => u
+ | Rebind => Error.bug "rebind new"
+ in
+ {domain = domain,
+ range = range,
+ scope = scope,
+ time = time,
+ uses = uses}
+ end
in
case !r of
[] =>
@@ -1234,52 +1815,88 @@
then maybeAddTop (toSymbol domain)
else ()
in
- new ()
+ r := [new ()]
end
- | {scope = scope', ...} :: l =>
+ | all as ({scope = scope', uses = uses', ...} :: rest) =>
if Scope.equals (scope, scope')
- then r := value :: l
- else new ()
+ then
+ let
+ val uses =
+ case uses of
+ New => newUses ()
+ | Old u => u
+ | Rebind => uses'
+ in
+ r := {domain = domain,
+ range = range,
+ scope = scope,
+ time = time,
+ uses = uses} :: rest
+ end
+ else r := new () :: all
end
-
local
- fun make get (E as T (fields as {currentScope, ...}), domain, range) =
+ val extend =
+ fn (E as T (fields as {currentScope, ...}), get,
+ domain: 'a,
+ range: 'b,
+ forceUsed: bool,
+ uses: 'a ExtendUses.t) =>
let
val ns = get fields
in
extend (E, ns, {domain = domain,
- isUsed = ref false,
+ forceUsed = forceUsed,
range = range,
scope = !currentScope,
- time = Time.next ()})
+ time = Time.next (),
+ uses = uses})
end
in
- val extendFctid = make #fcts
- val extendFix = make #fixs
- val extendSigid = make #sigs
- val extendStrid = make #strs
- val extendTycon = make #types
- val extendVals = make #vals
+ fun extendFctid (E, d, r) = extend (E, #fcts, d, r, false, ExtendUses.New)
+ fun extendFix (E, d, r) = extend (E, #fixs, d, r, false, ExtendUses.New)
+ fun extendSigid (E, d, r) = extend (E, #sigs, d, r, false, ExtendUses.New)
+ fun extendStrid (E, d, r) = extend (E, #strs, d, r, false, ExtendUses.New)
+ fun extendVals (E, d, r, eu) = extend (E, #vals, d, r, false, eu)
+ fun extendTycon (E, d, s, ir) =
+ let
+ val forceUsed =
+ let
+ datatype z = datatype TypeStr.node
+ in
+ case TypeStr.node s of
+ Datatype _ => true
+ | Scheme _ => false
+ | Tycon _ => true
+ end
+ val _ = extend (E, #types, d, s, forceUsed, ExtendUses.fromIsRebind ir)
+ val Cons.T v = TypeStr.cons s
+ in
+ Vector.foreach
+ (v, fn {con, name, scheme, uses} =>
+ extendVals (E, Ast.Vid.fromCon name, (Vid.Con con, scheme),
+ ExtendUses.Old uses))
+ end
end
-
-fun extendCon (E, c, c', s) =
- extendVals (E, Ast.Vid.fromCon c, (Vid.Con c', s))
-
+
fun extendExn (E, c, c', s) =
- extendVals (E, Ast.Vid.fromCon c, (Vid.Exn c', s))
+ extendVals (E, Ast.Vid.fromCon c, (Vid.Exn c', s), ExtendUses.New)
-fun extendVar (E, x, x', s) =
- extendVals (E, Ast.Vid.fromVar x, (Vid.Var x', s))
+fun extendVar (E, x, x', s, ir) =
+ extendVals (E, Ast.Vid.fromVar x, (Vid.Var x', s),
+ ExtendUses.fromIsRebind ir)
val extendVar =
- Trace.trace4
- ("extendVar", Layout.ignore, Ast.Var.layout, Var.layout, Scheme.layoutPretty,
+ Trace.trace
+ ("extendVar",
+ fn (_, x, x', s, _) =>
+ Layout.tuple [Ast.Var.layout x, Var.layout x', Scheme.layoutPretty s],
Unit.layout)
extendVar
fun extendOverload (E, p, x, yts, s) =
- extendVals (E, Ast.Vid.fromVar x, (Vid.Overload (p, yts), s))
+ extendVals (E, Ast.Vid.fromVar x, (Vid.Overload (p, yts), s), ExtendUses.New)
(* ------------------------------------------------- *)
(* local *)
@@ -1299,16 +1916,17 @@
fn () =>
let
val c2 = !current
- val lift = List.map (c2, Values.pop)
+ val lift = List.revMap (c2, Values.pop)
val _ = List.foreach (c1, fn v => (Values.pop v; ()))
val _ = current := old
val _ =
- List.foreach (lift, fn {domain, isUsed, range, time, ...} =>
+ List.foreach (lift, fn {domain, range, time, uses, ...} =>
extend (E, ns, {domain = domain,
- isUsed = isUsed,
+ forceUsed = false,
range = range,
scope = s0,
- time = time}))
+ time = time,
+ uses = ExtendUses.Old uses}))
in
()
end
@@ -1396,7 +2014,7 @@
fun scope (T {currentScope, fixs, strs, types, vals, ...}, th) =
let
- fun doit (NameSpace.T {current, ...}) =
+ fun doit (ns as NameSpace.T {current, ...}) =
let
val old = !current
val _ = current := []
@@ -1418,7 +2036,7 @@
fun scopeAll (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, th) =
let
- fun doit (NameSpace.T {current, ...}) =
+ fun doit (ns as NameSpace.T {current, ...}) =
let
val old = !current
val _ = current := []
@@ -1439,7 +2057,7 @@
in
res
end
-
+
fun openStructure (E as T {currentScope, strs, vals, types, ...},
Structure.T {strs = strs',
vals = vals',
@@ -1447,12 +2065,13 @@
let
val scope = !currentScope
fun doit (ns, Info.T a) =
- Array.foreach (a, fn {domain, isUsed, range} =>
+ Array.foreach (a, fn {domain, range, uses} =>
extend (E, ns, {domain = domain,
- isUsed = isUsed,
+ forceUsed = false,
range = range,
scope = scope,
- time = Time.next ()}))
+ time = Time.next (),
+ uses = ExtendUses.Old uses}))
val _ = doit (strs, strs')
val _ = doit (vals, vals')
val _ = doit (types, types')
@@ -1465,15 +2084,15 @@
fun fixCons (Cons.T cs, Cons.T cs') =
Cons.T
(Vector.map
- (cs', fn {con, name, scheme} =>
+ (cs', fn {con, name, scheme, ...} =>
let
- val con =
+ val (con, uses) =
case Vector.peek (cs, fn {name = n, ...} =>
Ast.Con.equals (n, name)) of
- NONE => Con.bogus
- | SOME {con, ...} => con
+ NONE => (Con.bogus, Uses.new ())
+ | SOME {con, uses, ...} => (con, uses)
in
- {con = con, name = name, scheme = scheme}
+ {con = con, name = name, scheme = scheme, uses = uses}
end))
val (S', instantiate) = dummyStructure (E, I, {prefix = prefix,
tyconNewString = true})
@@ -1756,21 +2375,24 @@
" but not in structure: "])],
empty)
in
- bogus c
+ {domain = name,
+ range = bogus c,
+ uses = Uses.new ()}
end
else
let
- val {domain, range, ...} = Array.sub (structArray, i)
+ val {domain, range, uses} =
+ Array.sub (structArray, i)
in
if namesEqual (domain, name)
then (r := i + 1
- ; doit (name, range, c))
+ ; {domain = domain,
+ range = doit (name, range, c),
+ uses = uses})
else find (i + 1)
end
in
- {domain = name,
- isUsed = ref false,
- range = find (!r)}
+ find (!r)
end)
in
Info.T array
@@ -2034,14 +2656,14 @@
fun doit (NameSpace.T {current, ...}) (v as Values.T vs) =
case ! vs of
[] => ()
- | {domain, isUsed, range, ...} :: _ =>
+ | {domain, range, uses, ...} :: _ =>
List.push
(add, fn s0 =>
(List.push (vs, {domain = domain,
- isUsed = isUsed,
range = range,
scope = s0,
- time = Time.next ()})
+ time = Time.next (),
+ uses = uses})
; List.push (current, v)))
val _ =
foreachTopLevelSymbol (E, {fcts = doit fcts,
@@ -2103,8 +2725,6 @@
end
end
-val useFunctorSummary = ref false
-
fun functorClosure
(E: t,
prefix: string,
@@ -2127,7 +2747,7 @@
val _ = TypeEnv.tick {useBeforeDef = fn _ => Error.bug "functor tick"}
val (formal, instantiate) =
dummyStructure (E, argInt, {prefix = prefix, tyconNewString = false})
- val _ = useFunctorSummary := true
+ val _ = insideFunctor := true
(* Keep track of all tycons created during the instantiation of the
* functor. These will later become the generative tycons that will need
* to be recreated for each functor application.
@@ -2138,6 +2758,7 @@
*)
val _ = newTycons := []
val (_, result) = makeBody (formal, [])
+ val _ = Option.app (result, Structure.forceUsed)
val generative = !newTycons
val _ = allTycons := let
fun loop cs =
@@ -2151,16 +2772,17 @@
loop (!allTycons)
end
val _ = newTycons := []
- val _ = useFunctorSummary := false
+ val _ = insideFunctor := false
val restore =
if !Control.elaborateOnly
then fn f => f ()
else snapshot E
fun apply (actual, nest) =
- if not (!useFunctorSummary) andalso not (!Control.elaborateOnly)
+ if not (!insideFunctor) andalso not (!Control.elaborateOnly)
then restore (fn () => makeBody (actual, nest))
else
let
+ val _ = Structure.forceUsed actual
val {destroy = destroy1,
get = tyconTypeStr: Tycon.t -> TypeStr.t option,
set = setTyconTypeStr, ...} =
@@ -2205,10 +2827,11 @@
fun replaceCons (Cons.T v): Cons.t =
Cons.T
(Vector.map
- (v, fn {con, name, scheme} =>
+ (v, fn {con, name, scheme, uses} =>
{con = con,
name = name,
- scheme = replaceScheme scheme}))
+ scheme = replaceScheme scheme,
+ uses = uses}))
fun replaceTypeStr (s: TypeStr.t): TypeStr.t =
let
val k = TypeStr.kind s
@@ -2287,17 +2910,17 @@
vals: (Ast.Vid.t, Status.t * Scheme.t) NameSpace.t}
val allowDuplicates = ref false
-
+
fun extend (T (fields as {currentScope, ...}),
domain, range, kind: string, ns, region): unit =
let
val scope = !currentScope
val NameSpace.T {current, lookup, toSymbol, ...} = ns fields
fun value () = {domain = domain,
- isUsed = ref false,
range = range,
scope = scope,
- time = Time.next ()}
+ time = Time.next (),
+ uses = Uses.new ()}
val values as Values.T r = lookup domain
fun new () = (List.push (current, values)
; List.push (r, value ()))
@@ -2329,7 +2952,7 @@
val lookupSigid = fn (T {env, ...}, x) => lookupSigid (env, x)
local
- fun make sel (T r, a) = NameSpace.peek (sel r, a)
+ fun make sel (T r, a) = NameSpace.peek (sel r, a, {markUse = true})
in
val peekStrid = make #strs
val peekTycon = make #types
@@ -2421,7 +3044,7 @@
val extendVid =
fn (E, v, st, s) => extendVid (E, v, st, s, Ast.Vid.region v)
- fun extendCon (E, c, c', s) =
+ fun extendCon (E, c, s) =
extendVid (E, Ast.Vid.fromCon c, Status.Con, s)
fun extendExn (E, c, s) =
@@ -2441,15 +3064,19 @@
(fn _ => {strs = Values.new (),
types = Values.new (),
vals = Values.new ()}))
- fun make (sel, toSymbol: 'a -> Symbol.t): ('a, 'b) NameSpace.t =
- NameSpace.new {lookup = sel o lookupAll o toSymbol,
+ fun make (sel, class, region, toSymbol: 'a -> Symbol.t)
+ : ('a, 'b) NameSpace.t =
+ NameSpace.new {class = class,
+ lookup = sel o lookupAll o toSymbol,
+ region = region,
toSymbol = toSymbol}
in
- InterfaceEnv.T {currentScope = currentScope,
- env = env,
- strs = make (#strs, Strid.toSymbol),
- types = make (#types, Ast.Tycon.toSymbol),
- vals = make (#vals, Ast.Vid.toSymbol)}
+ InterfaceEnv.T
+ {currentScope = currentScope,
+ env = env,
+ strs = make (#strs, "structure", Strid.region, Strid.toSymbol),
+ types = make (#types, "type", Ast.Tycon.region, Ast.Tycon.toSymbol),
+ vals = make (#vals, "variable", Ast.Vid.region, Ast.Vid.toSymbol)}
end
val newTycon = fn (s, k, a) => newTycon (s, k, a, {newString = true})
1.27 +57 -14 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- elaborate-env.sig 11 Feb 2004 08:09:24 -0000 1.26
+++ elaborate-env.sig 16 Feb 2004 22:42:10 -0000 1.27
@@ -24,6 +24,9 @@
sig
include ELABORATE_ENV_STRUCTS
+ structure AdmitsEquality: ADMITS_EQUALITY
+ sharing AdmitsEquality = TypeEnv.Tycon.AdmitsEquality
+
structure Decs: DECS
sharing CoreML = Decs.CoreML
@@ -52,14 +55,44 @@
val layout: t -> Layout.t
end
- structure TypeStr: TYPE_STR
- sharing TypeStr.Con = CoreML.Con
+ structure TypeStr:
+ sig
+ structure Cons:
+ sig
+ type t
+
+ val empty: t
+ val layout: t -> Layout.t
+ end
+ structure Kind: TYCON_KIND
+ structure Tycon:
+ sig
+ type t
+ end
+
+ type t
+
+ datatype node =
+ Datatype of {cons: Cons.t,
+ tycon: Tycon.t}
+ | Scheme of Scheme.t
+ | Tycon of Tycon.t
+
+ val abs: t -> t
+ val admitsEquality: t -> AdmitsEquality.t
+ val apply: t * Type.t vector -> Type.t
+ val bogus: Kind.t -> t
+ val cons: t -> Cons.t
+ val data: Tycon.t * Kind.t * Cons.t -> t
+ val def: Scheme.t * Kind.t -> t
+ val kind: t -> Kind.t
+ val layout: t -> Layout.t
+ val node: t -> node
+ val toTyconOpt: t -> Tycon.t option (* NONE on Scheme *)
+ val tycon: Tycon.t * Kind.t -> t
+ end
sharing TypeStr.Kind = Tycon.Kind
- sharing TypeStr.Name = Ast.Con
- sharing TypeStr.Scheme = Scheme
sharing TypeStr.Tycon = CoreML.Tycon
- sharing TypeStr.Type = Type
- sharing TypeStr.Tyvar = Ast.Tyvar
structure Interface: INTERFACE
sharing Interface.Ast = Ast
sharing Interface.EnvTypeStr = TypeStr
@@ -67,10 +100,11 @@
sig
type t
- (* ffi represents MLtonFFI, which is built by the basis library
- * and is set in compile.sml after processing the basis.
+ (* ffi represents MLtonFFI, which is built by the basis library and
+ * set via the special _set_ffi topdec.
*)
val ffi: t option ref
+ val forceUsed: t -> unit
end
structure FunctorClosure:
sig
@@ -90,12 +124,15 @@
sig
type t
end
- structure TypeStr: TYPE_STR
+ structure TypeStr:
+ sig
+ type t
+ end
type t
val allowDuplicates: bool ref
- val extendCon: t * Ast.Con.t * CoreML.Con.t * Scheme.t -> unit
+ val extendCon: t * Ast.Con.t * Scheme.t -> unit
val extendExn: t * Ast.Con.t * Scheme.t -> unit
val extendStrid: t * Ast.Strid.t * Interface.t -> unit
val extendTycon: t * Ast.Tycon.t * TypeStr.t -> unit
@@ -112,6 +149,7 @@
type t
+ val clearDefUses: t -> unit
(* cut keeps only those bindings in the structure that also appear
* in the interface. It proceeds recursively on substructures.
*)
@@ -120,14 +158,14 @@
* {isFunctor: bool, opaque: bool, prefix: string} * Region.t
-> Structure.t * Decs.t
val empty: unit -> t
- val extendCon: t * Ast.Con.t * CoreML.Con.t * Scheme.t -> unit
val extendExn: t * Ast.Con.t * CoreML.Con.t * Scheme.t -> unit
val extendFctid: t * Ast.Fctid.t * FunctorClosure.t -> unit
val extendFix: t * Ast.Vid.t * Ast.Fixity.t -> unit
val extendSigid: t * Ast.Sigid.t * Interface.t -> unit
val extendStrid: t * Ast.Strid.t * Structure.t -> unit
- val extendTycon: t * Ast.Tycon.t * TypeStr.t -> unit
- val extendVar: t * Ast.Var.t * CoreML.Var.t * Scheme.t -> unit
+ val extendTycon: t * Ast.Tycon.t * TypeStr.t * {isRebind: bool} -> unit
+ val extendVar:
+ t * Ast.Var.t * CoreML.Var.t * Scheme.t * {isRebind: bool} -> unit
val extendOverload:
t * Ast.Priority.t * Ast.Var.t * (CoreML.Var.t * Type.t) vector * Scheme.t
-> unit
@@ -158,7 +196,11 @@
val lookupSigid: t * Ast.Sigid.t -> Interface.t option
val makeStructure: t * (unit -> 'a) -> 'a * Structure.t
val makeInterfaceEnv: t -> InterfaceEnv.t
- val newTycon: string * Tycon.Kind.t * Tycon.AdmitsEquality.t -> Tycon.t
+ val newCons: ((t * {con: CoreML.Con.t,
+ name: Ast.Con.t} vector)
+ -> Scheme.t vector
+ -> TypeStr.Cons.t)
+ val newTycon: string * Tycon.Kind.t * AdmitsEquality.t -> Tycon.t
(* openStructure (E, S) opens S in the environment E. *)
val openStructure: t * Structure.t -> unit
val peekFix: t * Ast.Vid.t -> Ast.Fixity.t option
@@ -173,5 +215,6 @@
val scopeAll: t * (unit -> 'a) -> 'a
val setTyconNames: t -> unit
val sizeMessage: t -> Layout.t
+ val processDefUse: t -> unit
end
1.17 +10 -19 mlton/mlton/elaborate/elaborate-sigexp.fun
Index: elaborate-sigexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-sigexp.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- elaborate-sigexp.fun 6 Feb 2004 21:57:27 -0000 1.16
+++ elaborate-sigexp.fun 16 Feb 2004 22:42:10 -0000 1.17
@@ -41,19 +41,14 @@
local
open Interface
in
- structure Status = Status
- structure Tycon = Tycon
- structure TypeStr = TypeStr
-end
-
-local
- open TypeStr
-in
structure AdmitsEquality = AdmitsEquality
structure Cons = Cons
structure Kind = Kind
structure Scheme = Scheme
+ structure Status = Status
+ structure Tycon = Tycon
structure Type = Type
+ structure TypeStr = TypeStr
end
fun elaborateType (ty: Atype.t, E: Env.t): Tyvar.t vector * Type.t =
@@ -212,7 +207,6 @@
(Vector.map
(cons, fn (name, arg) =>
let
- val con = Con.newString "FOO"
val (makeArg, ty) =
case arg of
NONE => (fn _ => NONE, resultType)
@@ -222,8 +216,7 @@
Atype.arrow (t, resultType))
val scheme = elaborateScheme (tyvars, ty, E)
in
- ({con = con,
- name = name,
+ ({name = name,
scheme = scheme},
makeArg scheme)
end))
@@ -246,10 +239,8 @@
then ()
else (r := Never; change := true)
end
- val _ =
- Vector.foreach
- (cons, fn {con, name, scheme} =>
- Env.extendCon (E, name, con, scheme))
+ val _ = Vector.foreach (cons, fn {name, scheme} =>
+ Env.extendCon (E, name, scheme))
val _ = Env.allowDuplicates := true
val _ =
Env.extendTycon
@@ -333,11 +324,11 @@
(Env.lookupLongtycon (E, rhs), fn s =>
let
val _ = Env.extendTycon (E, lhs, s)
- val TypeStr.Cons.T v = TypeStr.cons s
+ val Cons.T v = TypeStr.cons s
val _ =
Vector.foreach
- (v, fn {con, name, scheme} =>
- Env.extendCon (E, name, con, scheme))
+ (v, fn {name, scheme} =>
+ Env.extendCon (E, name, scheme))
in
()
end))
@@ -350,7 +341,7 @@
| Spec.Exception cons =>
(* rule 73 *)
List.foreach
- (cons, fn (name: TypeStr.Name.t, arg: Ast.Type.t option) =>
+ (cons, fn (name: Ast.Con.t, arg: Ast.Type.t option) =>
let
val (arg, ty) =
case arg of
1.21 +12 -3 mlton/mlton/elaborate/elaborate.fun
Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- elaborate.fun 11 Feb 2004 08:09:24 -0000 1.20
+++ elaborate.fun 16 Feb 2004 22:42:10 -0000 1.21
@@ -70,8 +70,6 @@
structure Decs = Decs
structure Env = Env)
-val allowRebindEquals = ElaborateCore.allowRebindEquals
-
val info = Trace.info "elaborateStrdec"
val info' = Trace.info "elaborateTopdec"
@@ -217,7 +215,17 @@
Trace.traceInfo' (info', Topdec.layout, Decs.layout)
(fn (d: Topdec.t) =>
case Topdec.node d of
- Topdec.Strdec d => elabStrdec (d, [])
+ Topdec.BasisDone {ffi} =>
+ let
+ val _ = ElaborateCore.allowRebindEquals := false
+ val _ =
+ Option.app
+ (Env.lookupLongstrid (E, ffi), fn S =>
+ (Env.Structure.ffi := SOME S
+ ; Env.Structure.forceUsed S))
+ in
+ Decs.empty
+ end
| Topdec.Signature sigbinds =>
(Vector.foreach
(sigbinds, fn (sigid, sigexp) =>
@@ -226,6 +234,7 @@
NONE => Interface.empty
| SOME I => I))
; Decs.empty)
+ | Topdec.Strdec d => elabStrdec (d, [])
| Topdec.Functor funbinds =>
(* Appendix A, p.58 *)
(Vector.foreach
1.7 +0 -1 mlton/mlton/elaborate/elaborate.sig
Index: elaborate.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- elaborate.sig 6 Feb 2004 23:55:36 -0000 1.6
+++ elaborate.sig 16 Feb 2004 22:42:10 -0000 1.7
@@ -28,7 +28,6 @@
structure Decs: DECS
structure Env: ELABORATE_ENV
- val allowRebindEquals: bool ref
val elaborateProgram:
Ast.Program.t * Env.t * (string * ConstType.t -> CoreML.Const.t)
-> Decs.t
1.23 +128 -154 mlton/mlton/elaborate/interface.fun
Index: interface.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.fun,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- interface.fun 12 Feb 2004 19:06:25 -0000 1.22
+++ interface.fun 16 Feb 2004 22:42:10 -0000 1.23
@@ -29,12 +29,8 @@
open EtypeStr
in
structure AdmitsEquality = AdmitsEquality
- structure Con = Con
- structure Econs = Cons
structure Kind = Kind
- structure Escheme = Scheme
structure Etycon = Tycon
- structure Etype = Type
end
structure Set = DisjointSet
@@ -75,7 +71,7 @@
end
(* only needed for debugging *)
-structure TyconId = IntUniqueId()
+structure TyconId = IntUniqueId ()
structure Defn =
struct
@@ -130,17 +126,16 @@
plist: PropertyList.t} Set.t
withtype copy = t option ref
- fun dest (T s) = Set.value s
+ fun fields (T s) = Set.value s
local
- fun make f = f o dest
+ fun make f = f o fields
in
+ val admitsEquality = make #admitsEquality
val defn = ! o make #defn
val plist = make #plist
end
- fun admitsEquality t = #admitsEquality (dest t)
-
val equals = fn (T s, T s') => Set.equals (s, s')
fun layout (T s) =
@@ -170,8 +165,6 @@
structure Tycon =
struct
- structure AdmitsEquality = AdmitsEquality
-
datatype t =
Flexible of FlexibleTycon.t
| Rigid of Etycon.t * Kind.t
@@ -318,18 +311,115 @@
fun make (tyvars, ty) = T {ty = ty, tyvars = tyvars}
end
-structure TypeStr = TypeStr (structure AdmitsEquality = AdmitsEquality
- structure Con = Con
- structure Kind = Kind
- structure Name = Ast.Con
- structure Record = Record
- structure Scheme = Scheme
- structure Tycon = Tycon
- structure Type = Type
- structure Tyvar = Tyvar)
+structure Cons =
+ struct
+ datatype t = T of {name: Ast.Con.t,
+ scheme: Scheme.t} vector
+
+ val empty = T (Vector.new0 ())
+
+ fun layout (T v) =
+ Vector.layout (fn {name, scheme} =>
+ let
+ open Layout
+ in
+ seq [Ast.Con.layout name,
+ str ": ",
+ Scheme.layout scheme]
+ end)
+ v
+ end
+
+structure TypeStr =
+ struct
+ datatype node =
+ Datatype of {cons: Cons.t,
+ tycon: Tycon.t}
+ | Scheme of Scheme.t
+ | Tycon of Tycon.t
+
+ datatype t = T of {kind: Kind.t,
+ node: node}
+
+ local
+ fun make f (T r) = f r
+ in
+ val kind = make #kind
+ val node = make #node
+ end
-structure Cons = TypeStr.Cons
+ fun layout t =
+ let
+ open Layout
+ in
+ case node t of
+ Datatype {tycon, cons} =>
+ seq [str "Datatype ",
+ record [("tycon", Tycon.layout tycon),
+ ("cons", Cons.layout cons)]]
+ | Scheme s => Scheme.layout s
+ | Tycon t => seq [str "Tycon ", Tycon.layout t]
+ end
+
+ fun admitsEquality (s: t): AdmitsEquality.t =
+ case node s of
+ Datatype {tycon = c, ...} => ! (Tycon.admitsEquality c)
+ | Scheme s => if Scheme.admitsEquality s
+ then AdmitsEquality.Sometimes
+ else AdmitsEquality.Never
+ | Tycon c => ! (Tycon.admitsEquality c)
+
+ fun bogus (k: Kind.t): t =
+ T {kind = k,
+ node = Scheme (Scheme.bogus ())}
+
+ fun abs t =
+ case node t of
+ Datatype {tycon, ...} => T {kind = kind t,
+ node = Tycon tycon}
+ | _ => t
+
+ fun apply (t: t, tys: Type.t vector): Type.t =
+ case node t of
+ Datatype {tycon, ...} => Type.con (tycon, tys)
+ | Scheme s => Scheme.apply (s, tys)
+ | Tycon t => Type.con (t, tys)
+
+ fun cons t =
+ case node t of
+ Datatype {cons, ...} => cons
+ | _ => Cons.empty
+
+ fun data (tycon, kind, cons) =
+ T {kind = kind,
+ node = Datatype {tycon = tycon, cons = cons}}
+ fun def (s: Scheme.t, k: Kind.t) =
+ let
+ val (tyvars, ty) = Scheme.dest s
+ in
+ T {kind = k,
+ node = (case Type.deEta (ty, tyvars) of
+ NONE => Scheme s
+ | SOME c => Tycon c)}
+ end
+
+ fun isTycon s =
+ case node s of
+ Datatype _ => false
+ | Scheme _ => false
+ | Tycon _ => true
+
+ fun toTyconOpt s =
+ case node s of
+ Datatype {tycon, ...} => SOME tycon
+ | Scheme _ => NONE
+ | Tycon c => SOME c
+
+ fun tycon (c, kind) = T {kind = kind,
+ node = Tycon c}
+ end
+
structure Defn =
struct
open Defn
@@ -370,9 +460,8 @@
end
fun copyCons (Cons.T v): Cons.t =
- Cons.T (Vector.map (v, fn {con, name, scheme} =>
- {con = con,
- name = name,
+ Cons.T (Vector.map (v, fn {name, scheme} =>
+ {name = name,
scheme = copyScheme scheme}))
and copyDefn (d: Defn.t): Defn.t =
let
@@ -429,71 +518,6 @@
| Tycon c => tycon (copyTycon c, kind)
end
-fun flexibleTyconToEnv (c: FlexibleTycon.t): EtypeStr.t =
- let
- open FlexibleTycon
- in
- case Defn.dest (defn c) of
- Defn.Realized s => s
- | Defn.TypeStr s => typeStrToEnv s
- | _ => Error.bug "FlexiblTycon.toEnv"
- end
-and tyconToEnv (t: Tycon.t): EtypeStr.t =
- let
- open Tycon
- in
- case t of
- Flexible c => flexibleTyconToEnv c
- | Rigid (c, k) => EtypeStr.tycon (c, k)
- end
-and typeToEnv (t: Type.t): Etype.t =
- Type.hom (t, {con = fn (c, ts) => EtypeStr.apply (tyconToEnv c, ts),
- record = Etype.record,
- var = Etype.var})
-and schemeToEnv (Scheme.T {ty, tyvars}): Escheme.t =
- Escheme.make (tyvars, typeToEnv ty)
-and consToEnv (Cons.T v): Econs.t =
- Econs.T (Vector.map (v, fn {con, name, scheme} =>
- {con = con,
- name = name,
- scheme = schemeToEnv scheme}))
-and typeStrToEnv (s: TypeStr.t): EtypeStr.t =
- let
- val k = TypeStr.kind s
- datatype z = datatype TypeStr.node
- in
- case TypeStr.node s of
- Datatype {cons, tycon} =>
- let
- val tycon: Etycon.t =
- case tycon of
- Tycon.Flexible c =>
- let
- val typeStr = flexibleTyconToEnv c
- in
- case EtypeStr.node typeStr of
- EtypeStr.Datatype {tycon, ...} => tycon
- | EtypeStr.Tycon c => c
- | _ =>
- let
- open Layout
- in
- Error.bug
- (toString
- (seq [str "datatype ",
- TypeStr.layout s,
- str " realized with scheme ",
- EtypeStr.layout typeStr]))
- end
- end
- | Tycon.Rigid (c, _) => c
- in
- EtypeStr.data (tycon, k, consToEnv cons)
- end
- | Scheme s => EtypeStr.def (schemeToEnv s, k)
- | Tycon c => EtypeStr.abs (tyconToEnv c)
- end
-
structure AdmitsEquality =
struct
open AdmitsEquality
@@ -585,6 +609,18 @@
in
()
end
+
+ type typeStr = TypeStr.t
+
+ datatype dest =
+ ETypeStr of EnvTypeStr.t
+ | TypeStr of typeStr
+
+ fun dest (f: t): dest =
+ case Defn.dest (defn f) of
+ Defn.Realized s => ETypeStr s
+ | Defn.TypeStr s => TypeStr s
+ | _ => Error.bug "FlexiblTycon.dest"
end
structure Tycon =
@@ -598,21 +634,6 @@
val exn = fromEnv (Etycon.exn, Kind.Arity 0)
end
-structure Type =
- struct
- open Type
-
- fun fromEnv (t: Etype.t): t =
- let
- fun con (c, ts) =
- Con (Tycon.fromEnv (c, Kind.Arity (Vector.length ts)), ts)
- in
- Etype.hom (t, {con = con,
- record = Record,
- var = Var})
- end
- end
-
structure Scheme =
struct
open Scheme
@@ -620,65 +641,18 @@
val admitsEquality = schemeAdmitsEquality
val copy = copyScheme
-
- val toEnv = schemeToEnv
-
- fun fromEnv (s: Escheme.t): t =
- let
- val (tyvars, ty) = Escheme.dest s
- in
- make (tyvars, Type.fromEnv ty)
- end
- end
-
-structure Cons =
- struct
- open TypeStr.Cons
-
- fun fromEnv (Econs.T v): t =
- T (Vector.map (v, fn {con, name, scheme} =>
- {con = con,
- name = name,
- scheme = Scheme.fromEnv scheme}))
end
val renameTycons = ref (fn () => ())
structure TypeStr =
struct
- structure Cons' = Cons
- structure Scheme' = Scheme
- structure Tycon' = Tycon
- structure Type' = Type
open TypeStr
- structure Cons = Cons'
- structure Scheme = Scheme'
- structure Tycon = Tycon'
- structure Type = Type'
-
+
val admitsEquality = typeStrAdmitsEquality
val copy = copyTypeStr
- val toEnv = typeStrToEnv
-
- fun fromEnv (s: EtypeStr.t) =
- let
- val kind = EtypeStr.kind s
- in
- case EtypeStr.node s of
- EtypeStr.Datatype {cons, tycon} =>
- data (Tycon.fromEnv (tycon, kind),
- kind,
- Cons.fromEnv cons)
- | EtypeStr.Scheme s => def (Scheme.fromEnv s, kind)
- | EtypeStr.Tycon c =>
- tycon (Tycon.fromEnv (c, kind), kind)
- end
-
- val fromEnv =
- Trace.trace ("TypeStr.fromEnv", EtypeStr.layout, layout) fromEnv
-
fun getFlex (s: t, time, oper, reg, lay): FlexibleTycon.t option =
let
fun error what =
@@ -705,7 +679,7 @@
case c of
Tycon.Flexible c =>
let
- val {creationTime, defn, ...} = FlexibleTycon.dest c
+ val {creationTime, defn, ...} = FlexibleTycon.fields c
in
case Defn.dest (!defn) of
Defn.Realized _ => Error.bug "getFlex of realized"
@@ -793,7 +767,7 @@
end
else
let
- val {defn, hasCons, ...} = FlexibleTycon.dest flex
+ val {defn, hasCons, ...} = FlexibleTycon.fields flex
in
if hasCons
andalso
1.16 +89 -37 mlton/mlton/elaborate/interface.sig
Index: interface.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- interface.sig 11 Feb 2004 17:58:43 -0000 1.15
+++ interface.sig 16 Feb 2004 22:42:10 -0000 1.16
@@ -10,10 +10,27 @@
signature INTERFACE_STRUCTS =
sig
structure Ast: AST
- structure EnvTypeStr: TYPE_STR
- sharing Ast.Con = EnvTypeStr.Name
- sharing Ast.SortedRecord = EnvTypeStr.Record
- sharing Ast.Tyvar = EnvTypeStr.Tyvar
+ structure EnvTypeStr:
+ sig
+ structure AdmitsEquality: ADMITS_EQUALITY
+ structure Kind: TYCON_KIND
+ structure Tycon:
+ sig
+ type t
+
+ val admitsEquality: t -> AdmitsEquality.t ref
+ val arrow: t
+ val equals: t * t -> bool
+ val exn: t
+ val layout: t -> Layout.t
+ val layoutApp:
+ t * (Layout.t * {isChar: bool, needsParen: bool}) vector
+ -> Layout.t * {isChar: bool, needsParen: bool}
+ val tuple: t
+ end
+
+ type t
+ end
end
signature INTERFACE =
@@ -21,9 +38,25 @@
include INTERFACE_STRUCTS
structure AdmitsEquality: ADMITS_EQUALITY
+ sharing AdmitsEquality = EnvTypeStr.AdmitsEquality
+ structure Kind: TYCON_KIND
+ sharing Kind = EnvTypeStr.Kind
+
+ structure FlexibleTycon:
+ sig
+ type typeStr
+ type t
+
+ datatype dest =
+ ETypeStr of EnvTypeStr.t
+ | TypeStr of typeStr
+ val dest: t -> dest
+ end
structure Tycon:
sig
- type t
+ datatype t =
+ Flexible of FlexibleTycon.t
+ | Rigid of EnvTypeStr.Tycon.t * Kind.t
val admitsEquality: t -> AdmitsEquality.t ref
val make: {hasCons: bool} -> t
@@ -32,17 +65,25 @@
sig
type t
end
+ sharing Tyvar = Ast.Tyvar
+ structure Record: RECORD
+ sharing Record = Ast.SortedRecord
structure Type:
sig
type t
-
- val deEta: t * Tyvar.t vector -> Tycon.t option
- end
- structure Scheme:
- sig
- type t
- val toEnv: t -> EnvTypeStr.Scheme.t
+ val arrow: t * t -> t
+ val bogus: t
+ val con: Tycon.t * t vector -> t
+ val deArrow: t -> t * t
+ val deEta: t * Tyvar.t vector -> Tycon.t option
+ val exn: t
+ val hom: t * {con: Tycon.t * 'a vector -> 'a,
+ record: 'a Record.t -> 'a,
+ var: Tyvar.t -> 'a} -> 'a
+ val layout: t -> Layout.t
+ val record: t Record.t -> t
+ val var: Tyvar.t -> t
end
structure Status:
sig
@@ -51,48 +92,59 @@
val layout: t -> Layout.t
val toString: t -> string
end
- structure Con:
+ structure Time:
sig
type t
+
+ val tick: unit -> t
+ end
+ structure Scheme:
+ sig
+ datatype t = T of {ty: Type.t,
+ tyvars: Tyvar.t vector}
+
+ val admitsEquality: t -> bool
+ val make: Tyvar.t vector * Type.t -> t
+ val ty: t -> Type.t
end
- sharing Con = EnvTypeStr.Con
structure Cons:
sig
- datatype t = T of {con: Con.t,
- name: Ast.Con.t,
+ datatype t = T of {name: Ast.Con.t,
scheme: Scheme.t} vector
-
+
val empty: t
val layout: t -> Layout.t
end
- structure Time:
- sig
- type t
-
- val tick: unit -> t
- end
structure TypeStr:
sig
- include TYPE_STR
+ type t
- val fromEnv: EnvTypeStr.t -> t
+ datatype node =
+ Datatype of {cons: Cons.t,
+ tycon: Tycon.t}
+ | Scheme of Scheme.t
+ | Tycon of Tycon.t
+
+ val abs: t -> t
+ val admitsEquality: t -> AdmitsEquality.t
+ val apply: t * Type.t vector -> Type.t
+ val bogus: Kind.t -> t
+ val cons: t -> Cons.t
+ val data: Tycon.t * Kind.t * Cons.t -> t
+ val def: Scheme.t * Kind.t -> t
+ val kind: t -> Kind.t
+ val layout: t -> Layout.t
+ val node: t -> node
+ val toTyconOpt: t -> Tycon.t option (* NONE on Scheme *)
+ val tycon: Tycon.t * Kind.t -> t
val share:
(t * Region.t * (unit -> Layout.t))
* (t * Region.t * (unit -> Layout.t))
* Time.t
-> unit
val wheree: t * Region.t * (unit -> Layout.t) * Time.t * t -> unit
- val toEnv: t -> EnvTypeStr.t
end
- sharing TypeStr.AdmitsEquality = AdmitsEquality
- sharing TypeStr.Con = Con
- sharing TypeStr.Kind = EnvTypeStr.Kind
- sharing TypeStr.Name = EnvTypeStr.Name
- sharing TypeStr.Record = EnvTypeStr.Record
- sharing TypeStr.Scheme = Scheme
- sharing TypeStr.Tycon = Tycon
- sharing TypeStr.Type = Type
- sharing TypeStr.Tyvar = EnvTypeStr.Tyvar = Tyvar
+ sharing type FlexibleTycon.typeStr = TypeStr.t
structure Shape:
sig
type t
@@ -128,8 +180,8 @@
t * {followStrid: 'a * Ast.Strid.t -> 'a,
init: 'a,
realizeTycon: ('a * Ast.Tycon.t
- * TypeStr.AdmitsEquality.t
- * TypeStr.Kind.t
+ * AdmitsEquality.t
+ * Kind.t
* {hasCons: bool} -> EnvTypeStr.t)}
-> t
val renameTycons: (unit -> unit) ref
1.6 +0 -2 mlton/mlton/elaborate/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm 7 Nov 2003 00:21:28 -0000 1.5
+++ sources.cm 16 Feb 2004 22:42:10 -0000 1.6
@@ -39,5 +39,3 @@
scope.sig
type-env.fun
type-env.sig
-type-str.fun
-type-str.sig
1.3 +0 -105 mlton/mlton/elaborate/type-str.fun
Index: type-str.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-str.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- type-str.fun 14 Nov 2003 03:48:18 -0000 1.2
+++ type-str.fun 16 Feb 2004 22:42:10 -0000 1.3
@@ -16,108 +16,3 @@
structure AdmitsEquality = AdmitsEquality
end
-structure Cons =
- struct
- datatype t = T of {con: Con.t,
- name: Name.t,
- scheme: Scheme.t} vector
-
- val empty = T (Vector.new0 ())
-
- fun layout (T v) =
- Vector.layout (fn {con, name, scheme} =>
- Layout.tuple [Name.layout name,
- Con.layout con,
- Layout.str ": ",
- Scheme.layout scheme])
- v
- end
-
-datatype node =
- Datatype of {cons: Cons.t,
- tycon: Tycon.t}
- | Scheme of Scheme.t
- | Tycon of Tycon.t
-
-datatype t = T of {kind: Kind.t,
- node: node}
-
-local
- fun make f (T r) = f r
-in
- val kind = make #kind
- val node = make #node
-end
-
-fun layout t =
- let
- open Layout
- in
- case node t of
- Datatype {tycon, cons} =>
- seq [str "Datatype ",
- record [("tycon", Tycon.layout tycon),
- ("cons", Cons.layout cons)]]
- | Scheme s => Scheme.layout s
- | Tycon t => seq [str "Tycon ", Tycon.layout t]
- end
-
-fun admitsEquality (s: t): AdmitsEquality.t =
- case node s of
- Datatype {tycon = c, ...} => ! (Tycon.admitsEquality c)
- | Scheme s => if Scheme.admitsEquality s
- then AdmitsEquality.Sometimes
- else AdmitsEquality.Never
- | Tycon c => ! (Tycon.admitsEquality c)
-
-fun bogus (k: Kind.t): t =
- T {kind = k,
- node = Scheme (Scheme.bogus ())}
-
-fun abs t =
- case node t of
- Datatype {tycon, ...} => T {kind = kind t,
- node = Tycon tycon}
- | _ => t
-
-fun apply (t: t, tys: Type.t vector): Type.t =
- case node t of
- Datatype {tycon, ...} => Type.con (tycon, tys)
- | Scheme s => Scheme.apply (s, tys)
- | Tycon t => Type.con (t, tys)
-
-fun cons t =
- case node t of
- Datatype {cons, ...} => cons
- | _ => Cons.empty
-
-fun data (tycon, kind, cons) =
- T {kind = kind,
- node = Datatype {tycon = tycon, cons = cons}}
-
-fun def (s: Scheme.t, k: Kind.t) =
- let
- val (tyvars, ty) = Scheme.dest s
- in
- T {kind = k,
- node = (case Type.deEta (ty, tyvars) of
- NONE => Scheme s
- | SOME c => Tycon c)}
- end
-
-fun isTycon s =
- case node s of
- Datatype _ => false
- | Scheme _ => false
- | Tycon _ => true
-
-fun toTyconOpt s =
- case node s of
- Datatype {tycon, ...} => SOME tycon
- | Scheme _ => NONE
- | Tycon c => SOME c
-
-fun tycon (c, kind) = T {kind = kind,
- node = Tycon c}
-
-end
1.32 +2 -1 mlton/mlton/front-end/ml.grm
Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- ml.grm 31 Jan 2004 06:00:30 -0000 1.31
+++ ml.grm 16 Feb 2004 22:42:11 -0000 1.32
@@ -254,7 +254,7 @@
| RBRACKET | REC | RPAREN | SEMICOLON | SHARING | SIG | SIGNATURE | STRUCT
| STRUCTURE | THEN | TYPE | VAL | WHERE | WHILE | WILD | WITH | WITHTYPE
(* Extensions *)
- | BUILD_CONST | CONST | EXPORT | FFI | IMPORT | PRIM
+ | BASIS_DONE | BUILD_CONST | CONST | EXPORT | FFI | IMPORT | PRIM
%nonterm
aexp of Exp.node
@@ -518,6 +518,7 @@
in
Topdec.Functor funbinds
end)
+ | BASIS_DONE longid (Topdec.BasisDone {ffi = Longstrid.fromSymbols longid})
(*---------------------------------------------------*)
(* Structures *)
1.15 +16 -11 mlton/mlton/front-end/ml.lex
Index: ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- ml.lex 26 Jan 2004 19:18:04 -0000 1.14
+++ ml.lex 16 Feb 2004 22:42:11 -0000 1.15
@@ -127,17 +127,22 @@
%%
<INITIAL>{ws} => (continue ());
<INITIAL>{eol} => (Source.newline (source, yypos); continue ());
-<INITIAL>"_const" => (tok (Tokens.CONST, source, yypos,
- yypos + size yytext));
-<INITIAL>"_build_const" => (tok (Tokens.BUILD_CONST, source, yypos,
- yypos + size yytext));
-<INITIAL>"_export" => (tok (Tokens.EXPORT, source, yypos, yypos + size yytext));
-<INITIAL>"_ffi" => (tok (Tokens.FFI, source, yypos, yypos + size yytext));
-<INITIAL>"_import" => (tok (Tokens.IMPORT, source, yypos, yypos + size yytext));
-<INITIAL>"_overload" => (tok (Tokens.OVERLOAD, source, yypos,
- yypos + size yytext));
-<INITIAL>"_prim" => (tok (Tokens.PRIM, source, yypos,
- yypos + size yytext));
+<INITIAL>"_basis_done" =>
+ (tok (Tokens.BASIS_DONE, source, yypos, yypos + size yytext));
+<INITIAL>"_const" =>
+ (tok (Tokens.CONST, source, yypos, yypos + size yytext));
+<INITIAL>"_build_const" =>
+ (tok (Tokens.BUILD_CONST, source, yypos, yypos + size yytext));
+<INITIAL>"_export" =>
+ (tok (Tokens.EXPORT, source, yypos, yypos + size yytext));
+<INITIAL>"_ffi" =>
+ (tok (Tokens.FFI, source, yypos, yypos + size yytext));
+<INITIAL>"_import" =>
+ (tok (Tokens.IMPORT, source, yypos, yypos + size yytext));
+<INITIAL>"_overload" =>
+ (tok (Tokens.OVERLOAD, source, yypos, yypos + size yytext));
+<INITIAL>"_prim" =>
+ (tok (Tokens.PRIM, source, yypos, yypos + size yytext));
<INITIAL>"_" => (tok (Tokens.WILD, source, yypos, yypos + 1));
<INITIAL>"," => (tok (Tokens.COMMA, source, yypos, yypos + 1));
<INITIAL>"{" => (tok (Tokens.LBRACE, source, yypos, yypos + 1));
1.25 +74 -73 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- compile.fun 10 Feb 2004 12:33:39 -0000 1.24
+++ compile.fun 16 Feb 2004 22:42:11 -0000 1.25
@@ -235,47 +235,46 @@
(E, Ast.Tycon.fromSymbol (Symbol.fromString
(Tycon.originalName tycon),
Region.bogus),
- TypeStr.tycon (tycon, kind)))
+ TypeStr.tycon (tycon, kind),
+ {isRebind = false}))
val _ =
Vector.foreach
(primitiveDatatypes, fn {tyvars, tycon, cons} =>
let
- val cs =
- Vector.map
- (cons, fn {arg, con} =>
- let
- val resultType =
- Type.con (tycon, Vector.map (tyvars, Type.var))
- val scheme =
- Scheme.make
- {canGeneralize = true,
- ty = (case arg of
- NONE => resultType
- | SOME t => Type.arrow (t, resultType)),
- tyvars = tyvars}
- in
- {con = con,
- name = Con.toAst con,
- scheme = scheme}
- end)
- val _ =
- Vector.foreach (cs, fn {con, name, scheme} =>
- extendCon (E, name, con, scheme))
+ val cons =
+ Env.newCons
+ (E, Vector.map (cons, fn {arg, con} =>
+ {con = con, name = Con.toAst con}))
+ (Vector.map
+ (cons, fn {arg, ...} =>
+ let
+ val resultType =
+ Type.con (tycon, Vector.map (tyvars, Type.var))
+ in
+ Scheme.make
+ {canGeneralize = true,
+ ty = (case arg of
+ NONE => resultType
+ | SOME t => Type.arrow (t, resultType)),
+ tyvars = tyvars}
+ end))
in
extendTycon
(E, Tycon.toAst tycon,
TypeStr.data (tycon,
TypeStr.Kind.Arity (Vector.length tyvars),
- TypeStr.Cons.T cs))
+ cons),
+ {isRebind = false})
end)
val _ =
extendTycon (E,
Ast.Tycon.fromSymbol (Symbol.unit, Region.bogus),
TypeStr.def (Scheme.fromType Type.unit,
- TypeStr.Kind.Arity 0))
+ TypeStr.Kind.Arity 0),
+ {isRebind = false})
val scheme = Scheme.fromType Type.exn
val _ = List.foreach (primitiveExcons, fn c =>
- extendCon (E, Con.toAst c, c, scheme))
+ extendExn (E, Con.toAst c, c, scheme))
in
()
end
@@ -347,13 +346,6 @@
; withFiles (libsFile "build",
fn fs => parseAndElaborateFiles (fs, basisEnv,
lookupConstant))))
- val _ =
- Env.Structure.ffi
- := (Env.lookupLongstrid
- (basisEnv,
- Ast.Longstrid.short
- (Ast.Strid.fromSymbol (Symbol.fromString "MLtonFFI",
- Region.bogus))))
fun doit name =
let
fun libFile f = libsFile (String./ (name, f))
@@ -436,52 +428,61 @@
fun elaborate {input: File.t list}: Xml.Program.t =
let
- fun parseElabMsg () = (lexAndParseMsg (); elaborateMsg ())
val {basis, prefix, suffix, ...} = selectBasisLibrary ()
- val _ = Elaborate.allowRebindEquals := false
- fun parseAndElab () =
- parseAndElaborateFiles (input, basisEnv, lookupConstantError)
val _ =
- if !Control.showBasisUsed
- then (Env.scopeAll (basisEnv, parseAndElab)
- ; Layout.outputl (Env.layoutUsed basisEnv, Out.standard)
- ; raise Done)
- else ()
+ if List.isEmpty input
+ then ()
+ else Env.clearDefUses basisEnv
+ val input =
+ Env.scopeAll
+ (basisEnv, fn () =>
+ let
+ val res = parseAndElaborateFiles (input, basisEnv,
+ lookupConstantError)
+ val _ =
+ case !Control.showBasis of
+ NONE => ()
+ | SOME f =>
+ let
+ val lay =
+ if List.isEmpty input
+ then Env.layout basisEnv
+ else Env.layoutCurrentScope basisEnv
+ in
+ File.withOut (f, fn out => Layout.outputl (lay, out))
+ end
+ val _ =
+ if isSome (!Control.showDefUse) orelse !Control.warnUnused
+ then Env.processDefUse basisEnv
+ else ()
+ in
+ res
+ end)
+ val _ =
+ case !Control.showBasisUsed of
+ NONE => ()
+ | SOME f =>
+ File.withOut (f, fn out =>
+ Layout.outputl (Env.layoutUsed basisEnv, out))
val _ =
- if !Control.showBasis
- then
- let
- val lay =
- case input of
- [] => Env.layout basisEnv
- | _ =>
- Env.scopeAll
- (basisEnv, fn () =>
- (parseAndElab ()
- ; Env.layoutCurrentScope basisEnv))
- val _ = Layout.outputl (lay, Out.standard)
- in
- raise Done
- end
- else ()
- val input = parseAndElab ()
+ case !Control.exportHeader of
+ NONE => ()
+ | SOME f =>
+ File.withOut
+ (f, fn out =>
+ let
+ val _ =
+ File.outputContents
+ (concat [!Control.libDir, "/include/types.h"], out)
+ fun print s = Out.output (out, s)
+ val _ = print "\n"
+ val _ = Ffi.declareHeaders {print = print}
+ in
+ ()
+ end)
+ val _ = (lexAndParseMsg (); elaborateMsg ())
val _ = if !Control.elaborateOnly then raise Done else ()
- val _ =
- if not (!Control.exportHeader)
- then ()
- else
- let
- val _ =
- File.outputContents
- (concat [!Control.libDir, "/include/types.h"],
- Out.standard)
- val _ = print "\n"
- val _ = Ffi.declareHeaders {print = print}
- in
- raise Done
- end
val user = Decs.toList (Decs.appends [prefix, input, suffix])
- val _ = parseElabMsg ()
val basis = Decs.toList basis
val basis =
if !Control.deadCode
1.26 +30 -27 mlton/mlton/main/main.fun
Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- main.fun 13 Feb 2004 17:05:57 -0000 1.25
+++ main.fun 16 Feb 2004 22:42:11 -0000 1.26
@@ -59,6 +59,7 @@
val profileSet: bool ref = ref false
val runtimeArgs: string list ref = ref ["@MLton"]
val stop = ref Place.OUT
+val warnMatch = ref true
val targetMap: unit -> {arch: MLton.Platform.Arch.t,
os: MLton.Platform.OS.t,
@@ -180,9 +181,8 @@
boolRef exnHistory),
(Expert, "expert", " {false|true}", "enable expert status",
boolRef expert),
- (Normal, "export-header", " {false|true}",
- "output header file for _export's",
- boolRef exportHeader),
+ (Normal, "export-header", " <file>", "write header file for _export's",
+ SpaceString (fn s => exportHeader := SOME s)),
(Expert, "gc-check", " {limit|first|every}", "force GCs",
SpaceString (fn s =>
gcCheck :=
@@ -323,12 +323,14 @@
(Normal, "sequence-unit", " {false|true}",
"in (e1; e2), require e1: unit",
boolRef sequenceUnit),
- (Normal, "show-basis", " {false|true}", "display the basis library",
- boolRef showBasis),
- (Normal, "show-basis-used", " {false|true}",
- "display the basis library used by the program",
- boolRef showBasisUsed),
- (Expert, "show-types", " {false|true}", "print types in ILs",
+ (Normal, "show-basis", " <file>", "write out the basis library",
+ SpaceString (fn s => showBasis := SOME s)),
+ (Normal, "show-basis-used", " <file>",
+ "write the basis library used by the program",
+ SpaceString (fn s => showBasisUsed := SOME s)),
+ (Normal, "show-def-use", " <file>", "write def-use information",
+ SpaceString (fn s => showDefUse := SOME s)),
+ (Expert, "show-types", " {false|true}", "show types in ILs",
boolRef showTypes),
(Expert, "ssa-passes", " <passes>", "ssa optimization passes",
SpaceString
@@ -404,7 +406,10 @@
| _ => usage (concat ["invalid -variant arg: ", s])))),
(Normal, "warn-match", " {true|false}",
"nonexhaustive and redundant match warnings",
- Bool (fn b => (warnNonExhaustive := b; warnRedundant := b))),
+ boolRef warnMatch),
+ (Expert, "warn-unused", " {false|true}",
+ "unused identifier warnings",
+ boolRef warnUnused),
(Expert, "xml-passes", " <passes>", "xml optimization passes",
SpaceString
(fn s =>
@@ -439,6 +444,7 @@
val _ = setTargetType ("self", usage)
val result = parse args
val gcc = !gcc
+ val stop = !stop
val target = !target
val targetStr =
case target of
@@ -524,25 +530,22 @@
then keepSSA := true
else ()
val _ =
- if targetOS = Cygwin andalso !profile = ProfileTime
- then usage "can't use -profile time on Cygwin"
- else ()
+ let
+ val b = !warnMatch
+ in
+ (warnNonExhaustive := b; warnRedundant := b)
+ end
val _ =
- case List.keepAll ([("-export-header", exportHeader),
- ("-show-basis", showBasis),
- ("-show-basis-used", showBasisUsed)],
- fn (_, r) => !r) of
- (a, _) :: (b, _) :: _ =>
- usage (concat ["can't use both ", a, " and ", b])
- | _ => ()
+ keepDefUse := (isSome (!showDefUse)
+ orelse isSome (!showBasisUsed)
+ orelse !warnUnused)
+ val _ = elaborateOnly := (stop = Place.TypeCheck
+ andalso not (!warnMatch)
+ andalso not (!keepDefUse))
val _ =
- if !showBasis orelse !showBasisUsed
- then (stop := Place.TypeCheck
- ; warnNonExhaustive := false)
+ if targetOS = Cygwin andalso !profile = ProfileTime
+ then usage "can't use -profile time on Cygwin"
else ()
- val stop = !stop
- val _ = elaborateOnly := (stop = Place.TypeCheck
- andalso not (!warnNonExhaustive))
fun printVersion (out: Out.t): unit =
Out.output (out, concat [version, " ", build, "\n"])
in
@@ -550,7 +553,7 @@
Result.No msg => usage msg
| Result.Yes [] =>
(inputFile := "<none>"
- ; if !showBasis orelse stop = Place.TypeCheck
+ ; if isSome (!showDefUse) orelse isSome (!showBasis) orelse !warnUnused
then
trace (Top, "Type Check Basis")
Compile.elaborate {input = []}