[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 = []}