[MLton] cvs commit: added -default-ann switch
Matthew Fluet
fluet@mlton.org
Tue, 3 Aug 2004 20:15:12 -0700
fluet 04/08/03 20:15:11
Modified: doc/examples/ffi Makefile
doc/examples/finalizable Makefile
mlton/control control.sig control.sml
mlton/elaborate elaborate-core.fun elaborate-core.sig
elaborate-env.fun elaborate-env.sig
elaborate-mlbs.fun elaborate-mlbs.sig
elaborate-modules.fun elaborate-modules.sig
elaborate-programs.fun elaborate-programs.sig
elaborate.fun elaborate.sig sources.cm
mlton/main compile.fun main.fun
Removed: mlton/elaborate elaborate-controls.fun
elaborate-controls.sig
Log:
MAIL added -default-ann switch
Deprecated the following switches:
-allow-export {false|true}
-allow-import {false|true}
-dead-code {true|false}
-sequence-unit {false|true}
-warn-match {true|false}
-warn-unused {false|true}
and replaced them with a single switch
-default-ann <anns>
so that instead of writing
-allow-export true -sequence-unit true
one would write
-ann 'allowExport true, sequenceUnit true'
Extended -{enable,disable}-ann to accept a comma delimited list of
annotations to enable and disable.
In doing so, migrated Elaborate.Ctrls to Control.Elaborate, which
makes the controls accessible to Main. Also moved all recognizing of
annotation names and options into Control.Elaborate, which will ensure
consistency between MLBs annotations and command line annotations.
Not all annotations are accessible from the command line. In
particuler, the "expert" annotations allowConstant, allowPrim,
allowOverload, allowRebindEquals cannot be defaulted or disabled.
Also, the forceUsed annotation is not accessible from the command line
-- it's not clear what effect defaulting or disabling it should have,
although I may reconsider this choice. Finally, the deadCode
annotation can both be disabled and defaulted from the command-line.
Disabling it gives the behavior of -dead-code false. But, beware:
compiling with -default-ann 'deadCode true' will have serious semantic
consequences. All other annotations are fully accessible from the
command line.
Revision Changes Path
1.12 +1 -1 mlton/doc/examples/ffi/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/Makefile,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- Makefile 31 Jul 2004 02:04:46 -0000 1.11
+++ Makefile 4 Aug 2004 03:15:08 -0000 1.12
@@ -1,6 +1,6 @@
PATH = ../../../build/bin:$(shell echo $$PATH)
-mlton = mlton -allow-export true -allow-import true
+mlton = mlton -default-ann 'allowExport true, allowImport true'
.PHONY: all
all: import export
1.5 +1 -1 mlton/doc/examples/finalizable/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/finalizable/Makefile,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- Makefile 31 Jul 2004 16:12:32 -0000 1.4
+++ Makefile 4 Aug 2004 03:15:09 -0000 1.5
@@ -1,6 +1,6 @@
PATH = ../../../build/bin:$(shell echo $$PATH)
-mlton = mlton -allow-import true
+mlton = mlton -default-ann 'allowImport true'
all:
$(mlton) finalizable.sml cons.c
1.106 +27 -17 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.105
retrieving revision 1.106
diff -u -r1.105 -r1.106
--- control.sig 29 Jul 2004 21:56:55 -0000 1.105
+++ control.sig 4 Aug 2004 03:15:09 -0000 1.106
@@ -21,11 +21,6 @@
datatype align = Align4 | Align8
val align: align ref
- val allowExportAnn : bool ref
- val allowExportDef : bool ref
- val allowImportAnn : bool ref
- val allowImportDef : bool ref
-
val atMLtons: string vector ref
val basisLibs: string list
@@ -52,8 +47,6 @@
val contifyIntoMain: bool ref
- val deadCodeAnn: bool ref
-
(* Generate an executable with debugging info. *)
val debug: bool ref
@@ -68,6 +61,33 @@
(* List of optimization passes to skip. *)
val dropPasses: Regexp.Compiled.t list ref
+ structure Elaborate :
+ sig
+ type 'a t
+
+ val allowConstant: bool t
+ val allowExport: bool t
+ val allowImport: bool t
+ val allowOverload: bool t
+ val allowPrim: bool t
+ val allowRebindEquals: bool t
+ val deadCode: bool t
+ val forceUsed: int t
+ (* in (e1; e2), require e1: unit. *)
+ val sequenceUnit: bool t
+ val warnMatch: bool t
+ val warnUnused: bool t
+
+ val current: 'a t -> 'a
+ val default: 'a t -> 'a ref
+ val enabled: 'a t -> bool ref
+
+ val withDef: (unit -> 'a) -> 'a
+ val withAnn: string list -> (unit -> unit) option
+ val setDef: string list -> bool
+ val setAble: bool * string -> bool
+ end
+
(* stop after elaboration. So, no need for the elaborator to generate
* valid CoreML.
*)
@@ -234,10 +254,6 @@
(* Array bounds checking. *)
val safe: bool ref
- (* in (e1; e2), require e1: unit. *)
- val sequenceUnitAnn: bool ref
- val sequenceUnitDef: bool ref
-
(* Show the basis library. *)
val showBasis: File.t option ref
@@ -296,12 +312,6 @@
val version: string
val warnAnn: bool ref
-
- val warnMatchAnn: bool ref
- val warnMatchDef: bool ref
-
- val warnUnusedAnn: bool ref
- val warnUnusedDef: bool ref
(* XML Passes *)
val xmlPassesSet: (string -> string list Result.t) ref
1.132 +186 -40 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.131
retrieving revision 1.132
diff -u -r1.131 -r1.132
--- control.sml 29 Jul 2004 21:56:55 -0000 1.131
+++ control.sml 4 Aug 2004 03:15:09 -0000 1.132
@@ -26,20 +26,6 @@
default = Align4,
toString = Align.toString}
-val allowExportAnn = control {name = "allow _export (annotation)",
- default = true,
- toString = Bool.toString}
-val allowExportDef = control {name = "allow _export",
- default = false,
- toString = Bool.toString}
-val allowImportAnn = control {name = "allow _import (annotation)",
- default = true,
- toString = Bool.toString}
-val allowImportDef = control {name = "allow _import",
- default = false,
- toString = Bool.toString}
-
-
val atMLtons = control {name = "atMLtons",
default = Vector.new0 (),
toString = fn v => Layout.toString (Vector.layout
@@ -97,10 +83,6 @@
default = false,
toString = Bool.toString}
-val deadCodeAnn = control {name = "dead code (annotation)",
- default = true,
- toString = Bool.toString}
-
val debug = control {name = "debug",
default = false,
toString = Bool.toString}
@@ -127,6 +109,191 @@
(Layout.toString o
Regexp.Compiled.layout)}
+structure Elaborate =
+ struct
+ datatype 'a t = T of {cur: 'a ref,
+ def: 'a ref,
+ enabled: bool ref}
+ fun current (T {cur, ...}) = !cur
+ fun default (T {def, ...}) = def
+ fun enabled (T {enabled, ...}) = enabled
+
+ local
+ fun make {name: string,
+ default: 'a,
+ toString: 'a -> string,
+ expert: bool,
+ options: string list -> 'b option,
+ newCur: 'a * 'b -> 'a,
+ newDef: 'a * 'b -> 'a,
+ withDef: unit -> (unit -> unit),
+ withAnn: string list -> (unit -> unit) option,
+ setDef: string list -> bool,
+ setAble: bool * string -> bool} =
+ let
+ val ctrl as T {cur, def, enabled} =
+ T {cur = ref default,
+ def = control {name = concat ["elaborate ",name,
+ " (default)"],
+ default = default,
+ toString = toString},
+ enabled = control {name = concat ["elaborate ",name,
+ " (enabled)"],
+ default = true,
+ toString = Bool.toString}}
+ val withDef : unit -> (unit -> unit) =
+ fn () =>
+ let
+ val restore = withDef ()
+ val old = !cur
+ in
+ cur := !def
+ ; fn () => (cur := old
+ ; restore ())
+ end
+ val withAnn : string list -> (unit -> unit) option =
+ fn ss' =>
+ case ss' of
+ s::ss =>
+ if String.equals(s, name)
+ then
+ case options ss of
+ SOME v =>
+ if !enabled
+ then let
+ val old = !cur
+ val new = newCur (old, v)
+ in
+ cur := new
+ ; SOME (fn () => cur := old)
+ end
+ else SOME (fn () => ())
+ | NONE => NONE
+ else withAnn ss'
+ | _ => NONE
+ val setDef : string list -> bool =
+ if expert
+ then setDef
+ else
+ fn ss' =>
+ case ss' of
+ s::ss => if String.equals(s, name)
+ then
+ case options ss of
+ SOME v =>
+ let
+ val old = !def
+ val new = newDef (old, v)
+ in
+ def := new
+ ; true
+ end
+ | NONE => false
+ else setDef ss'
+ | _ => false
+ val setAble : bool * string -> bool =
+ if expert
+ then setAble
+ else
+ fn (b, s) =>
+ if String.equals(s, name)
+ then (enabled := b; true)
+ else setAble (b, s)
+ in
+ {ctrl = ctrl,
+ withDef = withDef,
+ withAnn = withAnn,
+ setDef = setDef,
+ setAble = setAble}
+ end
+
+ fun makeBool {name, default, expert,
+ withDef: unit -> (unit -> unit),
+ withAnn: string list -> (unit -> unit) option,
+ setDef: string list -> bool,
+ setAble: bool * string -> bool} =
+ make {name = name,
+ default = default,
+ toString = Bool.toString,
+ expert = expert,
+ options = fn ss =>
+ case ss of
+ [s] => Bool.fromString s
+ | _ => NONE,
+ newCur = fn (_,b) => b,
+ newDef = fn (_,b) => b,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ in
+ val {withDef, withAnn, setDef, setAble} =
+ {withDef = fn () => (fn () => ()),
+ withAnn = fn _ => NONE,
+ setDef = fn _ => false,
+ setAble = fn _ => false}
+ val {ctrl = allowConstant, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "allowConstant", default = false, expert = true,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = allowExport, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "allowExport", default = false, expert = false,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = allowImport, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "allowImport", default = false, expert = false,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = allowPrim, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "allowPrim", default = false, expert = true,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = allowOverload, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "allowOverload", default = false, expert = true,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = allowRebindEquals, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "allowRebindEquals", default = false, expert = true,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = deadCode, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "deadCode", default = false, expert = false,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = forceUsed, withDef, withAnn, setDef, setAble} =
+ make {name = "forceUsed",
+ default = 0,
+ toString = Int.toString,
+ expert = true,
+ options = fn ss =>
+ case ss of
+ [] => SOME ()
+ | _ => NONE,
+ newCur = fn (i,()) => i + 1,
+ newDef = fn (_,()) => 0,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = sequenceUnit, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "sequenceUnit", default = false, expert = false,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = warnMatch, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "warnMatch", default = true, expert = false,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ val {ctrl = warnUnused, withDef, withAnn, setDef, setAble} =
+ makeBool {name = "warnUnused", default = false, expert = false,
+ withDef = withDef, withAnn = withAnn,
+ setDef = setDef, setAble = setAble}
+ end
+
+ val withDef : (unit -> 'a) -> 'a = fn f =>
+ let val restore = withDef ()
+ in DynamicWind.wind (f, restore)
+ end
+ val withAnn = withAnn
+ val setDef = setDef
+ val setAble = setAble
+ end
+
val elaborateOnly =
control {name = "elaborate only",
default = false,
@@ -447,13 +614,6 @@
default = true,
toString = Bool.toString}
-val sequenceUnitAnn = control {name = "sequence unit (annotation)",
- default = true,
- toString = Bool.toString}
-val sequenceUnitDef = control {name = "sequence unit (default)",
- default = false,
- toString = Bool.toString}
-
val showBasis = control {name = "show basis",
default = NONE,
toString = Option.toString File.toString}
@@ -584,23 +744,9 @@
val version = "MLton MLTONVERSION"
-val warnAnn = control {name = "warn annotation",
+val warnAnn = control {name = "warn unrecognized annotation",
default = true,
toString = Bool.toString}
-
-val warnMatchAnn = control {name = "warn match (annotation)",
- default = true,
- toString = Bool.toString}
-val warnMatchDef = control {name = "warn match (default)",
- default = true,
- toString = Bool.toString}
-
-val warnUnusedAnn = control {name = "warn unused (annotation)",
- default = true,
- toString = Bool.toString}
-val warnUnusedDef = control {name = "warn unused (default)",
- default = false,
- toString = Bool.toString}
val xmlPassesSet: (string -> string list Result.t) ref =
control {name = "xmlPassesSet",
1.112 +32 -16 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.111
retrieving revision 1.112
diff -u -r1.111 -r1.112
--- elaborate-core.fun 28 Jul 2004 21:05:12 -0000 1.111
+++ elaborate-core.fun 4 Aug 2004 03:15:09 -0000 1.112
@@ -11,6 +11,22 @@
open S
local
+ open Control.Elaborate
+in
+ val allowConstant = fn () => current allowConstant
+ val allowExport = fn () => current allowExport
+ val allowImport = fn () => current allowImport
+ val allowPrim = fn () => current allowPrim
+ val allowOverload = fn () => current allowOverload
+ val allowRebindEquals = fn () => current allowRebindEquals
+ val sequenceUnit = fn () => current sequenceUnit
+ val warnMatch = fn () => current warnMatch
+ val warnUnused = fn () => current warnUnused
+end
+val lookupConstant : (string * ConstType.t -> CoreML.Const.t) ref =
+ ref (fn _ => Error.bug "lookupConstant not set")
+
+local
open Ast
in
structure Acon = Con
@@ -323,7 +339,7 @@
val eq = Avar.fromSymbol (Symbol.equal, Region.bogus)
in
fun ensureNotEquals x =
- if not (!Ctrls.allowRebindEquals) andalso Avar.equals (x, eq)
+ if not (allowRebindEquals ()) andalso Avar.equals (x, eq)
then
let
open Layout
@@ -1502,7 +1518,7 @@
Cexp.tuple
(Vector.map2
(xs, argTypes, Cexp.var)),
- warnMatch = !Ctrls.warnMatch}
+ warnMatch = warnMatch ()}
in
Cexp.enterLeave (e, sourceInfo)
end
@@ -1580,7 +1596,7 @@
Decs.empty
end
| Adec.Overload (p, x, tyvars, ty, xs) =>
- (if not (!Ctrls.allowOverload)
+ (if not (allowOverload ())
then let open Layout
in Control.error (region, str "_overload disallowed", empty)
end
@@ -1731,7 +1747,7 @@
region = region,
rules = rules,
test = Cexp.var (arg, argType),
- warnMatch = !Ctrls.warnMatch},
+ warnMatch = warnMatch ()},
fn () => SourceInfo.function {name = nest,
region = region})
val lambda =
@@ -1810,7 +1826,7 @@
Decs.single (Cdec.Val {rvbs = rvbs,
tyvars = bound,
vbs = vbs,
- warnMatch = !Ctrls.warnMatch})
+ warnMatch = warnMatch ()})
end
end) arg
and elabExp (arg: Aexp.t * Nest.t * string option): Cexp.t =
@@ -1892,7 +1908,7 @@
region = region,
rules = rules,
test = e,
- warnMatch = !Ctrls.warnMatch}
+ warnMatch = warnMatch ()}
end
| Aexp.Const c =>
elabConst
@@ -2118,7 +2134,7 @@
(Cpat.tuple
(Vector.map (vars, Cpat.var)))},
test = Cexp.var (arg, argType),
- warnMatch = !Ctrls.warnMatch}
+ warnMatch = warnMatch ()}
end
in
Cexp.make (Cexp.Lambda
@@ -2168,7 +2184,7 @@
else
bug ()
val finish =
- let val lookupConstant = !Ctrls.lookupConstant
+ let val lookupConstant = !lookupConstant
in fn () => lookupConstant (name, ct)
end
in
@@ -2179,17 +2195,17 @@
in
case kind of
BuildConst =>
- (if not (!Ctrls.allowConstant)
+ (if not (allowConstant ())
then disallowed "_build_const"
else ()
; lookConst name)
| Const =>
- (if not (!Ctrls.allowConstant)
+ (if not (allowConstant ())
then disallowed "_const"
else ()
; lookConst name)
| Export attributes =>
- (if not (!Ctrls.allowExport)
+ (if not (allowExport ())
then disallowed "_export"
else ()
; let
@@ -2221,7 +2237,7 @@
wrap (e, Type.arrow (ty, Type.unit))
end)
| Import attributes =>
- (if not (!Ctrls.allowImport)
+ (if not (allowImport ())
then disallowed "_import"
else ()
; eta (import {attributes = attributes,
@@ -2229,7 +2245,7 @@
region = region,
ty = expandedTy}))
| Prim =>
- (if not (!Ctrls.allowPrim)
+ (if not (allowPrim ())
then disallowed "_prim"
else ()
; eta (Prim.fromString name))
@@ -2268,7 +2284,7 @@
* unit.
*)
val _ =
- if not (!Ctrls.sequenceUnit)
+ if not (sequenceUnit ())
then ()
else
Vector.foreachi
@@ -2354,7 +2370,7 @@
val expr = elab expr
(* Error if expr is not of type unit. *)
val _ =
- if not (!Ctrls.sequenceUnit)
+ if not (sequenceUnit ())
then ()
else
unify (Cexp.ty expr, Type.unit, fn (l, _) =>
@@ -2376,7 +2392,7 @@
region = region,
rules = rules,
test = Cexp.var (arg, argType),
- warnMatch = !Ctrls.warnMatch}
+ warnMatch = warnMatch ()}
in
{arg = arg,
argType = argType,
1.10 +3 -4 mlton/mlton/elaborate/elaborate-core.sig
Index: elaborate-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- elaborate-core.sig 28 Jul 2004 21:05:12 -0000 1.9
+++ elaborate-core.sig 4 Aug 2004 03:15:09 -0000 1.10
@@ -12,13 +12,11 @@
structure Ast: AST
structure ConstType: CONST_TYPE
structure CoreML: CORE_ML
- structure Ctrls: ELABORATE_CONTROLS
structure Decs: DECS
structure Env: ELABORATE_ENV
- sharing Ast = Ctrls.Ast = Env.Ast
+ sharing Ast = Env.Ast
sharing Ast.Tyvar = CoreML.Tyvar
- sharing ConstType = Ctrls.ConstType
- sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+ sharing CoreML = Decs.CoreML = Env.CoreML
sharing Decs = Env.Decs
end
@@ -30,5 +28,6 @@
val elaborateDec:
Ast.Dec.t * {env: Env.t, nest: string list}
-> Decs.t
+ val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
val reportUndeterminedTypes: unit -> unit
end
1.97 +10 -3 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.96
retrieving revision 1.97
diff -u -r1.96 -r1.97
--- elaborate-env.fun 28 Jul 2004 21:05:12 -0000 1.96
+++ elaborate-env.fun 4 Aug 2004 03:15:09 -0000 1.97
@@ -13,6 +13,13 @@
type int = Int.t
local
+ open Control.Elaborate
+in
+ val warnMatch = fn () => current warnMatch
+ val warnUnused = fn () => current warnUnused
+end
+
+local
open Ast
in
structure Basid = Basid
@@ -1656,7 +1663,7 @@
val uses = NameSpace.newUses (vals, Class.Con,
Ast.Vid.fromCon name)
val () =
- if not (!Ctrls.warnUnused) orelse forceUsed
+ if not (warnUnused ()) orelse forceUsed
then Uses.forceUsed uses
else ()
in
@@ -1879,7 +1886,7 @@
let
val u = NameSpace.newUses (ns, class range, domain)
val () =
- if not (!Ctrls.warnUnused) orelse forceUsed
+ if not (warnUnused ()) orelse forceUsed
then Uses.forceUsed u
else ()
in
@@ -2734,7 +2741,7 @@
lay = fn _ => Layout.empty,
pat = Pat.var (x, strType),
patRegion = region}),
- warnMatch = !Ctrls.warnMatch})
+ warnMatch = warnMatch ()})
in
Vid.Var x
end
1.34 +0 -3 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- elaborate-env.sig 28 Jul 2004 21:05:12 -0000 1.33
+++ elaborate-env.sig 4 Aug 2004 03:15:09 -0000 1.34
@@ -9,13 +9,10 @@
sig
structure Ast: AST
structure CoreML: CORE_ML
- structure Ctrls: ELABORATE_CONTROLS
structure TypeEnv: TYPE_ENV
- sharing Ast = Ctrls.Ast
sharing Ast.Record = CoreML.Record
sharing Ast.SortedRecord = CoreML.SortedRecord
sharing Ast.Tyvar = CoreML.Tyvar
- sharing CoreML = Ctrls.CoreML
sharing CoreML.Atoms = TypeEnv.Atoms
sharing CoreML.Type = TypeEnv.Type
end
1.2 +43 -8 mlton/mlton/elaborate/elaborate-mlbs.fun
Index: elaborate-mlbs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-mlbs.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-mlbs.fun 28 Jul 2004 21:05:13 -0000 1.1
+++ elaborate-mlbs.fun 4 Aug 2004 03:15:09 -0000 1.2
@@ -11,6 +11,41 @@
open S
local
+ open Control.Elaborate
+in
+ val withDef = withDef
+ fun withAnns (anns, f) =
+ let
+ val restore =
+ List.fold
+ (anns, fn () => (), fn ((ann,reg), restore) =>
+ let
+ fun warn () =
+ if !Control.warnAnn
+ then let open Layout
+ in
+ Control.warning
+ (reg,
+ seq [str "unrecognized annotation: ",
+ (seq o separate) (List.map (ann, str), " ")],
+ empty)
+ end
+ else ()
+ in
+ case withAnn ann of
+ SOME restore' => restore o restore'
+ | NONE => (warn (); restore)
+ end)
+ in
+ DynamicWind.wind (f, restore)
+ end
+
+ val allowPrim = fn () => current allowPrim
+ val deadCode = fn () => current deadCode
+ val forceUsed = fn () => current forceUsed
+end
+
+local
open Ast
in
structure Basid = Basid
@@ -28,9 +63,9 @@
structure ElaboratePrograms = ElaboratePrograms (structure Ast = Ast
structure ConstType = ConstType
structure CoreML = CoreML
- structure Ctrls = Ctrls
structure Decs = Decs
structure Env = Env)
+val lookupConstant = ElaboratePrograms.lookupConstant
local
open ElaboratePrograms
@@ -48,7 +83,7 @@
val emptySnapshot : (unit -> Env.Basis.t) -> Env.Basis.t =
Env.snapshot E
val emptySnapshot = fn f =>
- emptySnapshot (fn () => Ctrls.withDefault f)
+ emptySnapshot (fn () => withDef f)
val primBasis =
emptySnapshot
@@ -136,7 +171,7 @@
(Vector.map (basids, fn basid => Env.lookupBasid (E, basid)),
fn bo => Option.app (bo, fn b => Env.openBasis (E, b)))
| Basdec.Prog (_, prog) =>
- Buffer.add (decs, (elabProg prog, !Ctrls.deadCode))
+ Buffer.add (decs, (elabProg prog, deadCode ()))
| Basdec.MLB (_, fid, basdec) =>
let
val fid = valOf fid
@@ -157,7 +192,7 @@
Env.openBasis (E, B)
end
| Basdec.Prim =>
- (if not (!Ctrls.allowPrim)
+ (if not (allowPrim ())
then let open Layout
in Control.error (Basdec.region basdec, str "_prim disallowed", empty)
end
@@ -165,16 +200,16 @@
; Env.openBasis (E, primBasis))
| Basdec.Ann (anns, basdec) =>
let
- val old = !Ctrls.forceUsed
+ val old = forceUsed ()
in
- Ctrls.withAnns
+ withAnns
(anns, fn () =>
(elabBasdec basdec
- ; if !Ctrls.forceUsed <> old
+ ; if forceUsed () <> old
then Env.forceUsed E
else ()))
end) basdec
- val _ = Ctrls.withDefault (fn () => elabBasdec mlb)
+ val _ = withDef (fn () => elabBasdec mlb)
in
(E, Buffer.toVector decs)
end
1.2 +4 -5 mlton/mlton/elaborate/elaborate-mlbs.sig
Index: elaborate-mlbs.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-mlbs.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-mlbs.sig 28 Jul 2004 21:05:13 -0000 1.1
+++ elaborate-mlbs.sig 4 Aug 2004 03:15:09 -0000 1.2
@@ -10,13 +10,11 @@
structure Ast: AST
structure ConstType: CONST_TYPE
structure CoreML: CORE_ML
- structure Ctrls: ELABORATE_CONTROLS
structure Decs: DECS
structure Env: ELABORATE_ENV
- sharing Ast = Ctrls.Ast = Env.Ast
+ sharing Ast = Env.Ast
sharing Ast.Tyvar = CoreML.Tyvar
- sharing ConstType = Ctrls.ConstType
- sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+ sharing CoreML = Decs.CoreML = Env.CoreML
sharing Decs = Env.Decs
end
@@ -26,4 +24,5 @@
val elaborateMLB:
Ast.Basdec.t * {addPrim: Env.t -> Decs.t} -> Env.t * (Decs.t * bool) vector
- end
+ val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
+ end
1.2 +1 -1 mlton/mlton/elaborate/elaborate-modules.fun
Index: elaborate-modules.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-modules.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-modules.fun 28 Jul 2004 21:05:13 -0000 1.1
+++ elaborate-modules.fun 4 Aug 2004 03:15:09 -0000 1.2
@@ -39,9 +39,9 @@
structure ElaborateCore = ElaborateCore (structure Ast = Ast
structure ConstType = ConstType
structure CoreML = CoreML
- structure Ctrls = Ctrls
structure Decs = Decs
structure Env = Env)
+val lookupConstant = ElaborateCore.lookupConstant
val elabStrdecInfo = Trace.info "elabStrdec"
val elabTopdecInfo = Trace.info "elabTopdec"
1.2 +3 -4 mlton/mlton/elaborate/elaborate-modules.sig
Index: elaborate-modules.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-modules.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-modules.sig 28 Jul 2004 21:05:13 -0000 1.1
+++ elaborate-modules.sig 4 Aug 2004 03:15:09 -0000 1.2
@@ -10,13 +10,11 @@
structure Ast: AST
structure ConstType: CONST_TYPE
structure CoreML: CORE_ML
- structure Ctrls: ELABORATE_CONTROLS
structure Decs: DECS
structure Env: ELABORATE_ENV
- sharing Ast = Ctrls.Ast = Env.Ast
+ sharing Ast = Env.Ast
sharing Ast.Tyvar = CoreML.Tyvar
- sharing ConstType = Ctrls.ConstType
- sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+ sharing CoreML = Decs.CoreML = Env.CoreML
sharing Decs = Env.Decs
end
@@ -26,4 +24,5 @@
val elaborateTopdec:
Ast.Topdec.t * {env: Env.t} -> Decs.t
+ val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
end
1.2 +1 -1 mlton/mlton/elaborate/elaborate-programs.fun
Index: elaborate-programs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-programs.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-programs.fun 28 Jul 2004 21:05:13 -0000 1.1
+++ elaborate-programs.fun 4 Aug 2004 03:15:09 -0000 1.2
@@ -13,9 +13,9 @@
structure ElaborateModules = ElaborateModules (structure Ast = Ast
structure ConstType = ConstType
structure CoreML = CoreML
- structure Ctrls = Ctrls
structure Decs = Decs
structure Env = Env)
+val lookupConstant = ElaborateModules.lookupConstant
fun elaborateProgram (program, {env = E: Env.t}) =
let
1.2 +3 -4 mlton/mlton/elaborate/elaborate-programs.sig
Index: elaborate-programs.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-programs.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- elaborate-programs.sig 28 Jul 2004 21:05:13 -0000 1.1
+++ elaborate-programs.sig 4 Aug 2004 03:15:09 -0000 1.2
@@ -10,13 +10,11 @@
structure Ast: AST
structure ConstType: CONST_TYPE
structure CoreML: CORE_ML
- structure Ctrls: ELABORATE_CONTROLS
structure Decs: DECS
structure Env: ELABORATE_ENV
- sharing Ast = Ctrls.Ast = Env.Ast
+ sharing Ast = Env.Ast
sharing Ast.Tyvar = CoreML.Tyvar
- sharing ConstType = Ctrls.ConstType
- sharing CoreML = Ctrls.CoreML = Decs.CoreML = Env.CoreML
+ sharing CoreML = Decs.CoreML = Env.CoreML
sharing Decs = Env.Decs
end
@@ -26,4 +24,5 @@
val elaborateProgram:
Ast.Program.t * {env: Env.t} -> Decs.t
+ val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
end
1.28 +0 -6 mlton/mlton/elaborate/elaborate.fun
Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- elaborate.fun 28 Jul 2004 21:05:13 -0000 1.27
+++ elaborate.fun 4 Aug 2004 03:15:09 -0000 1.28
@@ -21,13 +21,8 @@
| Word => "Word"
end
-structure Ctrls = ElaborateControls(structure Ast = Ast
- structure ConstType = ConstType
- structure CoreML = CoreML)
-
structure Env = ElaborateEnv (structure Ast = Ast
structure CoreML = CoreML
- structure Ctrls = Ctrls
structure TypeEnv = TypeEnv)
local
@@ -39,7 +34,6 @@
structure ElaborateMLBs = ElaborateMLBs (structure Ast = Ast
structure ConstType = ConstType
structure CoreML = CoreML
- structure Ctrls = Ctrls
structure Decs = Decs
structure Env = Env)
1.10 +2 -2 mlton/mlton/elaborate/elaborate.sig
Index: elaborate.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- elaborate.sig 28 Jul 2004 21:05:13 -0000 1.9
+++ elaborate.sig 4 Aug 2004 03:15:09 -0000 1.10
@@ -22,10 +22,10 @@
include ELABORATE_STRUCTS
structure ConstType: CONST_TYPE
- structure Ctrls: ELABORATE_CONTROLS
structure Decs: DECS
structure Env: ELABORATE_ENV
val elaborateMLB:
Ast.Basdec.t * {addPrim: Env.t -> Decs.t} -> Env.t * (Decs.t * bool) vector
- end
+ val lookupConstant: (string * ConstType.t -> CoreML.Const.t) ref
+ end
1.9 +0 -2 mlton/mlton/elaborate/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- sources.cm 28 Jul 2004 21:05:13 -0000 1.8
+++ sources.cm 4 Aug 2004 03:15:09 -0000 1.9
@@ -27,8 +27,6 @@
type-env.fun
interface.sig
interface.fun
-elaborate-controls.sig
-elaborate-controls.fun
elaborate-env.sig
elaborate-env.fun
precedence-parse.sig
1.39 +1 -1 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- compile.fun 3 Aug 2004 01:00:59 -0000 1.38
+++ compile.fun 4 Aug 2004 03:15:10 -0000 1.39
@@ -331,7 +331,7 @@
style = Control.ML,
thunk = fn () =>
Ref.fluidLet
- (Elaborate.Ctrls.lookupConstant, lookupConstant, fn () =>
+ (Elaborate.lookupConstant, lookupConstant, fn () =>
elaborateMLB (lexAndParseMLB fs, {addPrim = addPrim})),
display = displayEnvDecs}
1.52 +40 -26 mlton/mlton/main/main.fun
Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- main.fun 30 Jul 2004 13:37:59 -0000 1.51
+++ main.fun 4 Aug 2004 03:15:11 -0000 1.52
@@ -127,10 +127,14 @@
s]))))),
(Expert, "allow-export", " {false|true}",
"allow _export expression in program",
- boolRef allowExportDef),
+ Bool (fn b =>
+ (warnDeprecated "allow-export"
+ ; (Control.Elaborate.default Control.Elaborate.allowExport) := b))),
(Expert, "allow-import", " {false|true}",
"allow _import expression in program",
- boolRef allowImportDef),
+ Bool (fn b =>
+ (warnDeprecated "allow-import"
+ ; (Control.Elaborate.default Control.Elaborate.allowImport) := b))),
(Expert, "basis", " {2002|1997|...}",
"select Basis Library revision to prefix to the program",
SpaceString (fn s =>
@@ -171,9 +175,17 @@
"annotated dead code elimination",
Bool (fn b =>
(warnDeprecated "dead-code"
- ; deadCodeAnn := b))),
+ ; (Control.Elaborate.enabled Control.Elaborate.deadCode) := b))),
(Expert, "debug", " {false|true}", "produce executable with debug info",
boolRef debug),
+ (Expert, "default-ann", " <ann>", "annotation default",
+ SpaceString
+ (fn s =>
+ List.foreach
+ (String.tokens (s, fn #"," => true | _ => false), fn s =>
+ if Control.Elaborate.setDef (String.tokens (s, fn #" " => true | _ => false))
+ then ()
+ else usage (concat ["invalid -default-ann flag: ", s])))),
(Normal, "detect-overflow", " {true|false}",
"overflow checking on integer arithmetic",
boolRef detectOverflow),
@@ -190,14 +202,12 @@
(Expert, "disable-ann", " <ann>", "globally disable annotation",
SpaceString
(fn s =>
- (case s of
- "allowExport" => allowExportAnn := false
- | "allowImport" => allowImportAnn := false
- | "deadCode" => deadCodeAnn := false
- | "sequenceUnit" => sequenceUnitAnn := false
- | "warnMatch" => warnMatchAnn := false
- | "warnUnused" => warnUnusedAnn := false
- | _ => usage (concat ["invalid -disable-ann flag: ", s])))),
+ List.foreach
+ (String.tokens (s, fn #"," => true | _ => false), fn s =>
+ if Control.Elaborate.setAble
+ (false, String.deleteSurroundingWhitespace s)
+ then ()
+ else usage (concat ["invalid -disable-ann flag: ", s])))),
(Expert, "drop-pass", " <pass>", "omit optimization pass",
SpaceString
(fn s => (case Regexp.fromString s of
@@ -211,14 +221,12 @@
(Expert, "enable-ann", " <ann>", "globally enable annotation",
SpaceString
(fn s =>
- (case s of
- "allowExport" => allowExportAnn := true
- | "allowImport" => allowImportAnn := true
- | "deadCode" => deadCodeAnn := true
- | "sequenceUnit" => sequenceUnitAnn := true
- | "warnMatch" => warnMatchAnn := true
- | "warnUnused" => warnUnusedAnn := true
- | _ => usage (concat ["invalid -enable-ann flag: ", s])))),
+ List.foreach
+ (String.tokens (s, fn #"," => true | _ => false), fn s =>
+ if Control.Elaborate.setAble
+ (true, String.deleteSurroundingWhitespace s)
+ then ()
+ else usage (concat ["invalid -enable-ann flag: ", s])))),
(Expert, "error-threshhold", " 20", "error threshhold",
intRef errorThreshhold),
(Normal, "exn-history", " {false|true}", "enable Exn.history",
@@ -385,7 +393,9 @@
boolRef safe),
(Normal, "sequence-unit", " {false|true}",
"in (e1; e2), require e1: unit",
- boolRef sequenceUnitDef),
+ Bool (fn b =>
+ (warnDeprecated "sequence-unit"
+ ; (Control.Elaborate.default Control.Elaborate.sequenceUnit) := b))),
(Normal, "show-basis", " <file>", "write out the final basis environment",
SpaceString (fn s => showBasis := SOME s)),
(Normal, "show-def-use", " <file>", "write def-use information",
@@ -461,10 +471,14 @@
boolRef warnAnn),
(Normal, "warn-match", " {true|false}",
"nonexhaustive and redundant match warnings",
- boolRef warnMatchDef),
+ Bool (fn b =>
+ (warnDeprecated "warn-match"
+ ; (Control.Elaborate.default Control.Elaborate.warnMatch) := b))),
(Normal, "warn-unused", " {false|true}",
"unused identifier warnings",
- boolRef warnUnusedDef),
+ Bool (fn b =>
+ (warnDeprecated "warn-unused"
+ ; (Control.Elaborate.default Control.Elaborate.warnUnused) := b))),
(Expert, "xml-passes", " <passes>", "xml optimization passes",
SpaceString
(fn s =>
@@ -590,11 +604,11 @@
else ()
val keepDefUse =
isSome (!showDefUse)
- orelse !warnUnusedAnn
- orelse !warnUnusedDef
+ orelse !(Control.Elaborate.enabled Control.Elaborate.warnUnused)
+ orelse !(Control.Elaborate.default Control.Elaborate.warnUnused)
val warnMatch =
- !warnMatchAnn
- orelse !warnMatchDef
+ !(Control.Elaborate.enabled Control.Elaborate.warnMatch)
+ orelse !(Control.Elaborate.default Control.Elaborate.warnMatch)
val _ = elaborateOnly := (stop = Place.TypeCheck
andalso not (warnMatch)
andalso not (keepDefUse))