[MLton-devel] cvs commit: -basis command line option

Matthew Fluet fluet@users.sourceforge.net
Thu, 21 Nov 2002 20:49:35 -0800


fluet       02/11/21 20:49:34

  Modified:    bin      Tag: basis-2002 check-basis
               mlton/ast Tag: basis-2002 ast.fun ast.sig
               mlton/control Tag: basis-2002 control.sig control.sml
               mlton/elaborate Tag: basis-2002 elaborate-env.fun
                        elaborate-env.sig
               mlton/main Tag: basis-2002 compile.sml main.sml
  Added:       basis-library/libs Tag: basis-2002 build
               basis-library/libs/basis-2002 Tag: basis-2002 basis-funs.sml
                        basis-sigs.sml basis.sig basis.sml bind prefix
                        suffix top-level.sml
               basis-library/libs/none Tag: basis-2002 bind prefix suffix
  Removed:     basis-library Tag: basis-2002 bind-basis build-basis
               basis-library/top-level Tag: basis-2002 basis-funs.sml
                        basis-sigs.sml basis.sig basis.sml top-level.sml
  Log:
  Added -basis command line option (which subsumes the old
  -use-basis-library option).  Currently, only basis-2002 and none are
  supported.  To add a basis, add it to the Control.basisLibs list and
  create a directory in /basis-library/libs with the same name, with
  the files bind, prefix, and suffix.
  World sizes for the partially elaborated basis are on par with the old system.

Revision  Changes    Path
No                   revision


No                   revision

	<<Binary file>>


1.1.2.1   +212 -0    mlton/basis-library/libs/Attic/build




No                   revision


No                   revision


1.1.2.1   +6 -0      mlton/basis-library/libs/basis-2002/Attic/basis-funs.sml




1.1.2.1   +82 -0     mlton/basis-library/libs/basis-2002/Attic/basis-sigs.sml




1.1.2.1   +414 -0    mlton/basis-library/libs/basis-2002/Attic/basis.sig




1.1.2.1   +155 -0    mlton/basis-library/libs/basis-2002/Attic/basis.sml




1.1.2.1   +5 -0      mlton/basis-library/libs/basis-2002/Attic/bind




1.1.2.1   +0 -0      mlton/basis-library/libs/basis-2002/Attic/prefix

	<<Binary file>>


1.1.2.1   +1 -0      mlton/basis-library/libs/basis-2002/Attic/suffix




1.1.2.1   +9 -0      mlton/basis-library/libs/basis-2002/Attic/top-level.sml




No                   revision


No                   revision


1.1.2.1   +0 -0      mlton/basis-library/libs/none/Attic/bind

	<<Binary file>>


1.1.2.1   +0 -0      mlton/basis-library/libs/none/Attic/prefix

	<<Binary file>>


1.1.2.1   +0 -0      mlton/basis-library/libs/none/Attic/suffix

	<<Binary file>>


No                   revision


No                   revision


1.6.2.4   +13 -7     mlton/bin/check-basis

Index: check-basis
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/check-basis,v
retrieving revision 1.6.2.3
retrieving revision 1.6.2.4
diff -u -r1.6.2.3 -r1.6.2.4
--- check-basis	8 Oct 2002 15:06:33 -0000	1.6.2.3
+++ check-basis	22 Nov 2002 04:49:34 -0000	1.6.2.4
@@ -6,7 +6,7 @@
 name=`basename $0`
 
 function usage() {
-	echo >&2 "usage: $name [file.sml | file.cm]"
+	echo >&2 "usage: $name lib [file.sml | file.cm]"
 	exit 1
 }
 
@@ -44,14 +44,20 @@
 
 SML_FILE=""
 CM_FILE=""
+LIB=""
 case "$#" in
 0)
+	usage
 	;;
 1)
-	if [ "$1" == "`basename $1 .sml`.sml" -a -r "$1" ]; then
-		SML_FILE=$1
-	elif [ "$1" == "`basename $1 .cm`.cm" -a -r "$1" ]; then
-		CM_FILE=$1
+	LIB=$1
+	;;
+2)
+	LIB=$1
+	if [ "$2" == "`basename $2 .sml`.sml" -a -r "$2" ]; then
+		SML_FILE=$2
+	elif [ "$2" == "`basename $2 .cm`.cm" -a -r "$2" ]; then
+		CM_FILE=$2
 	else usage
         fi
         ;;
@@ -273,13 +279,13 @@
 	local
 EOF
 cd $root/basis-library
-REWRITE_FILES="build-basis"
+REWRITE_FILES="libs/build"
 rewrite_files
 cat <<-EOF
 	in
 EOF
 cd $root/basis-library
-REWRITE_FILES="bind-basis"
+REWRITE_FILES="libs/$LIB/bind"
 rewrite_files
 cat <<-EOF
 	end



No                   revision


No                   revision


1.5.2.1   +4 -0      mlton/mlton/ast/ast.fun

Index: ast.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.fun,v
retrieving revision 1.5
retrieving revision 1.5.2.1
diff -u -r1.5 -r1.5.2.1
--- ast.fun	10 Apr 2002 07:02:18 -0000	1.5
+++ ast.fun	22 Nov 2002 04:49:34 -0000	1.5.2.1
@@ -342,6 +342,10 @@
    struct
       datatype t = T of Topdec.t list
 
+      val empty = T []
+
+      fun append (T ds1, T ds2) = T (ds1 @ ds2)
+
       fun layout (T ds) = Layout.align (List.map (ds, Topdec.layout))
 
       fun size (T ds): int =



1.2.2.1   +2 -0      mlton/mlton/ast/ast.sig

Index: ast.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.sig,v
retrieving revision 1.2
retrieving revision 1.2.2.1
diff -u -r1.2 -r1.2.2.1
--- ast.sig	10 Apr 2002 07:02:18 -0000	1.2
+++ ast.sig	22 Nov 2002 04:49:34 -0000	1.2.2.1
@@ -171,6 +171,8 @@
 	 sig
 	    datatype t = T of Topdec.t list
 
+	    val append: t * t -> t
+	    val empty: t
 	    val size: t -> int
 	    val layout: t -> Layout.t
 	 end



No                   revision


No                   revision


1.48.2.1  +3 -0      mlton/mlton/control/control.sig

Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.48
retrieving revision 1.48.2.1
diff -u -r1.48 -r1.48.2.1
--- control.sig	12 Jul 2002 18:53:17 -0000	1.48
+++ control.sig	22 Nov 2002 04:49:34 -0000	1.48.2.1
@@ -18,6 +18,9 @@
       (*            Begin Flags             *)
       (*------------------------------------*)
 
+      val basisLibs: string list
+      val basisLibrary: string ref
+
       datatype chunk =
 	 OneChunk
        | ChunkPerFunc



1.60.2.1  +5 -0      mlton/mlton/control/control.sml

Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.60
retrieving revision 1.60.2.1
diff -u -r1.60 -r1.60.2.1
--- control.sml	12 Jul 2002 18:53:17 -0000	1.60
+++ control.sml	22 Nov 2002 04:49:34 -0000	1.60.2.1
@@ -11,6 +11,11 @@
 structure C = Control ()
 open C
 
+val basisLibs = ["basis-2002", "none"]
+val basisLibrary = control {name = "basis library",
+			    default = "basis-2002",
+			    toString = fn s => s}
+
 structure Chunk =
    struct
       datatype t =



No                   revision


No                   revision


1.7.2.1   +12 -8     mlton/mlton/elaborate/elaborate-env.fun

Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.7
retrieving revision 1.7.2.1
diff -u -r1.7 -r1.7.2.1
--- elaborate-env.fun	10 Apr 2002 07:02:20 -0000	1.7
+++ elaborate-env.fun	22 Nov 2002 04:49:34 -0000	1.7.2.1
@@ -1047,8 +1047,7 @@
 	 end
       end
 in
-   fun localTop (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...},
-		 f1, f2) =
+   fun localTop (T {currentScope, fcts, fixs, sigs, strs, types, vals, ...}, f) =
       let
 	 val s0 = !currentScope
 	 val fcts = doit (fcts, s0)
@@ -1058,18 +1057,23 @@
 	 val types = doit (types, s0)
 	 val vals = doit (vals, s0)
 	 val _ = currentScope := Scope.new ()
-	 val a1 = f1 ()
+	 val a = f ()
 	 val fcts = fcts ()
 	 val fixs = fixs ()
 	 val sigs = sigs ()
 	 val strs = strs ()
 	 val types = types ()
 	 val vals = vals ()
-	 val _ = currentScope := Scope.new ()
-	 val a2 = f2 ()
-	 val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
-	 val _ = currentScope := s0
-      in (a1, a2)
+	 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, ...},



1.3.2.1   +1 -1      mlton/mlton/elaborate/elaborate-env.sig

Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.3
retrieving revision 1.3.2.1
diff -u -r1.3 -r1.3.2.1
--- elaborate-env.sig	10 Apr 2002 07:02:20 -0000	1.3
+++ elaborate-env.sig	22 Nov 2002 04:49:34 -0000	1.3.2.1
@@ -109,7 +109,7 @@
       val layoutUsed: t -> Layout.t
       val localCore: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
       val localModule: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
-      val localTop: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
+      val localTop: t * (unit -> 'a) -> ('a * ((unit -> 'b) -> 'b))
       val lookupFctid: t * Ast.Fctid.t -> FunctorClosure.t
       val lookupLongcon: t * Ast.Longcon.t -> CoreML.Con.t
       val lookupLongstrid: t * Ast.Longstrid.t -> Structure.t



No                   revision


No                   revision


1.32.2.1  +118 -81   mlton/mlton/main/compile.sml

Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.32
retrieving revision 1.32.2.1
diff -u -r1.32 -r1.32.2.1
--- compile.sml	6 Jul 2002 17:22:07 -0000	1.32
+++ compile.sml	22 Nov 2002 04:49:34 -0000	1.32.2.1
@@ -62,16 +62,26 @@
 val (lexAndParse, lexAndParseMsg) =
    Control.traceBatch (Control.Pass, "lex and parse") FrontEnd.lexAndParse
 
+fun lexAndParseFile (f: File.t): Ast.Program.t =
+   let
+      val ast = lexAndParse f
+      val _ = Control.checkForErrors "parse"
+   in ast
+   end
+
+fun lexAndParseFiles (fs: File.t list): Ast.Program.t =
+   List.fold
+   (fs, Ast.Program.empty, fn (f, ast) =>
+    Ast.Program.append (ast, lexAndParseFile f))
+
 val (elaborate, elaborateMsg) =
    Control.traceBatch (Control.Pass, "elaborate") Elaborate.elaborateProgram
 
-fun parseAndElaborateFile (f: File.t, E): Decs.t =
+fun elaborateProg (ast: Ast.Program.t, E: Env.t): Decs.t =
    let
-      val ast = lexAndParse f
-      val _ = Control.checkForErrors "parse"
-      val res = elaborate (ast, E)
+      val decs = elaborate (ast, E)
       val _ = Control.checkForErrors "elaborate"
-   in res
+   in decs
    end
 
 val displayDecs =
@@ -85,7 +95,8 @@
     suffix = "core-ml",
     style = Control.ML,
     thunk = fn () => List.fold (fs, Decs.empty, fn (f, ds) =>
-				Decs.append (ds, parseAndElaborateFile (f, E))),
+				Decs.append 
+				(ds, elaborateProg (lexAndParseFile f, E))),
     display = displayDecs}
 
 (* ------------------------------------------------- *)   
@@ -147,13 +158,6 @@
 		       let
 			  val resultType =
 			     Type.con (tycon, Vector.map (tyvars, Type.var))
-		       (* 		    val scheme =
-			* 		       Scheme.T
-			* 		       {tyvars = tyvars,
-			* 			ty = (case arg of
-			* 				 NONE => resultType
-			* 			       | SOME t => Type.arrow (t, resultType))}
-			*)
 		       in {name = Con.toAst con,
 			   con = con}
 		       end)
@@ -183,7 +187,12 @@
 in
    fun setBasisLibraryDir (d: Dir.t): unit =
       dir := SOME d
-   val basisLibrary =
+   val basisLibrary : unit -> {build: Decs.t,
+			       localTopFinish: (unit -> Decs.t) -> Decs.t,
+			       libs: {name: string,
+				      bind: Ast.Program.t,
+				      prefix: Ast.Program.t,
+				      suffix: Ast.Program.t} list} =
       Promise.lazy
       (fn () =>
        let
@@ -192,27 +201,44 @@
 		NONE => Error.bug "basis library dir not set"
 	      | SOME d => d
 	  fun basisFile f = String./ (d, f)
-	  fun files (f, E) =
-	     parseAndElaborateFiles
-	     (rev (File.foldLines (basisFile f, [], fn (s, ac) =>
-				   if s <> "\n" andalso #"#" <> String.sub (s, 0)
-				      then basisFile (String.dropLast s) :: ac
-				   else ac)),
-	      basisEnv)
-	  val (d1, (d2, d3)) =
+	  fun libsFile f = basisFile (String./ ("libs", f))
+	  fun withFiles (f, g) =
+	     let
+	        val fs = File.foldLines
+		         (f, [], fn (s, ac) =>
+			  if s <> "\n" andalso #"#" <> String.sub (s, 0)
+			     then basisFile (String.dropLast s) :: ac
+			  else ac)
+	     in
+	        g (List.rev fs)
+	     end
+
+	  val (build, localTopFinish) =
 	     Env.localTop
 	     (basisEnv,
 	      fn () => (Env.addPrim basisEnv
-			; files ("build-basis", basisEnv)),
-	      fn () =>
-	      (files ("bind-basis", basisEnv),
-	       (* Suffix is concatenated onto the end of the program for cleanup. *)
-	       parseAndElaborateFiles ([basisFile "misc/suffix.sml"], basisEnv)))
-	  val _ = Env.addEquals basisEnv
-	  val _ = Env.clean basisEnv
+			; withFiles (libsFile "build", 
+				     fn fs => parseAndElaborateFiles (fs, basisEnv))))
+	  val localTopFinish = fn g =>
+	     (localTopFinish g) before (Env.addEquals basisEnv
+					; Env.clean basisEnv)
+
+	  fun doit name =
+	    let
+	      fun libFile f = libsFile (String./ (name, f))
+	      val bind = withFiles (libFile "bind", lexAndParseFiles)
+	      val prefix = withFiles (libFile "prefix", lexAndParseFiles)
+	      val suffix = withFiles (libFile "suffix", lexAndParseFiles)
+	    in
+	      {name = name,
+	       bind = bind,
+	       prefix = prefix,
+	       suffix = suffix}
+	    end
        in
-	  {prefix = Decs.append (d1, d2),
-	   suffix = d3}
+	  {build = build,
+	   localTopFinish = localTopFinish,
+	   libs = List.map (Control.basisLibs, doit)}
        end)
 end
 
@@ -221,17 +247,37 @@
     ; basisLibrary ()
     ; ())
    
-fun basisDecs () =
+fun buildDecs () =
    let
-      val {prefix, ...} = basisLibrary ()
+      val {build, ...} = basisLibrary ()
    in
-      Decs.toVector prefix
+      Decs.toVector build
    end
    
 fun outputBasisConstants (out: Out.t): unit =
-   LookupConstant.build (basisDecs (), out)
+   LookupConstant.build (buildDecs (), out)
+
+fun selectBasisLibrary () =
+   let
+     val {build, localTopFinish, libs} = basisLibrary ()
+     val lib = !Control.basisLibrary
+   in
+      case List.peek (libs, fn {name, ...} => name = lib) of
+	 NONE => Error.bug ("Missing basis library: " ^ lib)
+       | SOME {bind, prefix, suffix, ...} =>
+	   let
+	     val bind = localTopFinish (fn () => elaborateProg (bind, basisEnv))
+	   in
+	     {basis = Decs.append (build, bind),
+	      prefix = prefix,
+	      suffix = suffix}
+	   end
+   end
 
-fun layoutBasisLibrary () = Env.layoutPretty basisEnv
+fun layoutBasisLibrary () = 
+   let val _ = selectBasisLibrary ()
+   in Env.layoutPretty basisEnv
+   end
 
 (* ------------------------------------------------- *)
 (*                      compile                      *)
@@ -251,50 +297,41 @@
 			    make (Exception {con = c, arg = NONE}))]
 	 end
       val decs =
-	 if !Control.useBasisLibrary
-	    then
-	       let
-		  val {prefix, suffix} = basisLibrary ()
-		  val basis = Decs.toList prefix
-		  val decs =
-		     if !Control.showBasisUsed
-			then
-			   let
-			      val decs = 
-				 Elaborate.Env.scopeAll
-				 (basisEnv, fn () =>
-				  parseAndElaborateFiles (input, basisEnv))
-			      val _ =
-				 Layout.outputl
-				 (Elaborate.Env.layoutUsed basisEnv,
-				  Out.standard)
-			   in
-			      Process.succeed ()
-			   end
-		     else
-			parseAndElaborateFiles (input, basisEnv)
-		  val user = Decs.toList (Decs.append (decs, suffix))
-		  val _ = parseElabMsg ()
-		  val basis =
-		     Control.pass
-		     {name = "dead",
-		      suffix = "basis",
-		      style = Control.ML,
-		      thunk = fn () => DeadCode.deadCode {basis = basis,
-							  user = user},
-		      display = Control.Layout (List.layout CoreML.Dec.layout)}
-	       in Vector.concat [primitiveDecs,
-				 Vector.fromList basis,
-				 Vector.fromList user]
-	       end
-	 else
-	    let
-	       val E = Env.empty ()
-	       val _ = Env.addPrim E
-	       val decs = parseAndElaborateFiles (input, E)
-	       val _ = parseElabMsg ()
-	    in Vector.concat [primitiveDecs, Decs.toVector decs]
-	    end
+	 let 
+	    val {basis, prefix, suffix, ...} = selectBasisLibrary ()
+	    val prefix = elaborateProg (prefix, basisEnv)
+	    val input =
+	       if !Control.showBasisUsed
+		  then let
+			  val input =
+			     Elaborate.Env.scopeAll
+			     (basisEnv, fn () =>
+			      parseAndElaborateFiles (input, basisEnv))
+			  val _ =
+			     Layout.outputl
+			     (Elaborate.Env.layoutUsed basisEnv,
+			      Out.standard)
+		       in
+			 Process.succeed ()
+		       end
+	       else parseAndElaborateFiles (input, basisEnv)
+	    val suffix = elaborateProg (suffix, basisEnv)
+	    val user = Decs.appends [prefix, input, suffix]
+	    val _ = parseElabMsg ()
+	    val basis = Decs.toList basis
+	    val user = Decs.toList user
+	    val basis = 
+	       Control.pass
+	       {name = "deadCode",
+		suffix = "basis",
+		style = Control.ML,
+		thunk = fn () => DeadCode.deadCode {basis = basis,
+						    user = user},
+		display = Control.Layout (List.layout CoreML.Dec.layout)}
+	 in Vector.concat [primitiveDecs,
+			   Vector.fromList basis,
+			   Vector.fromList user]
+	 end
       val coreML = CoreML.Program.T {decs = decs}
       val _ = Control.message (Control.Detail, fn () =>
 			       CoreML.Program.layoutStats coreML)
@@ -318,7 +355,7 @@
       val lookupConstant =
 	 File.withIn
 	 (concat [!Control.libDir, "/constants"], fn ins =>
-	  LookupConstant.load (basisDecs (), ins))
+	  LookupConstant.load (buildDecs (), ins))
       (* Set GC_state offsets. *)
       val _ =
 	 let



1.73.2.1  +10 -5     mlton/mlton/main/main.sml

Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.73
retrieving revision 1.73.2.1
diff -u -r1.73 -r1.73.2.1
--- main.sml	19 Jul 2002 19:23:18 -0000	1.73
+++ main.sml	22 Nov 2002 04:49:34 -0000	1.73.2.1
@@ -87,6 +87,14 @@
       open Control Popt
       fun push r = String (fn s => List.push (r, s))
    in [
+       (Normal, "basis", 
+	" {" ^ (String.concat (List.separate (Control.basisLibs, "|")))  ^ "}",
+	"select basis library to prefix to the program",
+	SpaceString (fn s => 
+		     basisLibrary :=
+		     (if List.contains (Control.basisLibs, s, String.equals)
+			then s
+			else usage (concat ["invalid -basis flag: ", s])))),
        (Expert, "build-constants", "",
 	"output C file that prints basis constants",
 	trueRef buildConstants),
@@ -255,9 +263,6 @@
 	intRef textIOBufSize),
        (Expert, "type-check", " {false|true}", "type check ILs",
 	boolRef typeCheck),
-       (Expert, "use-basis-library", " {true|false}",
-	"prefix the basis library to the program",
-	boolRef useBasisLibrary),
        (Normal, "v", "[0123]", "how verbose to be about compiler passes",
 	String
 	(fn s =>
@@ -363,8 +368,8 @@
 		   then Layout.outputl (Compile.layoutBasisLibrary (),
 					Out.standard)
 		else if !buildConstants
-			then Compile.outputBasisConstants Out.standard
-		     else usage "must supply a file"
+		   then Compile.outputBasisConstants Out.standard
+		else usage "must supply a file"
 	   | _ => 
 		(inputFile := ""
 		 ; outputHeader' (No, Out.standard)))





-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel