[MLton] cvs commit: interaction of elaboration controls and functor applications

Matthew Fluet fluet@mlton.org
Sun, 13 Feb 2005 05:27:58 -0800


fluet       05/02/13 05:27:58

  Modified:    mlton/control control.sig control.sml
               mlton/elaborate elaborate-env.fun
  Log:
  MAIL interaction of elaboration controls and functor applications
  
  Due to the re-elaboration of a functor body at the point of
  application, elaboration control dependent type-errors might only
  appear at the point of application, not at the point of definition.
  For example, consider the following:
  
  a.sml:
  functor F_A () =
     struct
        val r = ref 0
        fun inc () = (r := !r + 1; !r)
  
        fun f x y =
  	 (inc ()
  	  ; x + y)
  
        datatype t = A | B | C | D
        fun g x =
  	 case x of A => 1
     end
  
  b.sml:
  structure B_S = F_A ()
  
  z.mlb:
  $(SML_LIB)/basis/basis.mlb
  ann "sequenceUnit true" "warnMatch false" in
    a.sml
  end
  ann "sequenceUnit true" "warnMatch true" in
    b.sml
  end
  
  The old behavior would produce:
  
  bash-2.05b$ mlton-stable -stop tc z.mlb
  Error: a.sml 7.4.
    Sequence expression not of type unit.
      type: [int]
      in: inc ()
  Warning: a.sml 12.3.
    Case is not exhaustive.
      missing pattern: B | C | D
      in: case x of (A) => (1)
  compilation aborted: elaborate reported errors
  
  Notice that the errors are a bit misleading: they point to a.sml, but
  a.sml was clearly elaborated in a context with sequenceUnit false and
  warnMatch false.  We can confirm that it is due to the re-elaboration
  in b.sml by commenting out b.sml from the .mlb:
  
  z.mlb:
  $(SML_LIB)/basis/basis.mlb
  ann "sequenceUnit true" "warnMatch false" in
    a.sml
  end
  ann "sequenceUnit true" "warnMatch true" in
    (* b.sml *)
  end
  
  The new behavior is to snapshot the state of the elaboration controls
  at the point of functor definition and (temporarily) reinstate those
  controls for each application (i.e., re-elaboration of the body).
  I think this is a more intuitive behavior.

Revision  Changes    Path
1.120     +1 -0      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.119
retrieving revision 1.120
diff -u -r1.119 -r1.120
--- control.sig	22 Dec 2004 05:11:25 -0000	1.119
+++ control.sig	13 Feb 2005 13:27:57 -0000	1.120
@@ -107,6 +107,7 @@
 	    val processEnabled: string * bool -> bool
 
 	    val withDef: (unit -> 'a) -> 'a
+	    val snapshot: unit -> (unit -> 'a) -> 'a
 	 end
 
       (* stop after elaboration.  So, no need for the elaborator to generate



1.157     +28 -4     mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.156
retrieving revision 1.157
diff -u -r1.156 -r1.157
--- control.sml	12 Feb 2005 23:36:47 -0000	1.156
+++ control.sml	13 Feb 2005 13:27:57 -0000	1.157
@@ -175,7 +175,8 @@
 		    parseArgs: string list -> 'args option},
 		   {parseId: string -> Id.t option,
 		    parseIdAndArgs: string -> (Id.t * Args.t) option,
-		    withDef: unit -> (unit -> unit)}) =
+		    withDef: unit -> (unit -> unit),
+		    snapshot: unit -> unit -> (unit -> unit)}) =
 	    let
 	       val ctrl as T {args = argsRef, cur, def, 
 			      id as Id.T {enabled, ...}, ...} =
@@ -246,11 +247,28 @@
 		     ; fn () => (cur := old
 				 ; restore ())
 		  end
+	       val snapshot : unit -> unit -> (unit -> unit) =
+		  fn () =>
+		  let 
+		     val withSaved = snapshot ()
+		     val saved = !cur 
+		  in
+		     fn () =>
+		     let
+			val restore = withSaved ()
+			val old = !cur
+		     in
+			cur := saved
+			; fn () => (cur := old
+				    ; restore ())
+		     end
+		  end
 	    in
 	       (ctrl, 
 		{parseId = parseId,
 		 parseIdAndArgs = parseIdAndArgs,
-		 withDef = withDef})
+		 withDef = withDef,
+		 snapshot = snapshot})
 	    end
 
 	 fun makeBool ({default: bool,
@@ -271,7 +289,8 @@
 	 val ac =
 	    {parseId = fn _ => NONE,
 	     parseIdAndArgs = fn _ => NONE,
-	     withDef = fn () => (fn () => ())}
+	     withDef = fn () => (fn () => ()),
+	     snapshot = fn () => fn () => (fn () => ())}
 	 val (allowConstant, ac) =
 	    makeBool ({name = "allowConstant", default = false, expert = true}, ac)
 	 val (allowExport, ac) =
@@ -316,7 +335,7 @@
 	    makeBool ({name = "warnMatch", default = true, expert = false}, ac)
 	 val (warnUnused, ac) =
 	    makeBool ({name = "warnUnused", default = false, expert = false}, ac)
-	 val {parseId, parseIdAndArgs, withDef} = ac
+	 val {parseId, parseIdAndArgs, withDef, snapshot} = ac
       end
 
       val processDefault = fn s =>
@@ -332,6 +351,11 @@
 	 let val restore = withDef ()
 	 in DynamicWind.wind (f, restore)
 	 end
+      val snapshot : unit -> (unit -> 'a) -> 'a = fn () =>
+	 let val withSaved = snapshot () in fn f =>
+	 let val restore = withSaved ()
+	 in DynamicWind.wind (f, restore)
+	 end end
 
    end
 



1.109     +6 -1      mlton/mlton/elaborate/elaborate-env.fun

Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -r1.108 -r1.109
--- elaborate-env.fun	4 Feb 2005 00:42:38 -0000	1.108
+++ elaborate-env.fun	13 Feb 2005 13:27:57 -0000	1.109
@@ -3136,7 +3136,12 @@
       val restore =
 	 if !Control.elaborateOnly
 	    then fn f => f ()
-	 else snapshot E
+	 else let 
+		 val withSaved = Control.Elaborate.snapshot ()
+		 val snapshot = snapshot E
+	      in 
+		 fn f => snapshot (fn () => withSaved f)
+	      end
       fun apply (actual, nest) =
 	 if not (!insideFunctor) andalso not (!Control.elaborateOnly)
 	    then restore (fn () => makeBody (actual, nest))