[MLton] cvs commit: new front end

sweeks@mlton.org sweeks@mlton.org
Thu, 13 Nov 2003 19:48:19 -0800


sweeks      03/11/13 19:48:18

  Modified:    basis-library/libs/basis-2002/top-level basis.sig basis.sml
                        top-level.sml
               mlton/ast admits-equality.fun admits-equality.sig
               mlton/defunctorize defunctorize.fun
               mlton/elaborate elaborate-core.fun elaborate-env.fun
                        elaborate-env.sig elaborate-sigexp.fun
                        elaborate.fun interface.fun interface.sig
                        type-env.fun type-env.sig type-str.fun type-str.sig
               mlton/main compile.fun
  Log:
  The next phase in the new front end: opaque signature constraints.
  This is implemented by building a dummy structure realized from the
  signature, just as we would for a functor argument when type checking
  a functor.  The dummy structure contains exactly the type information
  that is in the signature, which is what opacity requires.  We then
  replace the variables (and constructors) in the dummy structure with
  the corresponding variables (and constructors) from the actual
  structure so that the translation to CoreML uses the right stuff.  For
  each tycon in the dummy structure, we keep track of the corresponding
  type structure in the actual structure.  This is used when producing
  the CoreML types (see expandOpaque in type-env.{fun,sig})
  
  Another way to look at things is that an opaque signature constraint
  is equivalent to viewing the rest of the program as a functor
  parameterized by a structure matching the signature being matched
  opaquely.
  
  The most annoying bit about all of this was getting the opacity of the
  basis library right.  There were several problems.  The first stems
  from free types in signatures.  For example, in BYTE we have
  
  signature BYTE =
     sig
        ...
        val unpackString: Word8ArraySlice.slice -> string
     end
  
  Here, Word8ArraySlice.slice is a free type.  Then, in BASIS_2002 we have
  
  signature BASIS_2002 =
     sig
        ...
        structure Byte: BYTE
        ...
        structure Word8ArraySlice: MONO_ARRAY_SLICE
     end
  
  The problem is that this signature establishes no connection between
  the Word8ArraySlice.slice in Byte the slice Word8ArraySlice.  And we
  cannot use a sharing constraint to make them the same, since the
  Word8ArraySlice.slice in BYTE is not flexible.  So, we end up adding a
  new where type to BASIS_2002
  
     where type Word8ArraySlice.slice = Word8ArraySlice.slice
  
  This is a bit annoying, because it exposes the type of
  Word8ArraySlice.slice, which is probably some record type.  To really
  fix this, we need to add some opaque constraints earlier in the basis
  library.
  
  Another problem stems from the fact that we had the non-standard
  structures (MLton, SMLofNJ, ...) outside of the opaque constraint on
  Basis2002.  This meant that types that they used (e.g. MLton.Signal.t)
  were not known to be the same as the basis library types
  (e.g. Posix.Signal.signal).  One fix would be to add yet more where
  constraints to BASIS_2002, but that would expose even more types.  So,
  I decided a better fix was to move the non-standard structures into
  BASIS_2002 and Basis2002.
  
  I am beginning to wonder if using the :> for Basis2002 is the right
  approach.  The problem is that this approach introduces lots of
  potential bugs where we reject valid programs because two types are
  not equal that should be, because we haven't added the appropriate
  sharing or where.  If instead we were to use :, then we might accept
  some programs because two types are equal that shouldn't be.  But that
  seems more benign.  And when we learn it, we can use a :> somewhere
  earlier in the basis library code to patch stuff up.  Although maybe
  it's just a question of how quickly we can get to a correct BASIS_2002
  so that the single big :> works.
  
  I also think this would be an excellent time to drop support for
  -basis 1997 and Basis1997.  Why, because it will be a whole lot of
  additional work to get the opacity right there.  And, with the new
  front end, it is much easier for people to migrate to the new basis.
  
  Anyways, with all this, we now have a front end that works on all our
  usual tests.  I am certain there are still many problems both in the
  type checker and in missing sharing and wheres.  So, I am ready to
  start getting some feedback.  Please start testing.  Soon, I will
  revisit how type errors are displayed.

Revision  Changes    Path
1.21      +45 -13    mlton/basis-library/libs/basis-2002/top-level/basis.sig

Index: basis.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sig,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- basis.sig	7 Nov 2003 00:21:27 -0000	1.20
+++ basis.sig	14 Nov 2003 03:48:17 -0000	1.21
@@ -255,6 +255,14 @@
       structure Word64Vector : MONO_VECTOR
       structure Word64VectorSlice : MONO_VECTOR_SLICE
 
+      (* Non-standard structures *)
+      structure MLton: MLTON
+      structure SMLofNJ: SML_OF_NJ
+      structure Unsafe: UNSAFE
+
+      sharing type MLton.IntInf.int = IntInf.int
+      sharing type MLton.Signal.t = Posix.Signal.signal
+	 
       (* ************************************************** *)
       (* ************************************************** *)
 
@@ -318,6 +326,8 @@
       sharing type Text.Substring.substring = Substring.substring
       sharing type Text.CharVector.vector = CharVector.vector
       sharing type Text.CharArray.array = CharArray.array
+      sharing type TextIO.elem = char 
+      sharing type TextIO.vector = string
       sharing type TextPrimIO.elem = Char.char
       sharing type TextPrimIO.array = CharArray.array
       sharing type TextPrimIO.vector = CharVector.vector
@@ -333,7 +343,11 @@
       sharing type Word8Array2.elem = Word8.word
       sharing type Word8Array2.vector = Word8Vector.vector
 	
-      (* Optional structures *) 
+      (* Optional structures *)
+      sharing IntArray = Int32Array
+      sharing RealArray = Real64Array
+      sharing WordArray = Word32Array
+
       sharing type BoolArray.elem = bool
       sharing type BoolArray.vector = BoolVector.vector
       sharing type BoolArraySlice.elem = bool
@@ -437,14 +451,15 @@
       sharing type LargeWordArray2.vector = LargeWordVector.vector
       sharing type PackRealBig.real = real
       sharing type PackRealLittle.real = real
-      sharing type PackReal32Big.real = Real64.real
-      sharing type PackReal32Little.real = Real64.real
+      sharing type PackReal32Big.real = Real32.real
+      sharing type PackReal32Little.real = Real32.real
       sharing type PackReal64Big.real = Real64.real
       sharing type PackReal64Little.real = Real64.real
       sharing type Posix.Error.syserror = OS.syserror
-      sharing type Posix.Process.exit_status = Unix.exit_status
+      sharing type Posix.IO.file_desc = Posix.ProcEnv.file_desc
       sharing type Posix.FileSys.dirstream = OS.FileSys.dirstream
       sharing type Posix.FileSys.access_mode = OS.FileSys.access_mode
+      sharing type Posix.Process.exit_status = Unix.exit_status
       sharing type RealArray.elem = real
       sharing type RealArray.vector = RealVector.vector
       sharing type RealArraySlice.elem = real
@@ -501,6 +516,7 @@
       sharing type Word16VectorSlice.vector = Word16Vector.vector
       sharing type Word16Array2.elem = Word16.word
       sharing type Word16Array2.vector = Word16Vector.vector
+      sharing type Word32.word = Word.word
       sharing type Word32Array.elem = Word32.word
       sharing type Word32Array.vector = Word32Vector.vector
       sharing type Word32ArraySlice.elem = Word32.word
@@ -514,19 +530,21 @@
       sharing type Word32Array2.vector = Word32Vector.vector
    end
    (* Top-level types *)
-   where type unit = unit
-   where type int = int
-   where type word = word
-   where type real = real
-   where type char = char
-   where type exn = exn
    where type 'a array = 'a array
-   where type 'a vector = 'a vector
+   where type 'a list = 'a list
+   where type 'a option = 'a option
    where type 'a ref = 'a ref
+   where type 'a vector = 'a vector
    where type bool = bool
-   where type 'a option = 'a option
+   where type char = char
+   where type exn = exn
+   where type int = int
    where type order = order
-   where type 'a list = 'a list
+   where type real = real
+   where type string = string
+   where type substring = substring
+   where type unit = unit
+   where type word = word
 
    (* Types referenced in signatures by structure name *)
 (*
@@ -537,6 +555,7 @@
    where type BinPrimIO.writer = BinPrimIO.writer
    where type Char.char = Char.char
    where type Int.int = Int.int
+   where type IntInf.int = IntInf.int
    where type LargeInt.int = LargeInt.int
    where type LargeReal.real = LargeReal.real
    where type LargeWord.word = LargeWord.word
@@ -548,23 +567,36 @@
    where type OS.IO.iodesc = OS.IO.iodesc
    where type OS.Process.status = OS.Process.status
    where type Position.int = Position.int
+   where type Posix.IO.file_desc = Posix.IO.file_desc
    where type Posix.Process.pid = Posix.Process.pid
+   where type Posix.Signal.signal = Posix.Signal.signal
+   where type Real32.real = Real32.real
    where type Real64.real = Real64.real
+   where type Real64Array.array = Real64Array.array
+   where type ('a, 'b) Socket.sock = ('a, 'b) Socket.sock
+   where type 'a Socket.sock_addr = 'a Socket.sock_addr
+   where type 'a Socket.stream = 'a Socket.stream
    where type StringCvt.radix = StringCvt.radix
    where type StringCvt.realfmt = StringCvt.realfmt
 (*
    where type ('a, 'b) StringCvt.reader = ('a, 'b) StringCvt.reader
 *)
    where type SysWord.word = SysWord.word
+   where type TextIO.instream = TextIO.instream
+   where type TextIO.outstream = TextIO.outstream
    where type TextPrimIO.reader = TextPrimIO.reader
    where type TextPrimIO.writer = TextPrimIO.writer
    where type Time.time = Time.time
    where type Word.word = Word.word
    where type Word8.word = Word8.word
    where type Word8Array.array = Word8Array.array
+   where type Word8ArraySlice.slice = Word8ArraySlice.slice
+   where type Word8ArraySlice.vector_slice = Word8ArraySlice.vector_slice
    where type Word8Vector.vector = Word8Vector.vector
+   where type Word8VectorSlice.vector = Word8VectorSlice.vector
 (*
    where type 'a Vector.vector = 'a Vector.vector
 *)
    where type 'a VectorSlice.slice = 'a VectorSlice.slice
 
+   where type 'a MLton.Thread.t = 'a MLton.Thread.t



1.18      +4 -0      mlton/basis-library/libs/basis-2002/top-level/basis.sml

Index: basis.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/basis.sml,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- basis.sml	11 Sep 2003 00:51:06 -0000	1.17
+++ basis.sml	14 Nov 2003 03:48:17 -0000	1.18
@@ -174,6 +174,10 @@
       structure Word64Vector = Word64Vector
       structure Word64VectorSlice = Word64VectorSlice
 
+      structure MLton = MLton
+      structure SMLofNJ = SMLofNJ
+      structure Unsafe = Unsafe
+	 
       open ArrayGlobal
 	   BoolGlobal
 	   CharGlobal



1.8       +0 -7      mlton/basis-library/libs/basis-2002/top-level/top-level.sml

Index: top-level.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/basis-2002/top-level/top-level.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- top-level.sml	9 Oct 2003 18:17:30 -0000	1.7
+++ top-level.sml	14 Nov 2003 03:48:17 -0000	1.8
@@ -37,13 +37,6 @@
 signature SML_OF_NJ = SML_OF_NJ
 signature UNSAFE = UNSAFE
 
-(* Non-standard structures *)
-structure Primitive = Primitive
-structure Basis1997 = Basis1997
-structure MLton = MLton
-structure SMLofNJ = SMLofNJ
-structure Unsafe = Unsafe
-
 open Basis2002
 
 val op = = op =



1.3       +7 -0      mlton/mlton/ast/admits-equality.fun

Index: admits-equality.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/admits-equality.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- admits-equality.fun	7 Nov 2003 00:21:27 -0000	1.2
+++ admits-equality.fun	14 Nov 2003 03:48:17 -0000	1.3
@@ -12,6 +12,13 @@
 
 val layout = Layout.str o toString
 
+val op <= =
+   fn (Never, _) => true
+    | (Sometimes, Never) => false
+    | (Sometimes, _) => true
+    | (Always, Always) => true
+    | (Always, _) => false
+
 val or =
    fn (Always, _) => Always
     | (_, Always) => Always



1.3       +1 -0      mlton/mlton/ast/admits-equality.sig

Index: admits-equality.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/admits-equality.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- admits-equality.sig	7 Nov 2003 00:21:28 -0000	1.2
+++ admits-equality.sig	14 Nov 2003 03:48:17 -0000	1.3
@@ -8,6 +8,7 @@
       
       datatype t = Always | Never | Sometimes
 
+      val <= : t * t -> bool
       val layout: t -> Layout.t
       val or: t * t -> t
       val toString: t -> string



1.6       +1 -4      mlton/mlton/defunctorize/defunctorize.fun

Index: defunctorize.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/defunctorize.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- defunctorize.fun	13 Oct 2003 23:24:30 -0000	1.5
+++ defunctorize.fun	14 Nov 2003 03:48:17 -0000	1.6
@@ -316,10 +316,7 @@
 fun defunctorize (CoreML.Program.T {decs}) =
    let
       val {destroy, hom = loopTy} =
-	 Ctype.makeHom {con = fn (c, ts) => if Tycon.equals (c, Tycon.char)
-					       then Xtype.word8
-					    else Xtype.con (c, ts),
-                        var = Xtype.var}
+	 Ctype.makeHom {con = Xtype.con, var = Xtype.var}
       val {get = conTycon, set = setConTycon, ...} =
 	 Property.getSetOnce (Con.plist,
 			      Property.initRaise ("conTycon", Con.layout))



1.48      +1 -0      mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- elaborate-core.fun	11 Nov 2003 21:26:34 -0000	1.47
+++ elaborate-core.fun	14 Nov 2003 03:48:17 -0000	1.48
@@ -215,6 +215,7 @@
 
 val {hom = typeTycon: Type.t -> Tycon.t option, ...} =
    Type.makeHom {con = fn (c, _) => SOME c,
+		 expandOpaque = Type.Never,
 		 var = fn _ => NONE}
    
 fun resolveConst (c: Aconst.t, ty: Type.t): Const.t =



1.21      +1051 -947 mlton/mlton/elaborate/elaborate-env.fun

Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- elaborate-env.fun	11 Nov 2003 21:26:34 -0000	1.20
+++ elaborate-env.fun	14 Nov 2003 03:48:18 -0000	1.21
@@ -37,7 +37,12 @@
    structure Var = Var
 end
 
-structure Kind = Tycon.Kind
+local
+   open Tycon
+in
+   structure AdmitsEquality = AdmitsEquality
+   structure Kind = Kind
+end
 
 local
    open TypeEnv
@@ -150,7 +155,8 @@
 	 fn T {ranges, ...} => List.pop ranges
    end
 
-structure TypeStr = TypeStr (structure Con = Con
+structure TypeStr = TypeStr (structure AdmitsEquality = AdmitsEquality
+			     structure Con = Con
 			     structure Kind = Tycon.Kind
 			     structure Name = Ast.Con
 			     structure Record = SortedRecord
@@ -178,6 +184,12 @@
 				   open Type
 
 				   val bogus = new ()
+
+				   fun hom (t, {con, record, var}) =
+				      Type.hom (t, {con = con,
+						    expandOpaque = Type.Never,
+						    record = record,
+						    var = var})
 				end
 			     structure Tyvar = Tyvar)
 
@@ -244,29 +256,25 @@
 		       {isUsed = ref false,
 			range = f range,
 			values = values}))
+
+      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 ({range = r, values, ...}, {range = r', ...}) =>
+	     {isUsed = ref false,
+	      range = f (r, r'),
+	      values = values}))
    end
 
-(* pre: arities are equal. *)
-fun equalSchemes (s: Scheme.t, s': Scheme.t, name: unit -> Layout.t, r: Region.t)
-   : unit =
+val newTycons: (Tycon.t * Kind.t) list ref = ref []
+
+val newTycon: string * Kind.t -> Tycon.t =
+   fn (s, k) =>
    let
-      val (tyvars, ty) = Scheme.dest s
-      val (_, ty') = Scheme.dest s'
-      val tyvars =
-	 Vector.tabulate (Vector.length tyvars, fn _ =>
-			  Type.var (Tyvar.newNoname {equality = false}))
+      val c = Tycon.fromString s
+      val _ = List.push (newTycons, (c, k))
    in
-      Type.unify
-      (Scheme.apply (s, tyvars), Scheme.apply (s', tyvars), fn (l1, l2) =>
-       let
-	  open Layout
-       in
-	  (r,
-	   seq [str "type ", name (),
-		str " in structure disagrees with signature"],
-	   align [seq [str "structure: ", l1],
-		  seq [str "signature: ", l2]])
-       end)
+      c
    end
 
 (* ------------------------------------------------- *)
@@ -287,6 +295,8 @@
 	 val plist = make #plist
       end
 
+      fun eq (s: t, s': t): bool = PropertyList.equals (plist s, plist s')
+
       fun layoutUsed (T {strs, types, vals, ...}) =
 	 let
 	    open Layout
@@ -446,308 +456,6 @@
 	     addVal = addVal,
 	     finish = finish}
 	 end
-      
-      (* section 5.3, 5.5, 5.6 and rules 52, 53 *)
-      fun cut (str: t, {interface, opaque: bool, region}): t * Decs.t =
-	 let
-	    val decs = ref []
-	    fun error (name, l) =
-	       let
-		  open Layout
-	       in
-		  Control.error
-		  (region,
-		   seq [str (concat [name, " "]), l,
-			str " in signature but not in structure"],
-		   empty)
-	       end
-	    fun checkCons (Cons.T v, Cons.T v', strids): unit =
-	       let
-		  fun lay (c: Ast.Con.t) =
-		     Longcon.layout (Longcon.long (rev strids, c))
-		  val extraStr =
-		     Vector.keepAllMap
-		     (v, fn {name = n, scheme = s, ...} =>
-		      case Vector.peek (v', fn {name = n', ...} =>
-					Ast.Con.equals (n, n')) of
-			 NONE => SOME n
-		       | SOME {scheme = s', ...} =>
-			    let
-			       val _ =
-				  equalSchemes
-				  (s, s', fn () =>
-				   let
-				      open Layout
-				   in
-				      seq [str "of ", lay n]
-				   end,
-				   region)
-			    in
-			       NONE
-			    end)
-		  fun extras (v, name) =
-		     if 0 = Vector.length v
-			then ()
-		     else
-			let
-			   open Layout
-			in
-			   Control.error
-			   (region,
-			    seq [str (concat ["constructors in ", name, " only: "]),
-				 seq (List.separate (Vector.toListMap (v, lay),
-						     str ", "))],
-			    empty)
-			end
-		  val _ = extras (extraStr, "structure")
-		  val extraSig =
-		     Vector.keepAllMap
-		     (v', fn {name = n', ...} =>
-		      if Vector.exists (v, fn {name = n, ...} =>
-					Ast.Con.equals (n, n'))
-			 then NONE
-		      else SOME n')
-		  val _ = extras (extraSig, "signature")
-	       in
-		  ()
-	       end
-	    val interface =
-	       Interface.realize
-	       (interface, fn (c, a, k) =>
-		case peekLongtycon (str, c) of
-		   NONE => (error ("type", Longtycon.layout c)
-			    ; TypeStr.bogus k)
-		 | SOME typeStr =>
-		      let
-			 val k' = TypeStr.kind typeStr
-		      in
-			 if Kind.equals (k, k')
-			    then typeStr
-			 else
-			    let
-			       open Layout
-			       val _ =
-				  Control.error
-				  (Longtycon.region c,
-				   seq [str "type ", Longtycon.layout c,
-					str "has arity ", Kind.layout k',
-					str "in structure but arity ",
-					Kind.layout k, str " in signature"],
-				   empty)
-			    in
-			       TypeStr.bogus k
-			    end
-		      end)
-	    fun cut (S as T {shapeId, ...}, I, strids) =
-	       let
-		  val {addStr, addType, addVal, finish} = maker ()
-		  val shapeId' = Interface.shapeId I
-		  fun doit () =
-		     let
-			fun handleStr {name, interface = I} =
-			   case peekStrid' (S, name) of
-			      NONE =>
-				 error
-				 ("structure",
-				  Longstrid.layout	
-				  (Longstrid.long (rev strids, name)))
-			    | SOME {range, values, ...} =>
-				 addStr {range = cut (range, I, name :: strids),
-					 values = values}
-			fun handleType {name: Ast.Tycon.t,
-					typeStr: TypeStr.t} =
-			   let
-			      fun layoutName () =
-				 Longtycon.layout
-				 (Longtycon.long (rev strids, name))
-			   in
-			      case peekTycon' (S, name) of
-				 NONE => error ("type", layoutName ())
-			       | SOME {range = typeStr', values, ...} =>
-				    let
-				       fun tyconScheme (c: Tycon.t): Scheme.t =
-					  let
-					     val tyvars =
-						case TypeStr.kind typeStr' of
-						   Kind.Arity n =>
-						      Vector.tabulate
-						      (n, fn _ =>
-						       Tyvar.newNoname
-						       {equality = false})
-						 | _ => Error.bug "Nary tycon"
-					  in
-					     Scheme.make
-					     {canGeneralize = true,
-					      ty = Type.con (c, Vector.map (tyvars, Type.var)),
-					      tyvars = tyvars}
-					  end
-				       datatype z = datatype TypeStr.node
-				       val k = TypeStr.kind typeStr
-				       val k' = TypeStr.kind typeStr'
-				       fun typeStrScheme (s: TypeStr.t) =
-					  case TypeStr.node s of
-					     Datatype {tycon, ...} =>
-						tyconScheme tycon
-					   | Scheme s => s
-					   | Tycon c' => tyconScheme c'
-				       val typeStr =
-					  if not (Kind.equals (k, k'))
-					     then
-						let
-						   open Layout
-						in
-						   Control.error
-						   (region,
-						    seq [str "type ", layoutName (),
-							 str " has arity ", Kind.layout k',
-							 str " in structure but arity ", Kind.layout k,
-							 str " in signature"],
-						    empty)
-						   ; typeStr
-						end
-					  else
-					     case TypeStr.node typeStr of
-						Datatype {cons = c, ...} =>
-						   (case TypeStr.node typeStr' of
-						       Datatype {cons = c', ...} =>
-							  (checkCons (c', c,
-								      strids)
-							   ; typeStr')
-						     | _ =>
-							  let
-							     open Layout
-							  in
-							     Control.error
-							     (region,
-							      seq [str "type ",
-								   layoutName (),
-								   str " is a datatype in signature but not in structure"],
-							      Layout.empty)
-							     ; typeStr
-							  end)
-					      | Scheme s =>
-						   (equalSchemes
-						    (typeStrScheme typeStr',
-						     s, layoutName, region)
-						    ; typeStr)
-					      | Tycon c =>
-						   (equalSchemes
-						    (typeStrScheme typeStr',
-						     tyconScheme c,
-						     layoutName, region)
-						    ; typeStr)
-				    in
-				       addType {range = typeStr,
-						values = values}
-				    end
-			   end
-                        fun handleVal {name, scheme = s, status} =
-			   case peekVid' (S, name) of
-			      NONE =>
-				 error ("variable",
-					Longvid.layout (Longvid.long
-							(rev strids, name)))
-			    | SOME {range = (vid, s'), values, ...} =>
-				 let
-				    val (tyvars, t) = Scheme.dest s
-				    val {args, instance = t'} =
-				       Scheme.instantiate s'
-				    val _ =
-				       Type.unify
-				       (t, t', fn (l, l') =>
-					let
-					   open Layout
-					in
-					   (region,
-					    seq [str "type of ",
-						 Longvid.layout	
-						 (Longvid.long
-						  (rev strids, name)),
-						 str " in structure disagrees with signature"],
-					    align [seq [str "structure: ", l'],
-						   seq [str "signature: ", l]])
-					end)
-				    fun addDec (n: Exp.node): Vid.t =
-				       let
-					  val x = Var.newNoname ()
-					  val e = Exp.make (n, t')
-					  val _ =
-					     List.push
-					     (decs,
-					      Dec.Val
-					      {rvbs = Vector.new0 (),
-					       tyvars = fn () => tyvars,
-					       vbs = (Vector.new1
-						      {exp = e,
-						       lay = fn _ => Layout.empty,
-						       pat = Pat.var (x, t'),
-						       patRegion = region})})
-				       in
-					  Vid.Var x
-				       end
-				    fun con (c: Con.t): Vid.t =
-				       addDec (Exp.Con (c, args ()))
-				    val vid =
-				       case (vid, status) of
-					  (Vid.Con c, Status.Var) => con c
-					| (Vid.Exn c, Status.Var) => con c
-					| (Vid.Var x, Status.Var) =>
-					     if 0 < Vector.length tyvars
-						orelse 0 < Vector.length (args ())
-						then
-						   addDec
-						   (Exp.Var (fn () => x, args))
-					     else vid
-					| (Vid.Con _, Status.Con) => vid
-					| (Vid.Exn _, Status.Exn) => vid
-					| _ =>
-					     (Control.error
-					      (region,
-					       Layout.str
-					       (concat
-						["identifier ",
-						 Longvid.toString
-						 (Longvid.long (rev strids,
-								name)),
-						 " is ",
-						 Vid.statusPretty vid,
-						 " in the structure but ",
-						 Status.pretty status,
-						 " in the signature "]),
-					       Layout.empty)
-					      ; vid)
-				 in
-				    addVal {range = (vid, s),
-					    values = values}
-				 end
-			val _ =
-			   Interface.foreach
-			   (I, {handleStr = handleStr,
-				handleType = handleType,
-				handleVal = handleVal})
-		     in
-			finish (SOME shapeId')
-		     end
-	       in
-		  case shapeId of
-		     NONE => doit ()
-		   | SOME shapeId =>
-			if ShapeId.equals (shapeId, shapeId')
-			   then S
-			else doit ()
-	       end
-	    val str = cut (str, interface, [])
-	 in
-	    (str, Decs.fromList (!decs))
-	 end
-
-      val cut =
-	 Trace.trace ("cut",
-		      fn (str, {interface, ...}) =>
-		      Layout.tuple [layoutPretty str,
-				    Interface.layout interface],
-		      layout o #1)
-	 cut
 
       val ffi: t option ref = ref NONE
    end
@@ -984,442 +692,97 @@
 		   align [seq [str "structure ", Ast.Strid.layout d],
 			  indent (Structure.layoutUsed r, 3)])]
    end
-   
-fun dummyStructure (T {strs, types, vals, ...}, I: Interface.t): Structure.t =
-   let
-      val I =
-	 Interface.realize
-	 (I, fn (c, a, k) =>
-	  let
-	     val c = Tycon.fromString (Longtycon.toString c)
-	     val _ = TypeEnv.tyconAdmitsEquality c := a
-	  in
-	     TypeStr.tycon (c, k)
-	  end)
-      val {get, ...} =
-	 Property.get
-	 (Interface.plist,
-	  Property.initRec
-	  (fn (I, get) =>
-	   let
-	      val {addStr, addType, addVal, finish} = Structure.maker ()
-	      fun handleStr {name, interface = I} =
-		 addStr {range = get I,
-			 values = NameSpace.values (strs, name)}
-	      fun handleType {name, typeStr} =
-		 addType {range = typeStr,
-			  values = NameSpace.values (types, name)}
-	      fun handleVal {name, scheme, status} =
-		 let
-		    val con = CoreML.Con.fromString o Ast.Vid.toString
-		    val var = CoreML.Var.fromString o Ast.Vid.toString
-		    val vid =
-		       case status of
-			  Status.Con => Vid.Con (con name)
-			| Status.Exn => Vid.Exn (con name)
-			| Status.Var => Vid.Var (var name)
-		 in
-		    addVal {range = (vid, scheme),
-			    values = NameSpace.values (vals, name)}
-		 end
-	      val _ =
-		 Interface.foreach
-		 (I, {handleStr = handleStr,
-		      handleType = handleType,
-		      handleVal = handleVal})
-	   in
-	      finish (SOME (Interface.shapeId I))
-	   end))
-   in
-      get I
-   end
-
-val dummyStructure =
-   Trace.trace ("dummyStructure",
-		Interface.layout o #2,
-		Structure.layoutPretty)
-   dummyStructure
 
 (* ------------------------------------------------- *)
-(*                  functorClosure                   *)
+(*                       peek                        *)
 (* ------------------------------------------------- *)
 
-fun snapshot (T {currentScope, fcts, fixs, sigs, strs, types, vals}):
-   (unit -> 'a) -> 'a =
-   let
-      fun m l = Layout.outputl (l, Out.error)
-      open Layout
-      fun doit (NameSpace.T {current, table, ...}, lay) =
-	 let
-	    val all =
-	       HashSet.fold
-	       (table, [], fn (vs as Values.T {ranges, ...}, ac) =>
-		case !ranges of
-		   [] => ac
-		 | z :: _ => (z, vs) :: ac)
-	 in
-	    fn s0 =>
-	    let
-	       val current0 = !current
-	       val _ =
-		  current :=
-		  List.fold
-		  (all, [], fn (({isUsed, value, ...},
-				 vs as Values.T {ranges, ...}), ac) =>
-		   (List.push (ranges, {isUsed = isUsed,
-					scope = s0,
-					value = value})
-		    ; vs :: ac))
-	       val removed =
-		  HashSet.fold
-		  (table, [], fn (Values.T {ranges, ...}, ac) =>
-		   let
-		      val r = !ranges
-		   in
-		      case r of
-			 [] => ac
-		       | {scope, ...} :: _ =>
-			    if Scope.equals (s0, scope)
-			       then ac
-			    else (ranges := []
-				  ; (ranges, r) :: ac)
-		   end)
-	    in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
-			 ; current := current0
-			 ; List.foreach (removed, op :=))
-	    end
-	 end
-      val fcts = doit (fcts, Ast.Fctid.layout)
-      val fixs = doit (fixs, Ast.Vid.layout)
-      val sigs = doit (sigs, Ast.Sigid.layout)
-      val strs = doit (strs, Ast.Strid.layout)
-      val types = doit (types, Ast.Tycon.layout)
-      val vals = doit (vals, Ast.Vid.layout)
-   in
-      fn th =>
+local
+   fun 'a make field (T fields, a) = NameSpace.peek (field fields, a)
+in
+   val peekFctid = make #fcts
+   val peekFix = make #fixs
+   val peekFix =
+      Trace.trace
+      ("peekFix", Ast.Vid.layout o #2, Option.layout Ast.Fixity.layout)
+      peekFix			      
+   val peekSigid = make #sigs
+   val peekStrid = make #strs
+   val peekTycon = make #types
+   val peekVid = make #vals
+   fun peekVar (E, x) =
+      case peekVid (E, Ast.Vid.fromVar x) of
+	 NONE => NONE
+       | 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
+      NONE => NONE
+    | SOME (vid, s) => Option.map (Vid.deCon vid, fn c => (c, s))
+
+fun layoutStrids (ss: Strid.t list): Layout.t =
+   Layout.str (concat (List.separate (List.map (ss, Strid.toString), ".")))
+   
+structure PeekResult =
+   struct
+      datatype 'a t =
+	 Found of 'a
+       | UndefinedStructure of Strid.t list
+       | Undefined
+
+      fun layout lay =
+	 fn Found z => lay z
+	  | UndefinedStructure ss => layoutStrids ss
+	  | Undefined => Layout.str "Undefined"
+
+      val toOption: 'a t -> 'a option =
+	 fn Found z => SOME z
+	  | _ => NONE
+   end
+    
+local
+   datatype z = datatype PeekResult.t
+   fun make (split: 'a -> Strid.t list * 'b,
+	     peek: t * 'b -> 'c option,
+	     strPeek: Structure.t * 'b -> 'c option) (E, x) =
       let
-	 val s0 = Scope.new ()
-	 val fcts = fcts s0
-	 val fixs = fixs s0
-	 val sigs = sigs s0
-	 val strs = strs s0
-	 val types = types s0
-	 val vals = vals s0
-	 val s1 = !currentScope
-	 val _ = currentScope := s0
-	 val res = th ()
-	 val _ = currentScope := s1
-	 val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
+	 val (strids, x) = split x
       in
-	 res
+	 case strids of
+	    [] => (case peek (E, x) of
+		      NONE => Undefined
+		    | SOME z => Found z)
+	  | strid :: strids =>
+	       case peekStrid (E, strid) of
+		  NONE => UndefinedStructure [strid]
+		| SOME S =>
+		     case Structure.peekStrids (S, strids) of
+			Structure.Found S =>
+			   (case strPeek (S, x) of
+			       NONE => Undefined
+			     | SOME z => Found z)
+		      | Structure.UndefinedStructure ss =>
+			   UndefinedStructure (strid :: ss)
       end
-   end
+in
+   val peekLongstrid =
+      make (Ast.Longstrid.split, peekStrid, Structure.peekStrid)
+   val peekLongtycon =
+      make (Ast.Longtycon.split, peekTycon, Structure.peekTycon)
+   val peekLongvar = make (Ast.Longvar.split, peekVar, Structure.peekVar)
+   val peekLongvid = make (Ast.Longvid.split, peekVid, Structure.peekVid)
+   val peekLongcon = make (Ast.Longcon.split, peekCon, Structure.peekCon)
+end
 
-val useFunctorSummary = ref false
-val newTycons: (Tycon.t * Kind.t) list ref = ref []
-
-val newTycon: string * Kind.t -> Tycon.t =
-   fn (s, k) =>
-   let
-      val c = Tycon.fromString s
-      val _ = List.push (newTycons, (c, k))
-   in
-      c
-   end
-
-val propertyFun:
-   ('a -> PropertyList.t) * ('a * 'b * ('a * 'b -> 'c) -> 'c)
-   -> ('a * 'b -> 'c) * {destroy: unit -> unit} =
-   fn (plist, f) =>
-   let
-      fun uncurry g (a, b) = g a b 
-      val {destroy, get: 'a -> 'b -> 'c, ...} =
-	 Property.destGet
-	 (plist,
-	  Property.initRec
-	  (fn (a, get) =>
-	   let
-	      val done = ref NONE
-	   in
-	      fn b =>
-	      case !done of
-		 NONE =>
-		    let
-		       val c = f (a, b, uncurry get)
-		       val _ = done := SOME c
-		    in
-		       c
-		    end
-	       | SOME c => c
-	   end))
-   in
-      (uncurry get, {destroy = destroy})
-   end
-		     
-fun functorClosure
-   (E: t,
-    argInt: Interface.t,
-    makeBody: Structure.t * string list -> Decs.t * Structure.t) =
-   let
-      val formal = dummyStructure (E, argInt)
-      val _ = useFunctorSummary := 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.
-       *)
-      val _ = newTycons := []
-      val (_, res) = makeBody (formal, [])
-      val generative = !newTycons
-      val _ = newTycons := []
-      val _ = useFunctorSummary := false
-      val restore = snapshot E
-      fun apply (arg, nest, region) =
-	 let
-	    val (actual, decs) =
-	       Structure.cut (arg, {interface = argInt,
-				    opaque = false,
-				    region = region})
-	 in
-	    if !useFunctorSummary
-	       then
-		  let
-		     val {destroy = destroy1,
-			  get = tyconTypeStr: Tycon.t -> TypeStr.t option,
-			  set = setTyconTypeStr, ...} =
-			Property.destGetSet (Tycon.plist,
-					     Property.initConst NONE)
-		     (* Match the actual against the formal, to set the
-		      * tycons.  Then duplicate the res, replacing tycons.
-		      * Want to generate new tycons just like the functor body
-		      * did.
-		      * Need to treat the formal as a DAG.
-		      *)
-		     val (setTycons, {destroy}) =
-			propertyFun
-			(Structure.plist,
-			 (fn (formal, actual, setTycons) =>
-			  let
-			     val Structure.T {strs = Info.T s,
-					      types = Info.T t, ...} =
-				formal
-			     val Structure.T {strs = Info.T s',
-					      types = Info.T t', ...} =
-				actual
-			     val _ =
-				Array.foreach2
-				(t, t',
-				 fn ({range = r, ...},
-				     {range = r', ...}) =>
-				 let
-				    fun doit tycon =
-				       setTyconTypeStr (tycon, SOME r')
-				 in
-				    case TypeStr.node r of
-				       TypeStr.Datatype {tycon, ...} =>
-					  doit tycon
-				     | TypeStr.Scheme _ => ()
-				     | TypeStr.Tycon tycon => doit tycon
-				 end)
-			     val _ =
-				Array.foreach2
-				(s, s', fn ({range = s, ...},
-					    {range = s', ...}) =>
-				 setTycons (s, s'))
-			  in
-			     ()
-			  end))
-		     val _ = setTycons (formal, actual)
-		     val _ = destroy ()
-		     val _ =
-			List.foreach
-			(generative, fn (c, k) =>
-			 setTyconTypeStr
-			 (c, SOME (TypeStr.tycon
-				   (newTycon (Tycon.originalName c, k),
-				    k))))
-		     fun replaceType (t: Type.t): Type.t =
-			let
-			   fun con (c, ts) =
-			      case tyconTypeStr c of
-				 NONE => Type.con (c, ts)
-			       | SOME s => TypeStr.apply (s, ts)
-			in
-			   Type.hom (t, {con = con,
-					 record = Type.record,
-					 var = Type.var})
-			end
-		     fun replaceScheme (s: Scheme.t): Scheme.t =
-			let
-			   val (tyvars, ty) = Scheme.dest s
-			in
-			   Scheme.make {canGeneralize = true,
-					ty = replaceType ty,
-					tyvars = tyvars}
-			end
-		     fun replaceCons (Cons.T v): Cons.t =
-			Cons.T
-			(Vector.map
-			 (v, fn {con, name, scheme} =>
-			  {con = con,
-			   name = name,
-			   scheme = replaceScheme scheme}))
-		     fun replaceTypeStr (s: TypeStr.t): TypeStr.t =
-			let
-			   val k = TypeStr.kind s
-			   datatype z = datatype TypeStr.node
-			in
-			   case TypeStr.node s of
-			      Datatype {cons, tycon} =>
-				 let
-				    val tycon =
-				       case tyconTypeStr tycon of
-					  NONE => tycon
-					| SOME s =>
-					     (case TypeStr.node s of
-						Datatype {tycon, ...} => tycon
-					      | Scheme _ =>
-						   Error.bug "bad datatype"
-					      | Tycon c => c)
-				 in
-				    TypeStr.data (tycon, k, replaceCons cons)
-				 end
-			    | Scheme s => TypeStr.def (replaceScheme s, k)
-			    | Tycon c =>
-				 (case tyconTypeStr c of
-				     NONE => s
-				   | SOME s' => s')
-			end
-		     val {destroy = destroy2,
-			  get = replacement: Structure.t -> Structure.t, ...} =
-			Property.destGet
-			(Structure.plist,
-			 Property.initRec
-			 (fn (Structure.T {shapeId, strs, types, vals, ... },
-			      replacement) =>
-			  Structure.T
-			  {plist = PropertyList.new (),
-			   shapeId = shapeId,
-			   strs = Info.map (strs, replacement),
-			   types = Info.map (types, replaceTypeStr),
-			   vals = Info.map (vals, fn (v, s) =>
-					    (v, replaceScheme s))}))
-		     val res = replacement res
-		     val _ = destroy1 ()
-		     val _ = destroy2 ()
-		  in
-		     (Decs.empty, res)
-		  end
-	    else
-	       let
-		  val (decs', str) = restore (fn () => makeBody (actual, nest))
-	       in
-		  (Decs.append (decs, decs'),
-		   str)
-	       end
-	 end
-      val apply =
-	 Trace.trace ("functorApply",
-		      Structure.layout o #1,
-		      Layout.tuple2 (Layout.ignore, Structure.layout))
-	 apply
-      fun sizeMessage () = layoutSize apply
-      val fc =
-	 FunctorClosure.T {apply = apply,
-			   sizeMessage = sizeMessage}
-   in
-      fc
-   end
-
-(* ------------------------------------------------- *)
-(*                       peek                        *)
-(* ------------------------------------------------- *)
-
-local
-   fun 'a make field (T fields, a) = NameSpace.peek (field fields, a)
-in
-   val peekFctid = make #fcts
-   val peekFix = make #fixs
-   val peekFix =
-      Trace.trace
-      ("peekFix", Ast.Vid.layout o #2, Option.layout Ast.Fixity.layout)
-      peekFix			      
-   val peekSigid = make #sigs
-   val peekStrid = make #strs
-   val peekTycon = make #types
-   val peekVid = make #vals
-   fun peekVar (E, x) =
-      case peekVid (E, Ast.Vid.fromVar x) of
-	 NONE => NONE
-       | 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
-      NONE => NONE
-    | SOME (vid, s) => Option.map (Vid.deCon vid, fn c => (c, s))
-
-fun layoutStrids (ss: Strid.t list): Layout.t =
-   Layout.str (concat (List.separate (List.map (ss, Strid.toString), ".")))
-   
-structure PeekResult =
-   struct
-      datatype 'a t =
-	 Found of 'a
-       | UndefinedStructure of Strid.t list
-       | Undefined
-
-      fun layout lay =
-	 fn Found z => lay z
-	  | UndefinedStructure ss => layoutStrids ss
-	  | Undefined => Layout.str "Undefined"
-
-      val toOption: 'a t -> 'a option =
-	 fn Found z => SOME z
-	  | _ => NONE
-   end
-    
-local
-   datatype z = datatype PeekResult.t
-   fun make (split: 'a -> Strid.t list * 'b,
-	     peek: t * 'b -> 'c option,
-	     strPeek: Structure.t * 'b -> 'c option) (E, x) =
-      let
-	 val (strids, x) = split x
-      in
-	 case strids of
-	    [] => (case peek (E, x) of
-		      NONE => Undefined
-		    | SOME z => Found z)
-	  | strid :: strids =>
-	       case peekStrid (E, strid) of
-		  NONE => UndefinedStructure [strid]
-		| SOME S =>
-		     case Structure.peekStrids (S, strids) of
-			Structure.Found S =>
-			   (case strPeek (S, x) of
-			       NONE => Undefined
-			     | SOME z => Found z)
-		      | Structure.UndefinedStructure ss =>
-			   UndefinedStructure (strid :: ss)
-      end
-in
-   val peekLongstrid =
-      make (Ast.Longstrid.split, peekStrid, Structure.peekStrid)
-   val peekLongtycon =
-      make (Ast.Longtycon.split, peekTycon, Structure.peekTycon)
-   val peekLongvar = make (Ast.Longvar.split, peekVar, Structure.peekVar)
-   val peekLongvid = make (Ast.Longvid.split, peekVid, Structure.peekVid)
-   val peekLongcon = make (Ast.Longcon.split, peekCon, Structure.peekCon)
-end
-
-val peekLongcon =
-   Trace.trace2 ("peekLongcon", Layout.ignore, Ast.Longcon.layout,
-		 PeekResult.layout (Layout.tuple2
-				    (CoreML.Con.layout, TypeScheme.layout)))
-   peekLongcon
-(* ------------------------------------------------- *)
-(*                      lookup                       *)
-(* ------------------------------------------------- *)
+val peekLongcon =
+   Trace.trace2 ("peekLongcon", Layout.ignore, Ast.Longcon.layout,
+		 PeekResult.layout (Layout.tuple2
+				    (CoreML.Con.layout, TypeScheme.layout)))
+   peekLongcon
+(* ------------------------------------------------- *)
+(*                      lookup                       *)
+(* ------------------------------------------------- *)
 
 fun unbound (r: Region.t, className, x: Layout.t): unit =
    Control.error
@@ -1505,219 +868,960 @@
 (*                      extend                       *)
 (* ------------------------------------------------- *)
 
-local
-   fun make get (T (fields as {currentScope, ...}), domain, range) =
-      let
-	 val ns = get fields
-      in
-	 NameSpace.update (ns, !currentScope,
-			   {isUsed = ref false,
-			    range = range,
-			    values = NameSpace.values (ns, domain)})
-      end
-in
-   val extendFctid = make #fcts
-   val extendFix = make #fixs
-   val extendFix =
-      Trace.trace ("extendFix",
-		   fn (_, x, f) => Layout.tuple [Ast.Vid.layout x,
-						 Ast.Fixity.layout f],
-		   Unit.layout)
-      extendFix
-   val extendSigid = make #sigs
-   val extendStrid = make #strs
-   val extendTycon = make #types
-   val extendVals = make #vals
-end
+local
+   fun make get (T (fields as {currentScope, ...}), domain, range) =
+      let
+	 val ns = get fields
+      in
+	 NameSpace.update (ns, !currentScope,
+			   {isUsed = ref false,
+			    range = range,
+			    values = NameSpace.values (ns, domain)})
+      end
+in
+   val extendFctid = make #fcts
+   val extendFix = make #fixs
+   val extendFix =
+      Trace.trace ("extendFix",
+		   fn (_, x, f) => Layout.tuple [Ast.Vid.layout x,
+						 Ast.Fixity.layout f],
+		   Unit.layout)
+      extendFix
+   val extendSigid = make #sigs
+   val extendStrid = make #strs
+   val extendTycon = make #types
+   val extendVals = make #vals
+end
+
+val extendTycon =
+   Trace.trace3 ("extendTycon", layout, Ast.Tycon.layout, TypeStr.layout,
+		 Unit.layout)
+   extendTycon
+
+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))
+	       
+fun extendVar (E, x, x', s) =
+   extendVals (E, Ast.Vid.fromVar x, (Vid.Var x', s))
+
+fun extendOverload (E, x, yts, s) =
+   extendVals (E, Ast.Vid.fromVar x, (Vid.Overload yts, s))
+
+val extendVar =
+   Trace.trace4
+   ("extendVar", Layout.ignore, Ast.Var.layout, Var.layout, Scheme.layoutPretty,
+    Unit.layout)
+   extendVar
+
+(* ------------------------------------------------- *)   
+(*                       local                       *)
+(* ------------------------------------------------- *)
+
+local
+   fun doit (info as NameSpace.T {current, ...}, s0) =
+      let
+	 val old = !current
+	 val _ = current := []
+      in
+	 fn () =>
+	 let
+	    val c1 = !current
+	    val _ = current := []
+	 in
+	    fn () =>
+	    let
+	       val c2 = !current
+	       val lift = List.map (c2, Values.pop)
+	       val _ = List.foreach (c1, fn v => (Values.pop v; ()))
+	       val _ = current := old
+	       val _ =
+		  List.foreach2 (lift, c2, fn ({isUsed, value, ...}, values) =>
+				 NameSpace.update
+				 (info, s0, {isUsed = isUsed,
+					     range = value,
+					     values = values}))
+	    in
+	       ()
+	    end
+	 end
+      end
+in
+   fun localTop (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, f) =
+      let
+	 val s0 = !currentScope
+	 val fcts = doit (fcts, s0)
+	 val fixs = doit (fixs, s0)
+	 val sigs = doit (sigs, s0)
+	 val strs = doit (strs, s0)
+	 val types = doit (types, s0)
+	 val vals = doit (vals, s0)
+	 val _ = currentScope := Scope.new ()
+	 val a = f ()
+	 val fcts = fcts ()
+	 val fixs = fixs ()
+	 val sigs = sigs ()
+	 val strs = strs ()
+	 val types = types ()
+	 val vals = vals ()
+	 fun finish g =
+	    let
+	       val _ = currentScope := Scope.new ()
+	       val b = g ()
+	       val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
+	       val _ = currentScope := s0
+	    in
+	       b
+	    end
+      in (a, finish)
+      end
+
+   fun localModule (T {currentScope, fixs, strs, types, vals, ...},
+		    f1, f2) =
+      let
+	 val s0 = !currentScope
+	 val fixs = doit (fixs, s0)
+	 val strs = doit (strs, s0)
+	 val types = doit (types, s0)
+	 val vals = doit (vals, s0)
+	 val _ = currentScope := Scope.new ()
+	 val a1 = f1 ()
+	 val fixs = fixs ()
+	 val strs = strs ()
+	 val types = types ()
+	 val vals = vals ()
+	 val _ = currentScope := Scope.new ()
+	 val a2 = f2 a1
+	 val _ = (fixs (); strs (); types (); vals ())
+	 val _ = currentScope := s0
+      in
+	 a2
+      end
+
+   (* Can't eliminate the use of strs in localCore, because openn still modifies
+    * module level constructs.
+    *)
+   val localCore = localModule
+end
+
+fun makeStructure (T {currentScope, fixs, strs, types, vals, ...}, make) =
+   let
+      val f = NameSpace.collect (fixs, Ast.Vid.<=)
+      val s = NameSpace.collect (strs, Ast.Strid.<=)
+      val t = NameSpace.collect (types, Ast.Tycon.<=)
+      val v = NameSpace.collect (vals, Ast.Vid.<=)
+      val s0 = !currentScope
+      val _ = currentScope := Scope.new ()
+      val res = make ()
+      val _ = f ()
+      val S = Structure.T {plist = PropertyList.new (),
+			   shapeId = NONE,
+			   strs = s (),
+			   types = t (),
+			   vals = v ()}
+      val _ = currentScope := s0
+   in (res, S)
+   end
+      
+fun scope (T {currentScope, fixs, strs, types, vals, ...}, th) =
+   let
+      fun doit (NameSpace.T {current, ...}) =
+	 let
+	    val old = !current
+	    val _ = current := []
+	 in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
+		      ; current := old)
+	 end
+      val s0 = !currentScope
+      val _ = currentScope := Scope.new ()
+      val f = doit fixs 
+      val s = doit strs
+      val t = doit types
+      val v = doit vals
+      val res = th ()
+      val _ = (f (); s (); t (); v ())
+      val _ = currentScope := s0
+   in res
+   end
+
+fun scopeAll (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, th) =
+   let
+      fun doit (NameSpace.T {current, ...}) =
+	 let
+	    val old = !current
+	    val _ = current := []
+	 in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
+		      ; current := old)
+	 end
+      val s0 = !currentScope
+      val _ = currentScope := Scope.new ()
+      val fc = doit fcts
+      val f = doit fixs
+      val si = doit sigs
+      val s = doit strs
+      val t = doit types
+      val v = doit vals
+      val res = th ()
+      val _ = (fc (); f (); si (); s (); t (); v ())
+      val _ = currentScope := s0
+   in
+      res
+   end
+
+fun openStructure (T {currentScope, strs, vals, types, ...},
+		   Structure.T {strs = strs',
+				vals = vals',
+				types = types', ...}): unit =
+   let
+      val scope = !currentScope
+      fun doit (info, Info.T a) =
+	 Array.foreach (a, fn z => NameSpace.update (info, scope, z))
+   in doit (strs, strs')
+      ; doit (vals, vals')
+      ; doit (types, types')
+   end
+
 
-val extendTycon =
-   Trace.trace3 ("extendTycon", layout, Ast.Tycon.layout, TypeStr.layout,
-		 Unit.layout)
-   extendTycon
+val propertyFun:
+   ('a -> PropertyList.t) * ('a * 'b * ('a * 'b -> 'c) -> 'c)
+   -> ('a * 'b -> 'c) * {destroy: unit -> unit} =
+   fn (plist, f) =>
+   let
+      fun uncurry g (a, b) = g a b 
+      val {destroy, get: 'a -> 'b -> 'c, ...} =
+	 Property.destGet
+	 (plist,
+	  Property.initRec
+	  (fn (a, get) =>
+	   let
+	      val done = ref NONE
+	   in
+	      fn b =>
+	      case !done of
+		 NONE =>
+		    let
+		       val c = f (a, b, uncurry get)
+		       val _ = done := SOME c
+		    in
+		       c
+		    end
+	       | SOME c => c
+	   end))
+   in
+      (uncurry get, {destroy = destroy})
+   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))
-	       
-fun extendVar (E, x, x', s) =
-   extendVals (E, Ast.Vid.fromVar x, (Vid.Var x', s))
+fun dummyStructure (T {strs, types, vals, ...}, I: Interface.t)
+   : Structure.t * (Structure.t * (Tycon.t * TypeStr.t -> unit) -> unit) =
+   let
+      val tycons: (Longtycon.t * Tycon.t) list ref = ref []
+      val I =
+	 Interface.realize
+	 (I, fn (c, a, k) =>
+	  let
+	     val c' = newTycon (Longtycon.toString c, k)
+	     val _ = TypeEnv.tyconAdmitsEquality c' := a
+	     val _ = List.push (tycons, (c, c'))
+	  in
+	     TypeStr.tycon (c', k)
+	  end)
+      val tycons = !tycons
+      val {get, ...} =
+	 Property.get
+	 (Interface.plist,
+	  Property.initRec
+	  (fn (I, get) =>
+	   let
+	      val {addStr, addType, addVal, finish} = Structure.maker ()
+	      fun handleStr {name, interface = I} =
+		 addStr {range = get I,
+			 values = NameSpace.values (strs, name)}
+	      fun handleType {name, typeStr} =
+		 addType {range = typeStr,
+			  values = NameSpace.values (types, name)}
+	      fun handleVal {name, scheme, status} =
+		 let
+		    val con = CoreML.Con.fromString o Ast.Vid.toString
+		    val var = CoreML.Var.fromString o Ast.Vid.toString
+		    val vid =
+		       case status of
+			  Status.Con => Vid.Con (con name)
+			| Status.Exn => Vid.Exn (con name)
+			| Status.Var => Vid.Var (var name)
+		 in
+		    addVal {range = (vid, scheme),
+			    values = NameSpace.values (vals, name)}
+		 end
+	      val _ =
+		 Interface.foreach
+		 (I, {handleStr = handleStr,
+		      handleType = handleType,
+		      handleVal = handleVal})
+	   in
+	      finish (SOME (Interface.shapeId I))
+	   end))
+      val S = get I
+      fun instantiate (S', f) =
+	 List.foreach (tycons, fn (long, c) =>
+		       case Structure.peekLongtycon (S', long) of
+			  NONE => Error.bug "structure missing longtycon"
+			| SOME s=> f (c, s))
+   in
+      (S, instantiate)
+   end
 
-fun extendOverload (E, x, yts, s) =
-   extendVals (E, Ast.Vid.fromVar x, (Vid.Overload yts, s))
+val dummyStructure =
+   Trace.trace ("dummyStructure",
+		Interface.layout o #2,
+		Structure.layoutPretty o #1)
+   dummyStructure
+	 
+(* section 5.3, 5.5, 5.6 and rules 52, 53 *)
+fun cut (E: t, S: Structure.t, I: Interface.t, {opaque: bool}, region)
+   : Structure.t * Decs.t =
+   let
+      val decs = ref []
+      fun error (name, l) =
+	 let
+	    open Layout
+	 in
+	    Control.error
+	    (region,
+	     seq [str (concat [name, " "]), l,
+		  str " in signature but not in structure"],
+	     empty)
+	 end
+      (* pre: arities are equal. *)
+      fun equalSchemes (s: Scheme.t, s': Scheme.t,
+			name: unit -> Layout.t,
+			r: Region.t): unit =
+	 let
+	    val (tyvars', ty') = Scheme.dest s'
+	    val tyvars =
+	       Vector.tabulate
+	       (Vector.length tyvars', fn _ =>
+		Type.var (Tyvar.newNoname {equality = false}))
+	 in
+	    Type.unify
+	    (Scheme.apply (s, tyvars),
+	     Scheme.apply (Scheme.make {canGeneralize = true,
+					ty = ty',
+					tyvars = tyvars'},
+			   tyvars),
+	     fn (l1, l2) =>
+	     let
+		open Layout
+	     in
+		(r,
+		 seq [str "type ", name (),
+		      str " in structure disagrees with signature"],
+		 align [seq [str "structure: ", l1],
+			seq [str "signature: ", l2]])
+	     end)
+	 end
+      val equalSchemes =
+	 Trace.trace
+	 ("equalSchemes",
+	  fn (s, s', _, _) => Layout.tuple [Scheme.layout s,
+					    Scheme.layout s'],
+	  Unit.layout)
+	 equalSchemes
+      fun checkCons (Cons.T v, Cons.T v', strids): unit =
+	 let
+	    fun lay (c: Ast.Con.t) =
+	       Longcon.layout (Longcon.long (rev strids, c))
+	    val extraStr =
+	       Vector.keepAllMap
+	       (v, fn {name = n, scheme = s, ...} =>
+		case Vector.peek (v', fn {name = n', ...} =>
+				  Ast.Con.equals (n, n')) of
+		   NONE => SOME n
+		 | SOME {scheme = s', ...} =>
+		      let
+			 val _ =
+			    equalSchemes
+			    (s, s', fn () =>
+			     let
+				open Layout
+			     in
+				seq [str "of ", lay n]
+			     end,
+			     region)
+		      in
+			 NONE
+		      end)
+	    fun extras (v, name) =
+	       if 0 = Vector.length v
+		  then ()
+	       else
+		  let
+		     open Layout
+		  in
+		     Control.error
+		     (region,
+		      seq [str (concat ["constructors in ", name, " only: "]),
+			   seq (List.separate (Vector.toListMap (v, lay),
+					       str ", "))],
+		      empty)
+		  end
+	    val _ = extras (extraStr, "structure")
+	    val extraSig =
+	       Vector.keepAllMap
+	       (v', fn {name = n', ...} =>
+		if Vector.exists (v, fn {name = n, ...} =>
+				  Ast.Con.equals (n, n'))
+		   then NONE
+		else SOME n')
+	    val _ = extras (extraSig, "signature")
+	 in
+	    ()
+	 end
+      val I' =
+	 Interface.realize
+	 (I, fn (c, a, k) =>
+	  case Structure.peekLongtycon (S, c) of
+	     NONE => (error ("type", Longtycon.layout c)
+		      ; TypeStr.bogus k)
+	   | SOME typeStr =>
+		let
+		   val _ =
+		      if AdmitsEquality.<= (a, TypeStr.admitsEquality typeStr)
+			 then ()
+		      else
+			 let
+			    open Layout
+			 in
+			    Control.error
+			    (region,
+			     seq [str "type ", Longtycon.layout c,
+				  str " admits equality in signature but not in structure"],
+			     empty)
+			 end
+		   val k' = TypeStr.kind typeStr
+		   val typeStr =
+		      if Kind.equals (k, k')
+			 then typeStr
+		      else
+			 let
+			    open Layout
+			    val _ =
+			       Control.error
+			       (region,
+				seq [str "type ", Longtycon.layout c,
+				     str "has arity ", Kind.layout k',
+				     str "in structure but arity ",
+				     Kind.layout k, str " in signature"],
+				empty)
+			 in
+			    TypeStr.bogus k
+			 end
+		in
+		   typeStr
+		end)
+      fun cut (S as Structure.T {shapeId, ...}, I, strids) =
+	 let
+	    val {addStr, addType, addVal, finish} = Structure.maker ()
+	    val shapeId' = Interface.shapeId I
+	    fun doit () =
+	       let
+		  fun handleStr {name, interface = I} =
+		     case Structure.peekStrid' (S, name) of
+			NONE =>
+			   error
+			   ("structure",
+			    Longstrid.layout	
+			    (Longstrid.long (rev strids, name)))
+		      | SOME {range, values, ...} =>
+			   addStr {range = cut (range, I, name :: strids),
+				   values = values}
+		  fun handleType {name: Ast.Tycon.t,
+				  typeStr: TypeStr.t} =
+		     let
+			fun layoutName () =
+			   Longtycon.layout
+			   (Longtycon.long (rev strids, name))
+		     in
+			case Structure.peekTycon' (S, name) of
+			   NONE => error ("type", layoutName ())
+			 | SOME {range = typeStr', values, ...} =>
+			      let
+				 fun tyconScheme (c: Tycon.t): Scheme.t =
+				    let
+				       val tyvars =
+					  case TypeStr.kind typeStr' of
+					     Kind.Arity n =>
+						Vector.tabulate
+						(n, fn _ =>
+						 Tyvar.newNoname
+						 {equality = false})
+					   | _ => Error.bug "Nary tycon"
+				    in
+				       Scheme.make
+				       {canGeneralize = true,
+					ty = Type.con (c, Vector.map (tyvars, Type.var)),
+					tyvars = tyvars}
+				    end
+				 datatype z = datatype TypeStr.node
+				 val k = TypeStr.kind typeStr
+				 val k' = TypeStr.kind typeStr'
+				 fun typeStrScheme (s: TypeStr.t) =
+				    case TypeStr.node s of
+				       Datatype {tycon, ...} =>
+					  tyconScheme tycon
+				     | Scheme s => s
+				     | Tycon c' => tyconScheme c'
+				 val typeStr =
+				    if not (Kind.equals (k, k'))
+				       then
+					  let
+					     open Layout
+					  in
+					     Control.error
+					     (region,
+					      seq [str "type ", layoutName (),
+						   str " has arity ", Kind.layout k',
+						   str " in structure but arity ", Kind.layout k,
+						   str " in signature"],
+					      empty)
+					     ; typeStr
+					  end
+				    else
+				       case TypeStr.node typeStr of
+					  Datatype {cons = c, ...} =>
+					     (case TypeStr.node typeStr' of
+						 Datatype {cons = c', ...} =>
+						    (checkCons (c', c,
+								strids)
+						     ; typeStr')
+					       | _ =>
+						    let
+						       open Layout
+						    in
+						       Control.error
+						       (region,
+							seq [str "type ",
+							     layoutName (),
+							     str " is a datatype in signature but not in structure"],
+							Layout.empty)
+						       ; typeStr
+						    end)
+					| Scheme s =>
+					     (equalSchemes
+					      (typeStrScheme typeStr',
+					       s, layoutName, region)
+					      ; typeStr)
+					| Tycon c =>
+					     (equalSchemes
+					      (typeStrScheme typeStr',
+					       tyconScheme c,
+					       layoutName, region)
+					      ; typeStr)
+			      in
+				 addType {range = typeStr,
+					  values = values}
+			      end
+		     end
+		  fun handleVal {name, scheme = s, status} =
+		     case Structure.peekVid' (S, name) of
+			NONE =>
+			   error ("variable",
+				  Longvid.layout (Longvid.long
+						  (rev strids, name)))
+		      | SOME {range = (vid, s'), values, ...} =>
+			   let
+			      val (tyvars, t) = Scheme.dest s
+			      val {args, instance = t'} =
+				 Scheme.instantiate s'
+			      val _ =
+				 Type.unify
+				 (t, t', fn (l, l') =>
+				  let
+				     open Layout
+				  in
+				     (region,
+				      seq [str "type in structure disagrees with signature"],
+				      align [seq [str "variable:  ",
+						  Longvid.layout	
+						  (Longvid.long
+						   (rev strids, name))],
+					     seq [str "structure: ", l'],
+					     seq [str "signature: ", l]])
+				  end)
+			      fun addDec (n: Exp.node): Vid.t =
+				 let
+				    val x = Var.newNoname ()
+				    val e = Exp.make (n, t')
+				    val _ =
+				       List.push
+				       (decs,
+					Dec.Val
+					{rvbs = Vector.new0 (),
+					 tyvars = fn () => tyvars,
+					 vbs = (Vector.new1
+						{exp = e,
+						 lay = fn _ => Layout.empty,
+						 pat = Pat.var (x, t'),
+						 patRegion = region})})
+				 in
+				    Vid.Var x
+				 end
+			      fun con (c: Con.t): Vid.t =
+				 addDec (Exp.Con (c, args ()))
+			      val vid =
+				 case (vid, status) of
+				    (Vid.Con c, Status.Var) => con c
+				  | (Vid.Exn c, Status.Var) => con c
+				  | (Vid.Var x, Status.Var) =>
+				       if 0 < Vector.length tyvars
+					  orelse 0 < Vector.length (args ())
+					  then
+					     addDec
+					     (Exp.Var (fn () => x, args))
+				       else vid
+					   | (Vid.Con _, Status.Con) => vid
+					   | (Vid.Exn _, Status.Exn) => vid
+					   | _ =>
+						(Control.error
+						 (region,
+						  Layout.str
+						  (concat
+						   ["identifier ",
+						    Longvid.toString
+						    (Longvid.long (rev strids,
+								   name)),
+						    " is ",
+						    Vid.statusPretty vid,
+						    " in the structure but ",
+						    Status.pretty status,
+						    " in the signature "]),
+						  Layout.empty)
+						 ; vid)
+			   in
+			      addVal {range = (vid, s),
+				      values = values}
+			   end
+		  val _ =
+		     Interface.foreach
+		     (I, {handleStr = handleStr,
+			  handleType = handleType,
+			  handleVal = handleVal})
+	       in
+		  finish (SOME shapeId')
+	       end
+	 in
+	    case shapeId of
+	       NONE => doit ()
+	     | SOME shapeId =>
+		  if ShapeId.equals (shapeId, shapeId')
+		     then S
+		  else doit ()
+	 end
+      val S = cut (S, I', [])
+      val S =
+	 if not opaque
+	    then S
+	 else
+	    let
+	       fun fixCons (Cons.T cs, Cons.T cs') =
+		  Cons.T
+		  (Vector.map
+		   (cs', fn {con, name, scheme} =>
+		    let
+		       val con =
+			  case Vector.peek (cs, fn {name = n, ...} =>
+					    Ast.Con.equals (n, name)) of
+			     NONE => Con.bogus
+			   | SOME {con, ...} => con
+		    in
+		       {con = con, name = name, scheme = scheme}
+		    end))
+	       val (S', instantiate) = dummyStructure (E, I)
+	       val _ = instantiate (S, fn (c, s) =>
+				    TypeEnv.setOpaqueTyconExpansion
+				    (c, fn ts => TypeStr.apply (s, ts)))
+	       val {destroy,
+		    get = replacements: (Structure.t
+					 -> {formal: Structure.t,
+					     new: Structure.t} list ref), ...} =
+		  Property.destGet (Structure.plist,
+				Property.initFun (fn _ => ref []))
+	       fun loop (S, S'): Structure.t =
+		  let
+		     val rs = replacements S
+		  in
+		     case List.peek (!rs, fn {formal, ...} =>
+				     Structure.eq (S', formal)) of
+			NONE =>
+			   let
+			      val Structure.T {shapeId, strs, types, vals,
+					       ...} = S
+			      val Structure.T {strs = strs',
+					       types = types',
+					       vals = vals', ...} = S'
+			      val strs = Info.map2 (strs, strs', loop)
+			      val types =
+				 Info.map2
+				 (types, types', fn (s, s') =>
+				  let
+				     datatype z = datatype TypeStr.node
+				  in
+				     case TypeStr.node s' of
+					Datatype {cons = cs', tycon} =>
+					   (case TypeStr.node s of
+					       Datatype {cons = cs, ...} =>
+						  TypeStr.data
+						  (tycon, TypeStr.kind s',
+						   fixCons (cs, cs'))
+					     | _ => s')
+				      | Scheme _ => s'
+				      | Tycon _ => s'
+				  end)
+			      val vals =
+				 Info.map2 (vals, vals', fn ((v, _), (_, s)) =>
+					    (v, s))
+			      val new =
+				 Structure.T {plist = PropertyList.new (),
+					      shapeId = shapeId,
+					      strs = strs,
+					      types = types,
+					      vals = vals}
+			      val _ = List.push (rs, {formal = S', new = new})
+			   in
+			      new
+			   end
+		      | SOME {new, ...} => new
+		  end
+	       val S'' = loop (S, S')
+	       val _ = destroy ()
+	    in
+	       S''
+	    end
+   in
+      (S, Decs.fromList (!decs))
+   end
 
-val extendVar =
-   Trace.trace4
-   ("extendVar", Layout.ignore, Ast.Var.layout, Var.layout, Scheme.layoutPretty,
-    Unit.layout)
-   extendVar
+val cut =
+   Trace.trace ("cut",
+		fn (_, S, I, _, _) =>
+		Layout.tuple [Structure.layoutPretty S, Interface.layout I],
+		Structure.layoutPretty o #1)
+   cut
 
-(* ------------------------------------------------- *)   
-(*                       local                       *)
+(* ------------------------------------------------- *)
+(*                  functorClosure                   *)
 (* ------------------------------------------------- *)
 
-local
-   fun doit (info as NameSpace.T {current, ...}, s0) =
-      let
-	 val old = !current
-	 val _ = current := []
-      in
-	 fn () =>
+fun snapshot (T {currentScope, fcts, fixs, sigs, strs, types, vals}):
+   (unit -> 'a) -> 'a =
+   let
+      fun m l = Layout.outputl (l, Out.error)
+      open Layout
+      fun doit (NameSpace.T {current, table, ...}, lay) =
 	 let
-	    val c1 = !current
-	    val _ = current := []
+	    val all =
+	       HashSet.fold
+	       (table, [], fn (vs as Values.T {ranges, ...}, ac) =>
+		case !ranges of
+		   [] => ac
+		 | z :: _ => (z, vs) :: ac)
 	 in
-	    fn () =>
+	    fn s0 =>
 	    let
-	       val c2 = !current
-	       val lift = List.map (c2, Values.pop)
-	       val _ = List.foreach (c1, fn v => (Values.pop v; ()))
-	       val _ = current := old
+	       val current0 = !current
 	       val _ =
-		  List.foreach2 (lift, c2, fn ({isUsed, value, ...}, values) =>
-				 NameSpace.update
-				 (info, s0, {isUsed = isUsed,
-					     range = value,
-					     values = values}))
-	    in
-	       ()
-	    end
-	 end
-      end
-in
-   fun localTop (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, f) =
-      let
-	 val s0 = !currentScope
-	 val fcts = doit (fcts, s0)
-	 val fixs = doit (fixs, s0)
-	 val sigs = doit (sigs, s0)
-	 val strs = doit (strs, s0)
-	 val types = doit (types, s0)
-	 val vals = doit (vals, s0)
-	 val _ = currentScope := Scope.new ()
-	 val a = f ()
-	 val fcts = fcts ()
-	 val fixs = fixs ()
-	 val sigs = sigs ()
-	 val strs = strs ()
-	 val types = types ()
-	 val vals = vals ()
-	 fun finish g =
-	    let
-	       val _ = currentScope := Scope.new ()
-	       val b = g ()
-	       val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
-	       val _ = currentScope := s0
-	    in
-	       b
+		  current :=
+		  List.fold
+		  (all, [], fn (({isUsed, value, ...},
+				 vs as Values.T {ranges, ...}), ac) =>
+		   (List.push (ranges, {isUsed = isUsed,
+					scope = s0,
+					value = value})
+		    ; vs :: ac))
+	       val removed =
+		  HashSet.fold
+		  (table, [], fn (Values.T {ranges, ...}, ac) =>
+		   let
+		      val r = !ranges
+		   in
+		      case r of
+			 [] => ac
+		       | {scope, ...} :: _ =>
+			    if Scope.equals (s0, scope)
+			       then ac
+			    else (ranges := []
+				  ; (ranges, r) :: ac)
+		   end)
+	    in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
+			 ; current := current0
+			 ; List.foreach (removed, op :=))
 	    end
-      in (a, finish)
-      end
-
-   fun localModule (T {currentScope, fixs, strs, types, vals, ...},
-		    f1, f2) =
+	 end
+      val fcts = doit (fcts, Ast.Fctid.layout)
+      val fixs = doit (fixs, Ast.Vid.layout)
+      val sigs = doit (sigs, Ast.Sigid.layout)
+      val strs = doit (strs, Ast.Strid.layout)
+      val types = doit (types, Ast.Tycon.layout)
+      val vals = doit (vals, Ast.Vid.layout)
+   in
+      fn th =>
       let
-	 val s0 = !currentScope
-	 val fixs = doit (fixs, s0)
-	 val strs = doit (strs, s0)
-	 val types = doit (types, s0)
-	 val vals = doit (vals, s0)
-	 val _ = currentScope := Scope.new ()
-	 val a1 = f1 ()
-	 val fixs = fixs ()
-	 val strs = strs ()
-	 val types = types ()
-	 val vals = vals ()
-	 val _ = currentScope := Scope.new ()
-	 val a2 = f2 a1
-	 val _ = (fixs (); strs (); types (); vals ())
+	 val s0 = Scope.new ()
+	 val fcts = fcts s0
+	 val fixs = fixs s0
+	 val sigs = sigs s0
+	 val strs = strs s0
+	 val types = types s0
+	 val vals = vals s0
+	 val s1 = !currentScope
 	 val _ = currentScope := s0
+	 val res = th ()
+	 val _ = currentScope := s1
+	 val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
       in
-	 a2
+	 res
       end
-
-   (* Can't eliminate the use of strs in localCore, because openn still modifies
-    * module level constructs.
-    *)
-   val localCore = localModule
-end
-
-fun makeStructure (T {currentScope, fixs, strs, types, vals, ...}, make) =
-   let
-      val f = NameSpace.collect (fixs, Ast.Vid.<=)
-      val s = NameSpace.collect (strs, Ast.Strid.<=)
-      val t = NameSpace.collect (types, Ast.Tycon.<=)
-      val v = NameSpace.collect (vals, Ast.Vid.<=)
-      val s0 = !currentScope
-      val _ = currentScope := Scope.new ()
-      val res = make ()
-      val _ = f ()
-      val S = Structure.T {plist = PropertyList.new (),
-			   shapeId = NONE,
-			   strs = s (),
-			   types = t (),
-			   vals = v ()}
-      val _ = currentScope := s0
-   in (res, S)
-   end
-      
-fun scope (T {currentScope, fixs, strs, types, vals, ...}, th) =
-   let
-      fun doit (NameSpace.T {current, ...}) =
-	 let
-	    val old = !current
-	    val _ = current := []
-	 in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
-		      ; current := old)
-	 end
-      val s0 = !currentScope
-      val _ = currentScope := Scope.new ()
-      val f = doit fixs 
-      val s = doit strs
-      val t = doit types
-      val v = doit vals
-      val res = th ()
-      val _ = (f (); s (); t (); v ())
-      val _ = currentScope := s0
-   in res
    end
 
-fun scopeAll (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, th) =
+val useFunctorSummary = ref false
+		     
+fun functorClosure
+   (E: t,
+    argInt: Interface.t,
+    makeBody: Structure.t * string list -> Decs.t * Structure.t) =
    let
-      fun doit (NameSpace.T {current, ...}) =
+      val (formal, instantiate) = dummyStructure (E, argInt)
+      val _ = useFunctorSummary := 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.
+       *)
+      val _ = newTycons := []
+      val (_, res) = makeBody (formal, [])
+      val generative = !newTycons
+      val _ = newTycons := []
+      val _ = useFunctorSummary := false
+      val restore = snapshot E
+      fun apply (arg, nest, region) =
 	 let
-	    val old = !current
-	    val _ = current := []
-	 in fn () => (List.foreach (!current, fn v => (Values.pop v; ()))
-		      ; current := old)
+	    val (actual, decs) = cut (E, arg, argInt, {opaque = false}, region)
+	 in
+	    if !useFunctorSummary
+	       then
+		  let
+		     val {destroy = destroy1,
+			  get = tyconTypeStr: Tycon.t -> TypeStr.t option,
+			  set = setTyconTypeStr, ...} =
+			Property.destGetSet (Tycon.plist,
+					     Property.initConst NONE)
+		     (* Match the actual against the formal, to set the tycons.
+		      * Then duplicate the res, replacing tycons.
+		      * Want to generate new tycons just like the functor body
+		      * did.
+		      *)
+		     val _ =
+			instantiate (actual, fn (c, s) =>
+				     setTyconTypeStr (c, SOME s))
+		     val _ =
+			List.foreach
+			(generative, fn (c, k) =>
+			 setTyconTypeStr
+			 (c, SOME (TypeStr.tycon
+				   (newTycon (Tycon.originalName c, k),
+				    k))))
+		     fun replaceType (t: Type.t): Type.t =
+			let
+			   fun con (c, ts) =
+			      case tyconTypeStr c of
+				 NONE => Type.con (c, ts)
+			       | SOME s => TypeStr.apply (s, ts)
+			in
+			   Type.hom (t, {con = con,
+					 expandOpaque = Type.Never,
+					 record = Type.record,
+					 var = Type.var})
+			end
+		     fun replaceScheme (s: Scheme.t): Scheme.t =
+			let
+			   val (tyvars, ty) = Scheme.dest s
+			in
+			   Scheme.make {canGeneralize = true,
+					ty = replaceType ty,
+					tyvars = tyvars}
+			end
+		     fun replaceCons (Cons.T v): Cons.t =
+			Cons.T
+			(Vector.map
+			 (v, fn {con, name, scheme} =>
+			  {con = con,
+			   name = name,
+			   scheme = replaceScheme scheme}))
+		     fun replaceTypeStr (s: TypeStr.t): TypeStr.t =
+			let
+			   val k = TypeStr.kind s
+			   datatype z = datatype TypeStr.node
+			in
+			   case TypeStr.node s of
+			      Datatype {cons, tycon} =>
+				 let
+				    val tycon =
+				       case tyconTypeStr tycon of
+					  NONE => tycon
+					| SOME s =>
+					     (case TypeStr.node s of
+						Datatype {tycon, ...} => tycon
+					      | Scheme _ =>
+						   Error.bug "bad datatype"
+					      | Tycon c => c)
+				 in
+				    TypeStr.data (tycon, k, replaceCons cons)
+				 end
+			    | Scheme s => TypeStr.def (replaceScheme s, k)
+			    | Tycon c =>
+				 (case tyconTypeStr c of
+				     NONE => s
+				   | SOME s' => s')
+			end
+		     val {destroy = destroy2,
+			  get = replacement: Structure.t -> Structure.t, ...} =
+			Property.destGet
+			(Structure.plist,
+			 Property.initRec
+			 (fn (Structure.T {shapeId, strs, types, vals, ... },
+			      replacement) =>
+			  Structure.T
+			  {plist = PropertyList.new (),
+			   shapeId = shapeId,
+			   strs = Info.map (strs, replacement),
+			   types = Info.map (types, replaceTypeStr),
+			   vals = Info.map (vals, fn (v, s) =>
+					    (v, replaceScheme s))}))
+		     val res = replacement res
+		     val _ = destroy1 ()
+		     val _ = destroy2 ()
+		  in
+		     (Decs.empty, res)
+		  end
+	    else
+	       let
+		  val (decs', str) = restore (fn () => makeBody (actual, nest))
+	       in
+		  (Decs.append (decs, decs'),
+		   str)
+	       end
 	 end
-      val s0 = !currentScope
-      val _ = currentScope := Scope.new ()
-      val fc = doit fcts
-      val f = doit fixs
-      val si = doit sigs
-      val s = doit strs
-      val t = doit types
-      val v = doit vals
-      val res = th ()
-      val _ = (fc (); f (); si (); s (); t (); v ())
-      val _ = currentScope := s0
+      val apply =
+	 Trace.trace ("functorApply",
+		      Structure.layout o #1,
+		      Layout.tuple2 (Layout.ignore, Structure.layout))
+	 apply
+      fun sizeMessage () = layoutSize apply
+      val fc =
+	 FunctorClosure.T {apply = apply,
+			   sizeMessage = sizeMessage}
    in
-      res
-   end
-
-fun openStructure (T {currentScope, strs, vals, types, ...},
-		   Structure.T {strs = strs',
-				vals = vals',
-				types = types', ...}): unit =
-   let
-      val scope = !currentScope
-      fun doit (info, Info.T a) =
-	 Array.foreach (a, fn z => NameSpace.update (info, scope, z))
-   in doit (strs, strs')
-      ; doit (vals, vals')
-      ; doit (types, types')
+      fc
    end
 
 end



1.12      +6 -6      mlton/mlton/elaborate/elaborate-env.sig

Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- elaborate-env.sig	11 Nov 2003 21:26:34 -0000	1.11
+++ elaborate-env.sig	14 Nov 2003 03:48:18 -0000	1.12
@@ -67,12 +67,6 @@
 	 sig
 	    type t
 	       
-	    (* cut keeps only those bindings in the structure that also appear
-	     * in the interface.  It proceeds recursively on substructures.
-	     *)
-	    val cut: t * {interface: Interface.t,
-			  opaque: bool,
-			  region: Region.t} -> t * Decs.t
 	    (* ffi represents MLtonFFI, which is built by the basis library
 	     * and is set in compile.sml after processing the basis.
 	     *)
@@ -90,6 +84,12 @@
 
       (* Remove unnecessary entries. *)
       val clean: t -> unit
+      (* cut keeps only those bindings in the structure that also appear
+       * in the interface.  It proceeds recursively on substructures.
+       *)
+      val cut:
+	 t * Structure.t * Interface.t * {opaque: bool} * 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



1.5       +160 -168  mlton/mlton/elaborate/elaborate-sigexp.fun

Index: elaborate-sigexp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-sigexp.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- elaborate-sigexp.fun	7 Nov 2003 23:45:22 -0000	1.4
+++ elaborate-sigexp.fun	14 Nov 2003 03:48:18 -0000	1.5
@@ -45,6 +45,7 @@
 local
    open TypeStr
 in
+   structure AdmitsEquality = AdmitsEquality
    structure Cons = Cons
    structure Kind = Kind
    structure Scheme = Scheme
@@ -52,12 +53,6 @@
    structure Type = Type
 end
 
-local
-   open Tycon
-in
-   structure AdmitsEquality = AdmitsEquality
-end
-
 fun lookupLongtycon (E: Env.t,
 		     I: Interface.t,
 		     c: Ast.Longtycon.t): TypeStr.t =
@@ -307,169 +302,166 @@
 
 (* rule 65 *)
 fun elaborateSigexp (sigexp: Sigexp.t, E: Env.t): Interface.t =
-   case Sigexp.node sigexp of
-      Sigexp.Var s => Env.lookupSigid (E, s)
-    | _ =>
-	 let
-	    fun elaborateSigexp arg : Interface.t =
-	       Trace.traceInfo' (info,
-				 Layout.tuple2 (Sigexp.layout,
-						Interface.layout),
-				 Interface.layout)
-	       (fn (sigexp: Sigexp.t, I: Interface.t) =>
-		case Sigexp.node sigexp of
-		   Sigexp.Spec spec => (* rule 62 *)
-		      elaborateSpec (spec, I)
-		 | Sigexp.Var x => (* rule 63 *)
-		      Interface.copy (Env.lookupSigid (E, x))
-		 | Sigexp.Where (sigexp, wheres) => (* rule 64 *)
-		      let
-			 val I' = elaborateSigexp (sigexp, I)
-			 val _ =
-			    Interface.wheres
-			    (I',
-			     Vector.fromListMap
-			     (wheres, fn {tyvars, longtycon, ty} =>
-			      (longtycon,
-			       TypeStr.def
-			       (Scheme.make (elaborateType (ty, E, I)),
-				Kind.Arity (Vector.length tyvars)))))
-		      in
-			 I'
-		      end) arg
-	    and elaborateSpec arg : Interface.t =
-	       Trace.traceInfo' (info',
-				 Layout.tuple2 (Ast.Spec.layout, Layout.ignore),
-				 Layout.ignore)
-	       (fn (spec: Ast.Spec.t, I: Interface.t) =>
-		case Spec.node spec of
-		   Spec.Datatype rhs => (* rules 71, 72 *)
-		      (case DatatypeRhs.node rhs of
-			  DatatypeRhs.DatBind b => elaborateDatBind (b, E, I)
-			| DatatypeRhs.Repl {lhs, rhs} =>
-			     let
-				val s = lookupLongtycon (E, I, rhs)
-			     in
-				Interface.+
-				(Interface.types (Vector.new1 {name = lhs,
-							       typeStr = s}),
-				 Interface.cons (TypeStr.cons s))
-			     end)
-		 | Spec.Empty => (* rule 76 *)
-		      Interface.empty
-		 | Spec.Eqtype typedescs => (* rule 70 *)
-		      elaborateTypedescs (typedescs, {equality = true})
-		 | Spec.Exception cons => (* rule 73 *)
-		      Interface.excons
-		      (Cons.T
-		       (Vector.fromListMap
-			(cons, fn (name: TypeStr.Name.t,
-				   arg: Ast.Type.t option) =>
-			 let
-			    val con = Con.newNoname ()
-			    val (arg, ty) =
-			       case arg of
-				  NONE => (NONE, Type.exn)
-				| SOME t =>
-				     let
-					val t =
-					   Scheme.ty
-					   (elaborateScheme (Vector.new0 (),
-							     t, E, I))
-				     in
-					(SOME t, Type.arrow (t, Type.exn))
-				     end
-			 in
-			    {con = con: TypeStr.Con.t,
-			     name= name: TypeStr.Name.t,
-			     scheme = Scheme.make (Vector.new0 (), ty)}
-			 end)))
-		 | Spec.IncludeSigexp sigexp => (* rule 75 *)
-		      elaborateSigexp (sigexp, I)
-		 | Spec.IncludeSigids sigids => (* Appendix A, p.59 *)
-		      List.fold
-		      (sigids, Interface.empty, fn (sigid, I) =>
-		       Interface.+
-		       (I, Interface.copy (Env.lookupSigid (E, sigid))))
-		 | Spec.Seq (s, s') => (* rule 77 *)
-		      let
-			 val I' = elaborateSpec (s, I)
-			 val I'' = elaborateSpec (s', Interface.+ (I', I))
-		     in
-			Interface.+ (I', I'')
-		     end
-		 | Spec.Sharing {equations, spec} =>
-		      (* rule 78 and section G.3.3 *)
-		      let
-			 val I' = elaborateSpec (spec, I)
-			 fun share eqn =
-			    case Equation.node eqn of
-			       Equation.Structure ss =>
-				  let
-				     fun loop ss =
-					case ss of
-					   [] => ()
-					 | s :: ss =>
-					      (List.foreach
-					       (ss, fn s' =>
-						Interface.share (I', s, s'))
-					       ; loop ss)
-				  in
-				     loop ss
-				  end
-			     | Equation.Type cs =>
-				  case cs of
+   let
+      fun elaborateSigexp arg : Interface.t =
+	 Trace.traceInfo' (info,
+			   Layout.tuple2 (Sigexp.layout,
+					  Interface.layout),
+			   Interface.layout)
+	 (fn (sigexp: Sigexp.t, I: Interface.t) =>
+	  case Sigexp.node sigexp of
+	     Sigexp.Spec spec => (* rule 62 *)
+		elaborateSpec (spec, I)
+	   | Sigexp.Var x => (* rule 63 *)
+		Interface.copy (Env.lookupSigid (E, x))
+	   | Sigexp.Where (sigexp, wheres) => (* rule 64 *)
+		let
+		   val I' = elaborateSigexp (sigexp, I)
+		   val _ =
+		      Interface.wheres
+		      (I',
+		       Vector.fromListMap
+		       (wheres, fn {tyvars, longtycon, ty} =>
+			(longtycon,
+			 TypeStr.def
+			 (Scheme.make (elaborateType (ty, E, I)),
+			  Kind.Arity (Vector.length tyvars)))))
+		in
+		   I'
+		end) arg
+      and elaborateSpec arg : Interface.t =
+	 Trace.traceInfo' (info',
+			   Layout.tuple2 (Ast.Spec.layout, Layout.ignore),
+			   Layout.ignore)
+	 (fn (spec: Ast.Spec.t, I: Interface.t) =>
+	  case Spec.node spec of
+	     Spec.Datatype rhs => (* rules 71, 72 *)
+		(case DatatypeRhs.node rhs of
+		    DatatypeRhs.DatBind b => elaborateDatBind (b, E, I)
+		  | DatatypeRhs.Repl {lhs, rhs} =>
+		       let
+			  val s = lookupLongtycon (E, I, rhs)
+		       in
+			  Interface.+
+			  (Interface.types (Vector.new1 {name = lhs,
+							 typeStr = s}),
+			   Interface.cons (TypeStr.cons s))
+		       end)
+	   | Spec.Empty => (* rule 76 *)
+		Interface.empty
+	   | Spec.Eqtype typedescs => (* rule 70 *)
+		elaborateTypedescs (typedescs, {equality = true})
+	   | Spec.Exception cons => (* rule 73 *)
+		Interface.excons
+		(Cons.T
+		 (Vector.fromListMap
+		  (cons, fn (name: TypeStr.Name.t,
+			     arg: Ast.Type.t option) =>
+		   let
+		      val con = Con.newNoname ()
+		      val (arg, ty) =
+			 case arg of
+			    NONE => (NONE, Type.exn)
+			  | SOME t =>
+			       let
+				  val t =
+				     Scheme.ty
+				     (elaborateScheme (Vector.new0 (),
+						       t, E, I))
+			       in
+				  (SOME t, Type.arrow (t, Type.exn))
+			       end
+		   in
+		      {con = con: TypeStr.Con.t,
+		       name= name: TypeStr.Name.t,
+		       scheme = Scheme.make (Vector.new0 (), ty)}
+		   end)))
+	   | Spec.IncludeSigexp sigexp => (* rule 75 *)
+		elaborateSigexp (sigexp, I)
+	   | Spec.IncludeSigids sigids => (* Appendix A, p.59 *)
+		List.fold
+		(sigids, Interface.empty, fn (sigid, I) =>
+		 Interface.+
+		 (I, Interface.copy (Env.lookupSigid (E, sigid))))
+	   | Spec.Seq (s, s') => (* rule 77 *)
+		let
+		   val I' = elaborateSpec (s, I)
+		   val I'' = elaborateSpec (s', Interface.+ (I', I))
+		in
+		   Interface.+ (I', I'')
+		end
+	   | Spec.Sharing {equations, spec} =>
+		(* rule 78 and section G.3.3 *)
+		let
+		   val I' = elaborateSpec (spec, I)
+		   fun share eqn =
+		      case Equation.node eqn of
+			 Equation.Structure ss =>
+			    let
+			       fun loop ss =
+				  case ss of
 				     [] => ()
-				   | c :: cs =>
-					List.foreach
-					(cs, fn c' =>
-					 Interface.shareType (I', c, c'))
-			 val _ = List.foreach (equations, share)
-		      in
-			 I'
-		      end
-		 | Spec.Structure ss => (* rules 74, 84 *)
-		     Interface.strs
-		     (Vector.fromListMap
-		      (ss, fn (strid, sigexp) =>
-		       {interface = elaborateSigexp (sigexp, I),
-			name = strid}))
-		 | Spec.Type typedescs => (* rule 69 *)
-		      elaborateTypedescs (typedescs, {equality = false})
-		 | Spec.TypeDefs typBind =>
-		      (* Abbreviation on page 59,
-		       * combined with rules 77 and 80.
-		       *)
-		      let
-			 val TypBind.T ds = TypBind.node typBind
-		      in
-			 #2
-			 (List.fold
-			  (ds, (I, Interface.empty),
-			   fn ({def, tycon, tyvars}, (I, I')) =>
-			   let
-			      val I'' = 
-				 Interface.types
-				 (Vector.new1
-				  {name = tycon,
-				   typeStr = (TypeStr.def
-					      (elaborateScheme (tyvars, def, E, I),
-					       Kind.Arity (Vector.length tyvars)))})
-			   in
-			      (Interface.+ (I, I''), Interface.+ (I', I''))
-			   end))
-		      end
-		 | Spec.Val xts => (* rules 68, 79 *)
-		      Interface.vals
-		      (Vector.fromListMap
-		       (xts, fn (x, t) =>
-			{name = Ast.Vid.fromVar x,
-			 scheme = Scheme.make (elaborateType (t, E, I)),
-			 status = Status.Var}))
-		   ) arg
-	 in
-	    elaborateSigexp (sigexp, Interface.empty)
-	 end
+				   | s :: ss =>
+					(List.foreach
+					 (ss, fn s' =>
+					  Interface.share (I', s, s'))
+					 ; loop ss)
+			    in
+			       loop ss
+			    end
+		       | Equation.Type cs =>
+			    case cs of
+			       [] => ()
+			     | c :: cs =>
+				  List.foreach
+				  (cs, fn c' =>
+				   Interface.shareType (I', c, c'))
+		   val _ = List.foreach (equations, share)
+		in
+		   I'
+		end
+	   | Spec.Structure ss => (* rules 74, 84 *)
+		Interface.strs
+		(Vector.fromListMap
+		 (ss, fn (strid, sigexp) =>
+		  {interface = elaborateSigexp (sigexp, I),
+		   name = strid}))
+	   | Spec.Type typedescs => (* rule 69 *)
+		elaborateTypedescs (typedescs, {equality = false})
+	   | Spec.TypeDefs typBind =>
+		(* Abbreviation on page 59,
+		 * combined with rules 77 and 80.
+		 *)
+		let
+		   val TypBind.T ds = TypBind.node typBind
+		in
+		   #2
+		   (List.fold
+		    (ds, (I, Interface.empty),
+		     fn ({def, tycon, tyvars}, (I, I')) =>
+		     let
+			val I'' = 
+			   Interface.types
+			   (Vector.new1
+			    {name = tycon,
+			     typeStr = (TypeStr.def
+					(elaborateScheme (tyvars, def, E, I),
+					 Kind.Arity (Vector.length tyvars)))})
+		     in
+			(Interface.+ (I, I''), Interface.+ (I', I''))
+		     end))
+		end
+	   | Spec.Val xts => (* rules 68, 79 *)
+		Interface.vals
+		(Vector.fromListMap
+		 (xts, fn (x, t) =>
+		  {name = Ast.Vid.fromVar x,
+		   scheme = Scheme.make (elaborateType (t, E, I)),
+		   status = Status.Var}))
+		) arg
+   in
+      elaborateSigexp (sigexp, Interface.empty)
+   end
 
 val elaborateSigexp = 
    Trace.trace2 ("elaborateSigexp",



1.10      +2 -3      mlton/mlton/elaborate/elaborate.fun

Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- elaborate.fun	10 Nov 2003 23:01:59 -0000	1.9
+++ elaborate.fun	14 Nov 2003 03:48:18 -0000	1.10
@@ -86,9 +86,8 @@
 	    fun s (sigexp, opaque) =
 	       let
 		  val (S, decs) =
-		     Structure.cut (S, {interface = elabSigexp sigexp,
-					opaque = opaque,
-					region = Sigexp.region sigexp})
+		     Env.cut (E, S, elabSigexp sigexp, {opaque = opaque},
+			      Sigexp.region sigexp)
 	       in
 		  (decs, S)
 	       end



1.3       +3 -3      mlton/mlton/elaborate/interface.fun

Index: interface.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- interface.fun	7 Nov 2003 23:45:22 -0000	1.2
+++ interface.fun	14 Nov 2003 03:48:18 -0000	1.3
@@ -26,6 +26,7 @@
 local
    open EtypeStr
 in
+   structure AdmitsEquality = AdmitsEquality
    structure Con = Con
    structure Econs = Cons
    structure Kind = Kind
@@ -34,8 +35,6 @@
    structure Etype = Type
 end
 
-structure AdmitsEquality = Etycon.AdmitsEquality
-
 structure Set = DisjointSet
 
 structure ShapeId = UniqueId ()
@@ -422,7 +421,8 @@
 	 end
    end
 
-structure TypeStr = TypeStr (structure Con = Con
+structure TypeStr = TypeStr (structure AdmitsEquality = AdmitsEquality
+			     structure Con = Con
 			     structure Kind = Kind
 			     structure Name = Ast.Con
 			     structure Record = Record



1.3       +1 -1      mlton/mlton/elaborate/interface.sig

Index: interface.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/interface.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- interface.sig	7 Nov 2003 23:45:22 -0000	1.2
+++ interface.sig	14 Nov 2003 03:48:18 -0000	1.3
@@ -99,7 +99,7 @@
       val plist: t -> PropertyList.t
       (* realize makes a copy, and instantiate longtycons *)
       val realize: t * (Ast.Longtycon.t
-			* TypeStr.Tycon.AdmitsEquality.t
+			* TypeStr.AdmitsEquality.t
 			* TypeStr.Kind.t -> EnvTypeStr.t) -> t
       val shapeId: t -> ShapeId.t
       val share: t * Ast.Longstrid.t * Ast.Longstrid.t -> unit



1.11      +59 -9     mlton/mlton/elaborate/type-env.fun

Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- type-env.fun	7 Nov 2003 00:21:28 -0000	1.10
+++ type-env.fun	14 Nov 2003 03:48:18 -0000	1.11
@@ -460,8 +460,23 @@
       fun union (T s, T s') = Set.union (s, s')
 
       fun set (T s, v) = Set.setValue (s, v)
-	 
-      fun makeHom {con, flexRecord, genFlexRecord, int, real,
+
+      val {get = opaqueTyconExpansion: Tycon.t -> (t vector -> t) option,
+	   set = setOpaqueTyconExpansion, ...} =
+	 Property.getSet (Tycon.plist, Property.initConst NONE)
+
+      val opaqueTyconExpansion =
+	 Trace.trace ("opaqueTyconExpansion",
+		      Tycon.layout,
+		      Layout.ignore)
+	 opaqueTyconExpansion
+
+      datatype expandOpaque =
+	 Always
+	| Never
+	| Sometimes of Tycon.t -> bool
+
+      fun makeHom {con, expandOpaque, flexRecord, genFlexRecord, int, real,
 		   record, recursive, unknown, var, word} =
 	 let
 	    datatype status = Processing | Seen | Unseen
@@ -486,7 +501,20 @@
 			     val res = 
 				case toType t of
 				   Con (c, ts) =>
-				      con (t, c, Vector.map (ts, get))
+				      let
+					 fun no () =
+					    con (t, c, Vector.map (ts, get))
+					 fun yes () =
+					    (case opaqueTyconExpansion c of
+						NONE => no ()
+					      | SOME f => get (f ts))
+				      in
+					 case expandOpaque of
+					    Always => yes ()
+					  | Never => no ()
+					  | Sometimes f =>
+					       if f c then yes () else no ()
+				      end
 				 | Int => int t
 				 | FlexRecord {fields, spine, time} =>
 				      flexRecord (t, {fields = loopFields fields,
@@ -576,6 +604,7 @@
 	    fun word _ = simple (str "word")
 	    val (res, _) =
 	       hom (t, {con = con,
+			expandOpaque = Never,
 			flexRecord = flexRecord,
 			genFlexRecord = genFlexRecord,
 			int = int,
@@ -669,6 +698,9 @@
       fun var a = newTy (Var a, Equality.fromBool (Tyvar.isEquality a))
    end
 
+fun setOpaqueTyconExpansion (c, f) =
+   Type.setOpaqueTyconExpansion (c, SOME f)
+
 structure Ops = TypeOps (structure IntSize = IntSize
 			 structure Tycon = Tycon
 			 structure WordSize = WordSize
@@ -773,6 +805,7 @@
 	    val {destroy, hom} =
 	       makeHom
 	       {con = fn _ => (),
+		expandOpaque = Never,
 		flexRecord = fn (_, {time = r, ...}) => doit r,
 		genFlexRecord = fn _ => (),
 		int = fn _ => (),
@@ -1115,15 +1148,16 @@
 	  | UnifyResult.Unified => Unified
 
       val word8 = word WordSize.W8
-      
+	 
       fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
+			expandOpaque: expandOpaque,
 			record: t * (Field.t * 'a) vector -> 'a,
 			replaceCharWithWord8: bool,
 			var: t * Tyvar.t -> 'a} =
 	 let
 	    val con =
 	       fn (t, c, ts) =>
-	       if replaceCharWithWord8 andalso  Tycon.equals (c, Tycon.char)
+	       if replaceCharWithWord8 andalso Tycon.equals (c, Tycon.char)
 		  then con (word8, Tycon.word WordSize.W8, Vector.new0 ())
 	       else con (t, c, ts)
 	    val unit = con (unit, Tycon.tuple, Vector.new0 ())
@@ -1160,6 +1194,7 @@
 	       con (word WordSize.default, Tycon.defaultWord, Vector.new0 ())
 	 in
 	    makeHom {con = con,
+		     expandOpaque = expandOpaque,
 		     int = fn _ => int,
 		     flexRecord = flexRecord,
 		     genFlexRecord = genFlexRecord,
@@ -1281,9 +1316,10 @@
 		      | SOME ty => {isNew = true, ty = ty}
 		  val {ty: Type.t, ...} =
 		     Type.hom (ty, {con = con,
-				    int = keep,
+				    expandOpaque = Never,
 				    flexRecord = keep o #1,
 				    genFlexRecord = genFlexRecord,
+				    int = keep,
 				    real = keep,
 				    record = record,
 				    recursive = recursive,
@@ -1365,6 +1401,7 @@
 	    exception Yes
 	    val {destroy, hom} =
 	       Type.makeHom {con = fn _ => (),
+			     expandOpaque = Type.Never,
 			     flexRecord = fn _ => (),
 			     genFlexRecord = fn _ => (),
 			     int = fn _ => (),
@@ -1534,7 +1571,7 @@
    struct
       open Type
 
-      fun homConVar {con, var} =
+      fun homConVar {con, expandOpaque, var} =
 	 let
 	    fun tuple (t, ts) =
 	       if 1 = Vector.length ts
@@ -1542,13 +1579,15 @@
 	       else con (t, Tycon.tuple, ts)
 	 in
 	    simpleHom {con = con,
+		       expandOpaque = expandOpaque,
 		       record = fn (t, fs) => tuple (t, Vector.map (fs, #2)),
 		       replaceCharWithWord8 = true,
 		       var = var}
 	 end
 
-      fun makeHom {con, var} =
+      fun makeHom {con, expandOpaque, var} =
 	 homConVar {con = fn (_, c, ts) => con (c, ts),
+		    expandOpaque = expandOpaque,
 		    var = fn (_, a) => var a}
 	 
       fun deRecord t =
@@ -1556,6 +1595,7 @@
 	    val {hom, destroy} =
 	       simpleHom
 	       {con = fn (t, _, _) => (t, NONE),
+		expandOpaque = Never,
 		record = fn (t, fs) => (t,
 					SOME (Vector.map (fs, fn (f, (t, _)) =>
 							  (f, t)))),
@@ -1578,6 +1618,7 @@
 					if Tycon.equals (c, Tycon.tuple)
 					   then SOME (Vector.map (ts, #1))
 					else NONE),
+		expandOpaque = Never,
                 var = fn (t, _) => (t, NONE)}
 	    val res = #2 (hom t)
 	    val _ = destroy ()
@@ -1592,10 +1633,11 @@
 
       val deTuple = valOf o deTupleOpt
 
-      fun hom (t, {con, record, var}) =
+      fun hom (t, {con, expandOpaque, record, var}) =
 	 let
 	    val {hom, destroy} =
 	       simpleHom {con = fn (_, c, v) => con (c, v),
+			  expandOpaque = expandOpaque,
 			  record = fn (_, fs) => record (Srecord.fromVector fs),
 			  replaceCharWithWord8 = false,
 			  var = fn (_, a) => var a}
@@ -1605,6 +1647,13 @@
 	    res
 	 end
 
+      fun expandOpaque (t: t, e): t =
+	 hom (t, {con = con, expandOpaque = e, record = record, var = var})
+
+      val expandOpaque =
+	 Trace.trace ("expandOpaque", layoutPretty o #1, layoutPretty)
+	 expandOpaque
+
       val unify =
 	 fn (t1: t, t2: t,
 	     f: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t) =>
@@ -1612,4 +1661,5 @@
 	    NotUnifiable z => Control.error (f z)
 	  | Unified => ()
    end
+
 end



1.6       +8 -0      mlton/mlton/elaborate/type-env.sig

Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- type-env.sig	7 Nov 2003 00:21:28 -0000	1.5
+++ type-env.sig	14 Nov 2003 03:48:18 -0000	1.6
@@ -26,10 +26,17 @@
 	    val deEta: t * Tyvar.t vector -> Tycon.t option
 	    val deRecord: t -> (Record.Field.t * t) vector
 	    val flexRecord: t SortedRecord.t -> t * (unit -> bool)
+	    datatype expandOpaque =
+	       Always
+	     | Never
+	     | Sometimes of Tycon.t -> bool
+	    val expandOpaque: t * expandOpaque -> t
 	    val hom: t * {con: Tycon.t * 'a vector -> 'a,
+			  expandOpaque: expandOpaque,
 			  record: 'a SortedRecord.t -> 'a,
 			  var: Tyvar.t -> 'a} -> 'a
 	    val makeHom: {con: Tycon.t * 'a vector -> 'a,
+			  expandOpaque: expandOpaque,
 			  var: Tyvar.t -> 'a} -> {destroy: unit -> unit,
 						  hom: t -> 'a}
 	    val isUnit: t -> bool
@@ -84,6 +91,7 @@
 	 -> {bound: unit -> Tyvar.t vector,
 	     schemes: Scheme.t vector}
       val closeTop: Region.t -> unit
+      val setOpaqueTyconExpansion: Tycon.t * (Type.t vector -> Type.t) -> unit
       val tyconAdmitsEquality: Tycon.t -> Tycon.AdmitsEquality.t ref
    end
 



1.2       +14 -0     mlton/mlton/elaborate/type-str.fun

Index: type-str.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-str.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- type-str.fun	7 Nov 2003 00:21:28 -0000	1.1
+++ type-str.fun	14 Nov 2003 03:48:18 -0000	1.2
@@ -10,6 +10,12 @@
 
 open S
 
+local
+   open Tycon
+in
+   structure AdmitsEquality = AdmitsEquality
+end
+
 structure Cons =
    struct
       datatype t = T of {con: Con.t,
@@ -55,6 +61,14 @@
        | 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,



1.3       +2 -2      mlton/mlton/elaborate/type-str.sig

Index: type-str.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-str.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- type-str.sig	7 Nov 2003 23:45:22 -0000	1.2
+++ type-str.sig	14 Nov 2003 03:48:18 -0000	1.3
@@ -7,6 +7,7 @@
  *)
 signature TYPE_STR_STRUCTS = 
    sig
+      structure AdmitsEquality: ADMITS_EQUALITY
       structure Con:
 	 sig
 	    type t
@@ -23,8 +24,6 @@
 	 end
       structure Tycon:
 	 sig
-	    structure AdmitsEquality: ADMITS_EQUALITY
-
 	    type t
 
 	    val admitsEquality: t -> AdmitsEquality.t ref
@@ -93,6 +92,7 @@
        | 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



1.10      +6 -0      mlton/mlton/main/compile.fun

Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- compile.fun	11 Nov 2003 21:25:57 -0000	1.9
+++ compile.fun	14 Nov 2003 03:48:18 -0000	1.10
@@ -49,6 +49,12 @@
 			      struct
 				 open TypeEnv.Type
 
+				 val makeHom =
+				    fn {con, var} =>
+				    makeHom {con = con,
+					     expandOpaque = Always,
+					     var = var}
+				    
 				 val layout = layoutPretty
 			      end)
 structure Xml = Xml (open Atoms)