[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