[MLton-devel] cvs commit: new front end
Stephen Weeks
sweeks@users.sourceforge.net
Thu, 09 Oct 2003 11:17:35 -0700
sweeks 03/10/09 11:17:35
Modified: basis-library/io fast-imperative-io.fun stream-io.fun
basis-library/libs/basis-2002/top-level top-level.sml
basis-library/misc primitive.sml
basis-library/text string-cvt.sml
benchmark benchmark.cm
benchmark/tests model-elimination.sml
mlton mlton-stubs.cm
mlton/ast ast-atoms.fun ast-atoms.sig ast-const.fun
ast-const.sig ast-core.fun ast-core.sig ast.fun
ast.sig prim-cons.fun prim-tycons.fun
prim-tycons.sig sources.cm tyvar.fun
mlton/atoms atoms.fun atoms.sig c-type.sig const.fun
const.sig hash-type.fun hash-type.sig id.fun id.sig
int-x.fun prim.fun prim.sig sources.cm tycon.fun
tycon.sig type-ops.fun type-ops.sig type.fun
type.sig var.fun var.sig
mlton/backend representation.fun ssa-to-rssa.fun
mlton/closure-convert abstract-value.fun abstract-value.sig
closure-convert.fun
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86.fun
mlton/control control.sml source-pos.sml sources.cm
mlton/core-ml core-ml.fun core-ml.sig sources.cm
mlton/elaborate decs.fun decs.sig elaborate-core.fun
elaborate-core.sig elaborate-env.fun
elaborate-env.sig elaborate.fun elaborate.sig
scope.fun sources.cm
mlton/front-end ml.grm
mlton/main compile.sig main.sig main.sml sources.cm
mlton/ssa constant-propagation.fun direct-exp.fun
flatten.fun local-flatten.fun local-ref.fun
shrink.fun simplify-types.fun ssa-tree.fun
type-check.fun useless.fun
mlton/xml implement-exceptions.fun monomorphise.fun
polyvariance.fun scc-funs.fun shrink.fun
simplify-types.fun type-check.fun xml-tree.fun
xml-tree.sig
regression .cvsignore 6.sml asterisk.sml exnHistory.ok
exnHistory2.ok exnHistory3.ok flexrecord.sml
undetermined.sml valrec.ok valrec.sml
runtime libmlton.c
Added: mlton/ast tycon-kind.fun tycon-kind.sig
mlton/atoms con.fun con.sig
mlton/control layout.sml pretty.sig pretty.sml
mlton/defunctorize defunctorize.fun defunctorize.sig
sources.cm
mlton/elaborate const-type.sig type-env.fun type-env.sig
mlton/main compile.fun lookup-constant.fun
lookup-constant.sig main.fun
mlton/match-compile match-compile.fun match-compile.sig
nested-pat.fun nested-pat.sig sources.cm
Removed: mlton/atoms cons.fun cons.sig
mlton/core-ml lookup-constant.fun lookup-constant.sig
mlton/main compile.sml
mlton/type-inference infer.fun infer.sig match-compile.fun
match-compile.sig nested-pat.fun nested-pat.sig
sources.cm type-env.fun type-env.sig
Log:
This checkin is the next phase in getting a proper front end for
MLton. It does type checking of core SML programs correctly. It
still does type checking after defunctorization and ignores types in
signature. That will be fixed in the next phase.
I am pleased to report that the front end is quite fast. For example,
it can lex, parse, and type check all of MLton (118K lines) in under
10 seconds on my 1.6GHz machine.
I am very interested in receiving bug reports and suggestions on how
to improve the front end. In decreasing order of importance, I would
like to hear about:
1. Programs that are rejected but should be accepted.
2. Programs that are accepted but should be rejected.
3. Confusing type error messages.
4. Improvements to type error messages.
I would appreciate everyone starting to test this front end while
developing SML code. If building MLton from the CVS is an impediment
to doing this, let me know and I will make an experimental release.
There is one kind of problem that I am aware of that will not be fixed
until the module-level checking is there. MLton will now reject some
valid SML programs like the following.
structure S:
sig
val f: 'a list -> 'a list
end =
struct
fun f _ = []
end
val z = S.f [1, 2, 3]
The problem MLton has with this program is that the inferred type for
f is more general than the type given in the signature. Then, at the
call to S.f, type inference is unable to deduce the result type.
Since the expression is expansive, MLton is unable to generalize the
free type variable, and reports an error. I had to patch MLton in a
couple of places and a couple of the benchmarks and regressions to
work around this bug.
Here's an overview of what I did and how things now work.
All of the type inference code has been moved from operating on CoreML
to operating on Ast. Here's how the front end now works.
elaborate convert
Ast -----------> CoreML ---------> XML
* Ast is as before, the raw, implicitly typed SML source.
* CoreML is changed and is now explicitly typed, polymorphic,
direct-style, with nested patterns, and has no module-level
constructs.
* XML is as before, explicitly typed, polymorphic, A-normal, and has
flat patterns.
At the module level, the elaborate pass
* duplicates functors
* cuts structures according to signatures
* eliminates longids
Then within each structure or functor body, for each declaration
(<dec> in the SML grammar), the elaborate pass does three steps:
1. * type variable scope inference
2. * precedence parsing
* _{ex,im}port expansion
* profiling insertion
* unification
3. * overloaded {constant, function, record pattern} resolution
Then, the convert pass does the following, all in a single step:
* linearization
* match compilation
* lookup constants
* polymorphic val dec expansion
* moves datatypes to toplevel
One consequence of doing overloading resolution on a per declaration
level instead of over the whole program means that some programs that
used to be accepted will now be rejected. For example,
val x = ref NONE
structure S = struct end
val _ = x := SOME 13
I did add a pass to the elaborator to combine declarations into as
large a block of <dec> as possible. So, for example, the following
program is accepted.
local
val r = ref NONE
in
val _ = r := SOME 13
end
Without that pass, the front end would treat this as a local <strdec>
instead of a local <dec>, and would doing overloading resolution on
the "val r" dec before the unificaiton for the "val _" dec, which
would result in an error.
Lookup constants is now a bit tricky. The _build_const and _const
declarations are turned into thunks by the elaborator. These thunks
are thawed during the conversion from CoreML to XML. To build the
constants, we elaborate the basis library and convert to XML, using
the thunks to keep track of all the constants that are produced.
Then, we write these constants out the the C file. When processing a
normal program, we use the thunks to lookup the constant in a hash
table produced from lib/<target>/constants.
Now, for a few other minor points.
Moved {compile,main}.sml to {compile,main}.fun to be more consistent.
Changed how equality is handled. Instead of being magically added
in compile.fun, it is added via _prim in the basis library.
Took out Ast from Atoms. Now, pretty printing of ILs is handled by
directly producing Layouts instead of first converting to Ast.
Removed the type information associated with primitives in
Prim.fun.
Changed the formatting of front-end error messages.
Made the naming of some type operators more consistent.
dearray --> deArray
dearrow --> deArrow
deref --> deRef
...
Revision Changes Path
1.8 +0 -2 mlton/basis-library/io/fast-imperative-io.fun
Index: fast-imperative-io.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/fast-imperative-io.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- fast-imperative-io.fun 24 Sep 2003 17:45:25 -0000 1.7
+++ fast-imperative-io.fun 9 Oct 2003 18:17:29 -0000 1.8
@@ -174,8 +174,6 @@
function = function,
cause = cause}
- val empty = V.fromList []
-
(*---------------*)
(* outstream *)
(*---------------*)
1.16 +1 -1 mlton/basis-library/io/stream-io.fun
Index: stream-io.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/stream-io.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- stream-io.fun 25 Sep 2003 01:43:25 -0000 1.15
+++ stream-io.fun 9 Oct 2003 18:17:29 -0000 1.16
@@ -45,7 +45,7 @@
function = function,
cause = cause}
- val hasLine = V.exists isLine
+ val hasLine = fn z => V.exists isLine z
(*---------------*)
(* outstream *)
1.7 +2 -0 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.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- top-level.sml 27 Jun 2003 00:15:34 -0000 1.6
+++ top-level.sml 9 Oct 2003 18:17:30 -0000 1.7
@@ -45,3 +45,5 @@
structure Unsafe = Unsafe
open Basis2002
+
+val op = = op =
1.81 +46 -43 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -r1.80 -r1.81
--- primitive.sml 26 Sep 2003 05:21:08 -0000 1.80
+++ primitive.sml 9 Oct 2003 18:17:30 -0000 1.81
@@ -13,6 +13,10 @@
* script produces type-correct SML code.
*)
+infix 4 = <> > >= < <=
+
+val op = = fn z => _prim "MLton_equal": 'a * 'a -> bool; z
+
type 'a array = 'a array
structure Bool =
struct
@@ -170,10 +174,10 @@
structure Char =
struct
- val < = _prim "Char_lt": char * char -> bool;
- val <= = _prim "Char_le": char * char -> bool;
- val > = _prim "Char_gt": char * char -> bool;
- val >= = _prim "Char_ge": char * char -> bool;
+ val op < = _prim "Char_lt": char * char -> bool;
+ val op <= = _prim "Char_le": char * char -> bool;
+ val op > = _prim "Char_gt": char * char -> bool;
+ val op >= = _prim "Char_ge": char * char -> bool;
val chr = _prim "Char_chr": int -> char;
val ord = _prim "Char_ord": char -> int;
val toWord8 = _prim "Char_toWord8": char -> Word8.word;
@@ -317,10 +321,10 @@
if detectOverflow
then _prim "Int8_subCheck": int * int -> int;
else -?
- val < = _prim "Int8_lt": int * int -> bool;
- val <= = _prim "Int8_le": int * int -> bool;
- val > = _prim "Int8_gt": int * int -> bool;
- val >= = _prim "Int8_ge": int * int -> bool;
+ val op < = _prim "Int8_lt": int * int -> bool;
+ val op <= = _prim "Int8_le": int * int -> bool;
+ val op > = _prim "Int8_gt": int * int -> bool;
+ val op >= = _prim "Int8_ge": int * int -> bool;
val quot = _prim "Int8_quot": int * int -> int;
val rem = _prim "Int8_rem": int * int -> int;
val ~? = _prim "Int8_neg": int -> int;
@@ -354,10 +358,10 @@
if detectOverflow
then _prim "Int16_subCheck": int * int -> int;
else -?
- val < = _prim "Int16_lt": int * int -> bool;
- val <= = _prim "Int16_le": int * int -> bool;
- val > = _prim "Int16_gt": int * int -> bool;
- val >= = _prim "Int16_ge": int * int -> bool;
+ val op < = _prim "Int16_lt": int * int -> bool;
+ val op <= = _prim "Int16_le": int * int -> bool;
+ val op > = _prim "Int16_gt": int * int -> bool;
+ val op >= = _prim "Int16_ge": int * int -> bool;
val quot = _prim "Int16_quot": int * int -> int;
val rem = _prim "Int16_rem": int * int -> int;
val ~? = _prim "Int16_neg": int -> int;
@@ -390,10 +394,10 @@
if detectOverflow
then _prim "Int32_subCheck": int * int -> int;
else -?
- val < = _prim "Int32_lt": int * int -> bool;
- val <= = _prim "Int32_le": int * int -> bool;
- val > = _prim "Int32_gt": int * int -> bool;
- val >= = _prim "Int32_ge": int * int -> bool;
+ val op < = _prim "Int32_lt": int * int -> bool;
+ val op <= = _prim "Int32_le": int * int -> bool;
+ val op > = _prim "Int32_gt": int * int -> bool;
+ val op >= = _prim "Int32_ge": int * int -> bool;
val quot = _prim "Int32_quot": int * int -> int;
val rem = _prim "Int32_rem": int * int -> int;
val ~? = _prim "Int32_neg": int -> int;
@@ -409,7 +413,6 @@
struct
infix 7 *?
infix 6 +? -?
- infix 4 = <> > >= < <=
type int = Int64.int
@@ -814,11 +817,11 @@
val + = _prim "Real64_add": real * real -> real;
val - = _prim "Real64_sub": real * real -> real;
val / = _prim "Real64_div": real * real -> real;
- val < = _prim "Real64_lt": real * real -> bool;
- val <= = _prim "Real64_le": real * real -> bool;
+ val op < = _prim "Real64_lt": real * real -> bool;
+ val op <= = _prim "Real64_le": real * real -> bool;
val == = _prim "Real64_equal": real * real -> bool;
- val > = _prim "Real64_gt": real * real -> bool;
- val >= = _prim "Real64_ge": real * real -> bool;
+ val op > = _prim "Real64_gt": real * real -> bool;
+ val op >= = _prim "Real64_ge": real * real -> bool;
val ?= = _prim "Real64_qequal": real * real -> bool;
val abs = _prim "Real64_abs": real -> real;
val class = _import "Real64_class": real -> int;
@@ -908,11 +911,11 @@
val + = _prim "Real32_add": real * real -> real;
val - = _prim "Real32_sub": real * real -> real;
val / = _prim "Real32_div": real * real -> real;
- val < = _prim "Real32_lt": real * real -> bool;
- val <= = _prim "Real32_le": real * real -> bool;
+ val op < = _prim "Real32_lt": real * real -> bool;
+ val op <= = _prim "Real32_le": real * real -> bool;
val == = _prim "Real32_equal": real * real -> bool;
- val > = _prim "Real32_gt": real * real -> bool;
- val >= = _prim "Real32_ge": real * real -> bool;
+ val op > = _prim "Real32_gt": real * real -> bool;
+ val op >= = _prim "Real32_ge": real * real -> bool;
val ?= = _prim "Real32_qequal": real * real -> bool;
val abs = _prim "Real32_abs": real -> real;
val class = _import "Real32_class": real -> int;
@@ -1180,11 +1183,11 @@
val div = _prim "Word8_div": word * word -> word;
val fromInt = _prim "Int32_toWord8": int -> word;
val fromLarge = _import "Word64_toWord8": LargeWord.word -> word;
- val >= = _prim "Word8_ge": word * word -> bool;
- val > = _prim "Word8_gt" : word * word -> bool;
- val <= = _prim "Word8_le": word * word -> bool;
+ val op >= = _prim "Word8_ge": word * word -> bool;
+ val op > = _prim "Word8_gt" : word * word -> bool;
+ val op <= = _prim "Word8_le": word * word -> bool;
val << = _prim "Word8_lshift": word * Word.word -> word;
- val < = _prim "Word8_lt" : word * word -> bool;
+ val op < = _prim "Word8_lt" : word * word -> bool;
val mod = _prim "Word8_mod": word * word -> word;
val * = _prim "Word8_mul": word * word -> word;
val mulCheck = _prim "Word8_mulCheck": word * word -> word;
@@ -1236,11 +1239,11 @@
val div = _prim "Word16_div": word * word -> word;
val fromInt = _prim "Int32_toWord16": int -> word;
val fromLarge = _import "Word64_toWord16": LargeWord.word -> word;
- val >= = _prim "Word16_ge": word * word -> bool;
- val > = _prim "Word16_gt" : word * word -> bool;
- val <= = _prim "Word16_le": word * word -> bool;
+ val op >= = _prim "Word16_ge": word * word -> bool;
+ val op > = _prim "Word16_gt" : word * word -> bool;
+ val op <= = _prim "Word16_le": word * word -> bool;
val << = _prim "Word16_lshift": word * Word.word -> word;
- val < = _prim "Word16_lt" : word * word -> bool;
+ val op < = _prim "Word16_lt" : word * word -> bool;
val mod = _prim "Word16_mod": word * word -> word;
val * = _prim "Word16_mul": word * word -> word;
val mulCheck = _prim "Word16_mulCheck": word * word -> word;
@@ -1270,11 +1273,11 @@
val div = _prim "Word32_div": word * word -> word;
val fromInt = _prim "Int32_toWord32": int -> word;
val fromLarge = _import "Word64_toWord32": LargeWord.word -> word;
- val >= = _prim "Word32_ge": word * word -> bool;
- val > = _prim "Word32_gt" : word * word -> bool;
- val <= = _prim "Word32_le": word * word -> bool;
+ val op >= = _prim "Word32_ge": word * word -> bool;
+ val op > = _prim "Word32_gt" : word * word -> bool;
+ val op <= = _prim "Word32_le": word * word -> bool;
val << = _prim "Word32_lshift": word * word -> word;
- val < = _prim "Word32_lt" : word * word -> bool;
+ val op < = _prim "Word32_lt" : word * word -> bool;
val mod = _prim "Word32_mod": word * word -> word;
val * = _prim "Word32_mul": word * word -> word;
val mulCheck = _prim "Word32_mulCheck": word * word -> word;
@@ -1305,11 +1308,11 @@
val div = _import "Word64_div": word * word -> word;
val fromInt = _import "Int32_toWord64": int -> word;
val fromLarge: LargeWord.word -> word = fn x => x
- val >= = _import "Word64_ge": word * word -> bool;
- val > = _import "Word64_gt" : word * word -> bool;
- val <= = _import "Word64_le": word * word -> bool;
+ val op >= = _import "Word64_ge": word * word -> bool;
+ val op > = _import "Word64_gt" : word * word -> bool;
+ val op <= = _import "Word64_le": word * word -> bool;
val << = _import "Word64_lshift": word * Word.word -> word;
- val < = _import "Word64_lt" : word * word -> bool;
+ val op < = _import "Word64_lt" : word * word -> bool;
val mod = _import "Word64_mod": word * word -> word;
val * = _import "Word64_mul": word * word -> word;
(* val mulCheck = _import "Word64_mulCheck": word * word -> word; *)
@@ -1345,7 +1348,7 @@
open Int8
local
- fun make f (i: int, i': int): bool =
+ fun make f (i: Int.int, i': Int.int): bool =
f (Primitive.Word8.fromInt i, Primitive.Word8.fromInt i')
in
val geu = make Primitive.Word8.>=
@@ -1357,7 +1360,7 @@
open Int16
local
- fun make f (i: int, i': int): bool =
+ fun make f (i: Int.int, i': Int.int): bool =
f (Primitive.Word16.fromInt i, Primitive.Word16.fromInt i')
in
val geu = make Primitive.Word16.>=
1.5 +6 -3 mlton/basis-library/text/string-cvt.sml
Index: string-cvt.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/string-cvt.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- string-cvt.sml 4 Dec 2002 00:29:01 -0000 1.4
+++ string-cvt.sml 9 Oct 2003 18:17:30 -0000 1.5
@@ -35,9 +35,12 @@
structure String = String0
local
- fun pad f c i s =
- let val n = String.size s
- in if n >= i then s
+ fun pad f (c: char) i s =
+ let
+ val n = String.size s
+ in
+ if n >= i
+ then s
else f (s, String0.vector (i -? n, c))
end
in
1.10 +2 -2 mlton/benchmark/benchmark.cm
Index: benchmark.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/benchmark.cm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- benchmark.cm 23 Jun 2003 04:58:54 -0000 1.9
+++ benchmark.cm 9 Oct 2003 18:17:30 -0000 1.10
@@ -123,8 +123,6 @@
../lib/mlton/basic/file-desc.sig
../lib/mlton/basic/file-desc.sml
../lib/mlton/basic/signal.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/function.sig
../lib/mlton/basic/function.sml
../lib/mlton/basic/dir.sig
@@ -135,6 +133,8 @@
../lib/mlton/basic/justify.sml
../lib/mlton/basic/popt.sig
../lib/mlton/basic/popt.sml
+../lib/mlton/basic/int-inf.sig
+../lib/mlton/basic/int-inf.sml
../lib/mlton/basic/escape.sig
../lib/mlton/basic/escape.sml
../lib/mlton/basic/choice-pattern.sig
1.5 +2 -0 mlton/benchmark/tests/model-elimination.sml
Index: model-elimination.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/benchmark/tests/model-elimination.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- model-elimination.sml 24 Sep 2003 17:45:26 -0000 1.4
+++ model-elimination.sml 9 Oct 2003 18:17:30 -0000 1.5
@@ -2521,6 +2521,8 @@
fun finished S.NIL = ((), S.NIL)
| finished (S.CONS _) = raise Noparse;
+val finished: ('a, unit) parser = finished
+
fun some p = maybe (fn x => if p x then SOME x else NONE);
fun any input = some (K true) input;
1.32 +68 -63 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- mlton-stubs.cm 24 Sep 2003 17:54:02 -0000 1.31
+++ mlton-stubs.cm 9 Oct 2003 18:17:30 -0000 1.32
@@ -5,22 +5,19 @@
../lib/mlyacc/parser2.sml
../lib/mlyacc/join.sml
upgrade-basis.sml
+../lib/mlton/basic/error.sig
+../lib/mlton/basic/error.sml
../lib/mlton-stubs/int-inf.sml
../lib/mlton-stubs/real.sml
../lib/mlton/pervasive/pervasive.sml
../lib/mlton/basic/dynamic-wind.sig
../lib/mlton/basic/dynamic-wind.sml
-../lib/mlton/basic/error.sig
-../lib/mlton/basic/error.sml
../lib/mlton/basic/outstream0.sml
../lib/mlton/basic/relation0.sml
../lib/mlton/basic/char0.sml
../lib/mlton/basic/string0.sml
../lib/mlton/basic/layout.sig
../lib/mlton/basic/layout.sml
-../lib/mlton/basic/instream0.sml
-../lib/mlton/basic/fold.sig
-../lib/mlton/basic/fold.fun
../lib/mlton-stubs/thread.sml
../lib/mlton-stubs/random.sig
../lib/mlton-stubs/random.sml
@@ -52,12 +49,17 @@
../lib/mlton-stubs/itimer.sig
../lib/mlton-stubs/mlton.sig
../lib/mlton-stubs/mlton.sml
-../lib/mlton/basic/word.sig
-../lib/mlton/basic/word8.sml
../lib/mlton/basic/assert.sig
../lib/mlton/basic/assert.sml
+../lib/mlton/basic/fold.sig
+../lib/mlton/basic/fold.fun
../lib/mlton/basic/list.sig
../lib/mlton/basic/list.sml
+../lib/mlton/basic/option.sig
+../lib/mlton/basic/option.sml
+../lib/mlton/basic/string-map.sig
+../lib/mlton/basic/word.sig
+../lib/mlton/basic/word8.sml
../lib/mlton/basic/word32.sig
../lib/mlton/basic/word.sml
../lib/mlton/basic/string1.sml
@@ -67,29 +69,15 @@
../lib/mlton/basic/outstream.sml
../lib/mlton/basic/relation.sig
../lib/mlton/basic/relation.sml
-../lib/mlton/basic/ring.sig
-../lib/mlton/basic/ring-with-identity.sig
-../lib/mlton/basic/promise.sig
-../lib/mlton/basic/promise.sml
-../lib/mlton/basic/stream.sig
-../lib/mlton/basic/stream.sml
-../lib/mlton/basic/euclidean-ring.sig
-../lib/mlton/basic/integer.sig
-../lib/mlton/basic/ring.fun
-../lib/mlton/basic/ordered-ring.sig
-../lib/mlton/basic/ordered-ring.fun
-../lib/mlton/basic/power.sml
-../lib/mlton/basic/string-map.sig
../lib/mlton/basic/order0.sig
../lib/mlton/basic/order.sig
../lib/mlton/basic/time.sig
../lib/mlton/basic/time.sml
+../lib/mlton/basic/instream0.sml
../lib/mlton/basic/computation.sig
../lib/mlton/basic/intermediate-computation.sig
../lib/mlton/basic/intermediate-computation.sml
../lib/mlton/basic/string-map.sml
-../lib/mlton/basic/option.sig
-../lib/mlton/basic/option.sml
../lib/mlton/basic/pid.sig
../lib/mlton/basic/pid.sml
../lib/mlton/basic/date.sig
@@ -101,12 +89,29 @@
../lib/mlton/basic/unit.sml
../lib/mlton/basic/trace.sig
../lib/mlton/basic/trace.sml
-../lib/mlton/basic/ring-with-identity.fun
../lib/mlton/basic/bool.sig
../lib/mlton/basic/bool.sml
+../lib/mlton/basic/ring.sig
+../lib/mlton/basic/ring-with-identity.sig
+../lib/mlton/basic/promise.sig
+../lib/mlton/basic/promise.sml
+../lib/mlton/basic/stream.sig
+../lib/mlton/basic/stream.sml
+../lib/mlton/basic/euclidean-ring.sig
+../lib/mlton/basic/integer.sig
+../lib/mlton/basic/ring.fun
+../lib/mlton/basic/ordered-ring.sig
+../lib/mlton/basic/ordered-ring.fun
+../lib/mlton/basic/power.sml
+../lib/mlton/basic/ring-with-identity.fun
../lib/mlton/basic/euclidean-ring.fun
../lib/mlton/basic/integer.fun
../lib/mlton/basic/int.sml
+../lib/mlton/basic/vector.sig
+../lib/mlton/basic/vector.fun
+../lib/mlton/basic/vector.sml
+../lib/mlton/set/set.sig
+../lib/mlton/set/unordered.fun
../lib/mlton/basic/property-list.sig
../lib/mlton/basic/property.sig
../lib/mlton/basic/het-container.sig
@@ -121,12 +126,9 @@
../lib/mlton/basic/ref.sml
../lib/mlton/basic/property-list.fun
../lib/mlton/basic/property.fun
-../lib/mlton/basic/vector.sig
../lib/mlton/basic/array.sig
-../lib/mlton/basic/vector.fun
../lib/mlton/basic/random.sig
../lib/mlton/basic/random.sml
-../lib/mlton/basic/vector.sml
../lib/mlton/basic/array.fun
../lib/mlton/basic/array.sml
../lib/mlton/basic/hash-set.sig
@@ -145,39 +147,36 @@
control/source-pos.sml
control/region.sig
control/region.sml
-../lib/mlton/set/set.sig
-../lib/mlton/basic/large-word.sml
-ast/word-size.sig
ast/wrapped.sig
ast/tyvar.sig
ast/field.sig
ast/record.sig
+../lib/mlton/basic/large-word.sml
+ast/word-size.sig
ast/real-size.sig
../lib/mlton/basic/int-inf.sig
../lib/mlton/basic/int-inf.sml
ast/int-size.sig
+ast/tycon-kind.sig
ast/prim-tycons.sig
-ast/prim-cons.sig
-ast/ast-id.sig
-ast/longid.sig
-ast/ast-const.sig
-ast/ast-atoms.sig
-ast/ast-core.sig
-ast/ast.sig
-atoms/word-x.sig
atoms/id.sig
-atoms/var.sig
atoms/tycon.sig
-atoms/source-info.sig
atoms/type-ops.sig
atoms/type.sig
+atoms/type-ops.fun
+atoms/type.fun
atoms/generic-scheme.sig
atoms/scheme.sig
+atoms/generic-scheme.fun
+atoms/word-x.sig
+atoms/var.sig
+atoms/source-info.sig
atoms/real-x.sig
atoms/profile-exp.sig
atoms/c-type.sig
atoms/c-function.sig
-atoms/cons.sig
+ast/prim-cons.sig
+atoms/con.sig
atoms/int-x.sig
atoms/const.sig
atoms/prim.sig
@@ -188,6 +187,8 @@
xml/xml-tree.sig
xml/sxml-tree.sig
xml/sxml-tree.fun
+core-ml/core-ml.sig
+core-ml/dead-code.sig
../lib/mlton/basic/counter.sig
../lib/mlton/basic/counter.sml
../lib/mlton/basic/dot-color.sml
@@ -231,6 +232,7 @@
cm/parse.sml
cm/cm.sig
cm/cm.sml
+main/main.sig
ast/tyvar.fun
../lib/mlton/basic/quick-sort.sig
../lib/mlton/basic/insertion-sort.sig
@@ -238,8 +240,17 @@
../lib/mlton/basic/quick-sort.sml
ast/record.fun
ast/field.fun
+control/pretty.sig
+control/pretty.sml
+ast/ast-id.sig
+ast/longid.sig
+ast/ast-const.sig
+ast/ast-atoms.sig
+ast/ast-core.sig
+ast/ast.sig
ast/ast-const.fun
ast/word-size.fun
+ast/tycon-kind.fun
ast/real-size.fun
ast/prim-tycons.fun
ast/prim-cons.fun
@@ -249,22 +260,18 @@
ast/ast-atoms.fun
ast/ast-core.fun
ast/ast.fun
-../lib/mlton/set/unordered.fun
atoms/word-x.fun
atoms/id.fun
atoms/var.fun
-atoms/type-ops.fun
-atoms/type.fun
atoms/tycon.fun
atoms/source-info.fun
atoms/real-x.fun
atoms/profile-exp.fun
atoms/prim.fun
atoms/int-x.fun
-atoms/generic-scheme.fun
atoms/ffi.fun
atoms/const.fun
-atoms/cons.fun
+atoms/con.fun
atoms/c-type.fun
atoms/c-function.fun
atoms/atoms.fun
@@ -462,22 +469,26 @@
codegen/x86-codegen/x86-validate.sig
codegen/x86-codegen/x86-validate.fun
codegen/x86-codegen/x86-codegen.fun
-core-ml/core-ml.sig
core-ml/core-ml.fun
-core-ml/dead-code.sig
-core-ml/dead-code.fun
-core-ml/lookup-constant.sig
-core-ml/lookup-constant.fun
+match-compile/nested-pat.sig
+match-compile/nested-pat.fun
+../lib/mlton/env/mono-env.sig
+../lib/mlton/env/basic-env-to-env.fun
+../lib/mlton/env/mono-env.fun
+match-compile/match-compile.sig
+match-compile/match-compile.fun
+defunctorize/defunctorize.sig
+defunctorize/defunctorize.fun
+elaborate/type-env.sig
+elaborate/type-env.fun
elaborate/decs.sig
elaborate/elaborate-env.sig
+elaborate/const-type.sig
elaborate/elaborate.sig
elaborate/decs.fun
elaborate/elaborate-env.fun
elaborate/elaborate-sigexp.sig
elaborate/elaborate-sigexp.fun
-../lib/mlton/env/mono-env.sig
-../lib/mlton/env/basic-env-to-env.fun
-../lib/mlton/env/mono-env.fun
atoms/use-name.fun
elaborate/scope.sig
elaborate/scope.fun
@@ -493,16 +504,10 @@
front-end/ml.grm.sml
front-end/ml.lex.sml
front-end/front-end.fun
-type-inference/type-env.sig
-type-inference/type-env.fun
-type-inference/nested-pat.sig
-type-inference/nested-pat.fun
-type-inference/match-compile.sig
-type-inference/match-compile.fun
-type-inference/infer.sig
-type-inference/infer.fun
main/compile.sig
-main/compile.sml
-main/main.sig
+main/lookup-constant.sig
+main/lookup-constant.fun
+main/compile.fun
+main/main.fun
main/main.sml
call-main.sml
1.6 +5 -2 mlton/mlton/ast/ast-atoms.fun
Index: ast-atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- ast-atoms.fun 23 Jun 2003 04:58:55 -0000 1.5
+++ ast-atoms.fun 9 Oct 2003 18:17:30 -0000 1.6
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor AstAtoms (S: AST_ATOMS_STRUCTS) :> AST_ATOMS =
+functor AstAtoms (S: AST_ATOMS_STRUCTS): AST_ATOMS =
struct
open S
@@ -15,6 +15,8 @@
structure RealSize = RealSize ()
structure WordSize = WordSize ()
+structure Kind = TyconKind ()
+
structure Tycon =
struct
structure Id = AstId (val className = "tycon")
@@ -22,10 +24,11 @@
structure P =
PrimTycons (structure IntSize = IntSize
+ structure Kind = Kind
structure RealSize = RealSize
structure WordSize = WordSize
open Id
- val fromString = fn s => fromString (s, Region.bogus))
+ fun fromString s = Id.fromString (s, Region.bogus))
open P
end
1.4 +6 -6 mlton/mlton/ast/ast-atoms.sig
Index: ast-atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-atoms.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ast-atoms.sig 21 Jul 2003 21:53:50 -0000 1.3
+++ ast-atoms.sig 9 Oct 2003 18:17:30 -0000 1.4
@@ -90,16 +90,16 @@
include WRAPPED sharing type node' = node
sharing type obj = t
- val var: Tyvar.t -> t
- val con: Tycon.t * t vector -> t
- val record: t SortedRecord.t -> t
val arrow: t * t -> t
+ val con: Tycon.t * t vector -> t
val exn: t
- val tuple: t vector -> t
- val unit: t
val layout: t -> Layout.t
- val layoutOption: t option -> Layout.t
val layoutApp: Layout.t * 'a vector * ('a -> Layout.t) -> Layout.t
+ val layoutOption: t option -> Layout.t
+ val record: t SortedRecord.t -> t
+ val tuple: t vector -> t
+ val unit: t
+ val var: Tyvar.t -> t
end
structure TypBind:
sig
1.5 +5 -3 mlton/mlton/ast/ast-const.fun
Index: ast-const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-const.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ast-const.fun 23 Jun 2003 04:58:55 -0000 1.4
+++ ast-const.fun 9 Oct 2003 18:17:30 -0000 1.5
@@ -5,12 +5,13 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor AstConst (S: AST_CONST_STRUCTS) :> AST_CONST =
+functor AstConst (S: AST_CONST_STRUCTS): AST_CONST =
struct
open Region.Wrap
datatype node =
- Char of char
+ Bool of bool
+ | Char of char
| Int of IntInf.t
| Real of string
| String of string
@@ -27,7 +28,8 @@
in
fun layout c =
case node c of
- Char c => wrap ("#\"", "\"", String.implode [c])
+ Bool b => if b then str "true" else str "false"
+ | Char c => wrap ("#\"", "\"", String.implode [c])
| Int s => str (IntInf.toString s)
| Real l => String.layout l
| String s => wrap ("\"", "\"", s)
1.5 +2 -1 mlton/mlton/ast/ast-const.sig
Index: ast-const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-const.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ast-const.sig 23 Jun 2003 04:58:55 -0000 1.4
+++ ast-const.sig 9 Oct 2003 18:17:30 -0000 1.5
@@ -19,7 +19,8 @@
type t
datatype node =
- Char of char
+ Bool of bool
+ | Char of char
| Int of IntInf.t
| Real of string
| String of string
1.14 +114 -102 mlton/mlton/ast/ast-core.fun
Index: ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- ast-core.fun 21 Jul 2003 21:53:50 -0000 1.13
+++ ast-core.fun 9 Oct 2003 18:17:30 -0000 1.14
@@ -60,14 +60,6 @@
NONE => e
| SOME ty => layoutConstraint (e, ty)
-fun nest (prefix, x, y) =
- align [seq [str prefix, x],
- seq [str "in ", y],
- str "end"]
-
-fun layoutLet (d, e) = nest ("let ", d, e)
-fun layoutLocal (d, d') = nest ("local ", d, d')
-
fun layoutLongvid x =
str (let val s = Longvid.toString x
in if s = "*" then " * "
@@ -76,6 +68,13 @@
else s
end)
+structure Vector =
+ struct
+ open Vector
+
+ fun cons (x, v) = concat [new1 x, v]
+ end
+
(*---------------------------------------------------*)
(* Patterns *)
(*---------------------------------------------------*)
@@ -92,7 +91,7 @@
var: Var.t,
constraint: Type.t option,
pat: t}
- | List of t list
+ | List of t vector
| Record of {flexible: bool,
items: item vector}
| Tuple of t vector
@@ -119,7 +118,7 @@
val constraint = make o Constraint
val layered = make o Layered
- val emptyList = make (List [])
+ val emptyList = make (List (Vector.new0 ()))
fun longvid x = make (Var {name = x, fixop = Fixop.None})
val var = longvid o Longvid.short o Vid.fromVar
@@ -129,21 +128,25 @@
else longvid (Longvid.short (Vid.fromCon c))
fun app (c, p) =
- let val default = make (App (Longcon.short c, p))
- in if Con.equals (c, Con.cons)
- then (case node p of
- Tuple ps =>
- if 2 = Vector.length ps
- then
- let
- val p0 = Vector.sub (ps, 0)
- val p1 = Vector.sub (ps, 1)
- in case node p1 of
- List ps => make (List (p0 :: ps))
- | _ => default
- end
- else default
- | _ => default)
+ let
+ val default = make (App (Longcon.short c, p))
+ in
+ if Con.equals (c, Con.cons)
+ then
+ case node p of
+ Tuple ps =>
+ if 2 = Vector.length ps
+ then
+ let
+ val p0 = Vector.sub (ps, 0)
+ val p1 = Vector.sub (ps, 1)
+ in
+ case node p1 of
+ List ps => make (List (Vector.cons (p0, ps)))
+ | _ => default
+ end
+ else default
+ | _ => default
else default
end
@@ -182,7 +185,7 @@
then str (if Vector.isEmpty items then "..." else ", ...")
else empty,
str "}"]
- | List ps => Layout.list (List.map (ps, layoutT))
+ | List ps => Layout.vector (Vector.map (ps, layoutT))
| FlatApp ps => delimit (layoutFlatApp ps)
| App (c, p) => delimit (mayAlign [Longcon.layout c,
layoutF p])
@@ -273,11 +276,11 @@
| Seq of exp vector
| Const of Const.t
| Record of expNode Wrap.t Record.t (* the Kit barfs on exp Record.t *)
- | List of exp list
+ | List of exp vector
| Selector of Field.t
| Constraint of exp * Type.t
| Handle of exp * match
- | Raise of {exn: exp, filePos: string}
+ | Raise of exp
| If of exp * exp * exp
| Andalso of exp * exp
| Orelse of exp * exp
@@ -292,32 +295,34 @@
| Exception of Eb.t vector
| Fix of {fixity: Fixity.t,
ops: Vid.t vector}
- | Fun of Tyvar.t vector * {clauses: {body: exp,
- pats: Pat.t vector,
- resultType: Type.t option} vector,
- filePos: string} vector
+ | Fun of Tyvar.t vector * {body: exp,
+ pats: Pat.t vector,
+ resultType: Type.t option} vector vector
| Local of dec * dec
| Open of Longstrid.t vector
- | Overload of Var.t * Type.t * Longvar.t vector
+ | Overload of Var.t * Tyvar.t vector * Type.t * Longvar.t vector
| SeqDec of dec vector
| Type of TypBind.t
| Val of {tyvars: Tyvar.t vector,
vbs: {exp: exp,
- filePos: string,
pat: Pat.t} vector,
rvbs: {match: match,
pat: Pat.t} vector}
-and match = T of {filePos: string,
- rules: (Pat.t * exp) vector}
+and matchNode = T of (Pat.t * exp) vector
withtype
- exp = expNode Wrap.t
-and dec = decNode Wrap.t
+ dec = decNode Wrap.t
+and exp = expNode Wrap.t
+and match = matchNode Wrap.t
open Wrap
structure Match =
struct
- datatype t = datatype match
+ open Wrap
+ type t = match
+ datatype node = datatype matchNode
+ type node' = node
+ type obj = t
end
fun layoutAndsTyvars (prefix, (tyvars, xs), layoutX) =
@@ -330,7 +335,36 @@
| [] => [],
fn (prefix, x) => seq [prefix, x])
-fun layoutExp (e, isDelimited) =
+fun expNodeName e =
+ case node e of
+ Andalso _ => "Andalso"
+ | App _ => "App"
+ | Case _ => "Case"
+ | Const _ => "Const"
+ | Constraint _ => "Constraint"
+ | FlatApp _ => "FlatApp"
+ | Fn _ => "Fn"
+ | Handle _ => "Handle"
+ | If _ => "If"
+ | Let _ => "Let"
+ | List _ => "List"
+ | Orelse _ => "Orelse"
+ | Prim _ => "Prim"
+ | Raise _ => "Raise"
+ | Record _ => "Record"
+ | Selector _ => "Selector"
+ | Seq _ => "Seq"
+ | Var _ => "Var"
+ | While _ => "While"
+
+val traceLayoutExp =
+ Trace.traceInfo' (Trace.info "layoutExp",
+ fn (e, b: bool) => Layout.str (expNodeName e),
+ Layout.ignore: Layout.t -> Layout.t)
+
+fun layoutExp arg =
+ traceLayoutExp
+ (fn (e, isDelimited) =>
let
fun delimit t = if isDelimited then t else paren t
in
@@ -344,7 +378,7 @@
delimit (align [seq [str "case ", layoutExpT expr,
str " of"],
indent (layoutMatch match, 2)])
- | Let (dec, expr) => layoutLet (layoutDec dec, layoutExpT expr)
+ | Let (dec, expr) => Pretty.lett (layoutDec dec, layoutExpT expr)
| Seq es => paren (align (separateRight (layoutExpsT es, " ;")))
| Const c => Const.layout c
| Record r =>
@@ -355,19 +389,19 @@
else tuple (layoutExpsT es)
in
Record.layout {record = r,
- separator = " =",
+ separator = " = ",
extra = "",
layoutTuple = layoutTuple,
layoutElt = layoutExpT}
end
- | List es => list (List.map (es, layoutExpT))
+ | List es => vector (Vector.map (es, layoutExpT))
| Selector f => seq [str "#", Field.layout f]
| Constraint (expr, constraint) =>
delimit (layoutConstraint (layoutExpF expr, constraint))
| Handle (try, match) =>
delimit (align [layoutExpF try,
seq [str "handle ", layoutMatch match]])
- | Raise {exn, ...} => delimit (seq [str "raise ", layoutExpF exn])
+ | Raise exn => delimit (seq [str "raise ", layoutExpF exn])
| If (test, thenCase, elseCase) =>
delimit (mayAlign [seq [str "if ", layoutExpT test],
seq [str "then ", layoutExpT thenCase],
@@ -382,13 +416,17 @@
delimit (align [seq [str "while ", layoutExpT test],
seq [str "do ", layoutExpT expr]])
| Prim {name, ...} => str name
- end
+ end) arg
and layoutExpsT es = Vector.toListMap (es, layoutExpT)
and layoutExpT e = layoutExp (e, true)
and layoutExpF e = layoutExp (e, false)
-and layoutMatch (Match.T {rules, ...}) =
- alignPrefix (Vector.toListMap (rules, layoutRule), "| ")
+and layoutMatch m =
+ let
+ val Match.T rules = node m
+ in
+ alignPrefix (Vector.toListMap (rules, layoutRule), "| ")
+ end
and layoutRule (pat, exp) =
mayAlign [seq [Pat.layoutF pat, str " =>"],
@@ -396,40 +434,40 @@
and layoutDec d =
case node d of
- Local (d, d') => layoutLocal (layoutDec d, layoutDec d')
- | SeqDec ds => align (Vector.toListMap (ds, layoutDec))
- | Val {tyvars, vbs, rvbs} =>
- align [layoutAndsTyvars ("val", (tyvars, vbs), layoutVb),
- layoutAndsTyvars ("val rec", (tyvars, rvbs), layoutRvb)]
- | Fun fbs => layoutAndsTyvars ("fun", fbs, layoutFb)
- | Type typBind => TypBind.layout typBind
- | Datatype rhs => DatatypeRhs.layout rhs
- | Abstype {datBind, body} =>
+ Abstype {datBind, body} =>
align [DatBind.layout ("abstype", datBind),
seq [str "with ", layoutDec body],
str "end"]
+ | Datatype rhs => DatatypeRhs.layout rhs
| Exception ebs =>
layoutAnds ("exception", Vector.toList ebs,
fn (prefix, eb) => seq [prefix, Eb.layout eb])
+ | Fix {fixity, ops} =>
+ seq [Fixity.layout fixity, str " ",
+ seq (separate (Vector.toListMap (ops, Vid.layout), " "))]
+ | Fun fbs => layoutAndsTyvars ("fun", fbs, layoutFb)
+ | Local (d, d') => Pretty.locall (layoutDec d, layoutDec d')
| Open ss => seq [str "open ",
seq (separate (Vector.toListMap (ss, Longstrid.layout),
" "))]
- | Overload (x, t, xs) =>
+ | Overload (x, _, t, xs) =>
seq [str "_overload ",
align [layoutConstraint (Var.layout x, t),
layoutAnds ("as", Vector.toList xs, fn (prefix, x) =>
seq [prefix, Longvar.layout x])]]
- | Fix {fixity, ops} =>
- seq [Fixity.layout fixity, str " ",
- seq (separate (Vector.toListMap (ops, Vid.layout), " "))]
+ | SeqDec ds => align (Vector.toListMap (ds, layoutDec))
+ | Type typBind => TypBind.layout typBind
+ | Val {tyvars, vbs, rvbs} =>
+ align [layoutAndsTyvars ("val", (tyvars, vbs), layoutVb),
+ layoutAndsTyvars ("val rec", (tyvars, rvbs), layoutRvb)]
-and layoutVb {pat, exp, filePos} =
+and layoutVb {pat, exp} =
bind (Pat.layoutT pat, layoutExpT exp)
and layoutRvb {pat, match, ...} =
bind (Pat.layout pat, seq [str "fn ", layoutMatch match])
-and layoutFb {clauses, filePos} =
+and layoutFb clauses =
alignPrefix (Vector.toListMap (clauses, layoutClause), "| ")
and layoutClause ({pats, resultType, body}) =
@@ -452,7 +490,8 @@
fun make n = makeRegion (n, Region.bogus)
val const = make o Const
val constraint = make o Constraint
- val fnn = make o Fn
+ fun fnn rs =
+ make (Fn (Match.makeRegion (Match.T rs, Region.bogus)))
val handlee = make o Handle
val raisee = make o Raise
val record = make o Record
@@ -468,17 +507,20 @@
case node e of
Var {name=x', ...} => Longvid.equals (x, x')
| _ => false
- in val isTrue = isLongvid Longvid.truee
+ in
val isFalse = isLongvid Longvid.falsee
+ val isTrue = isLongvid Longvid.truee
end
-
+
fun iff (a: t, b: t, c: t): t =
make (if isTrue b then Orelse (a, c)
else if isFalse c then Andalso (a, b)
else If (a, b, c))
- fun casee (e: t, m as Match.T {rules, ...}) =
- let val default = make (Case (e, m))
+ fun casee (e: t, m: Match.t) =
+ let
+ val Match.T rules = Match.node m
+ val default = make (Case (e, m))
in
if 2 = Vector.length rules
then
@@ -495,7 +537,7 @@
else default
end
- val emptyList: t = make (List [])
+ val emptyList: t = make (List (Vector.new0 ()))
fun con c: t = if Con.equals (c, Con.nill) then emptyList
else longvid (Longvid.short (Vid.fromCon c))
@@ -520,7 +562,9 @@
val es = Vector.sub (v, 1)
in
case node es of
- List es => make (List (e1 :: es))
+ List es =>
+ make (List (Vector.cons
+ (e1, es)))
| _ => e
end
else e
@@ -570,19 +614,6 @@
val unit: t = tuple (Vector.new0 ())
- fun delay (e: t): t =
- fnn (Match.T {rules = Vector.new1 (Pat.tuple (Vector.new0 ()), e),
- filePos = ""})
-(*
- * val handleFunc =
- * let val e = Var.fromString "e"
- * val f = Var.fromString "f"
- * val x = Var.fromString "x"
- * in fnn (rules [(Pat.tuple [Pat.var e, Pat.var f],
- * make (Handle (app (var e, unit),
- * rules [(Pat.var x, app (var f, var x))])))])
- * end
- *)
val layout = layoutExpT
end
@@ -598,24 +629,6 @@
val openn = make o Open
- fun funn (tyvars, rvbs): t =
- make
- (Fun (tyvars,
- Vector.map
- (rvbs, fn {var,
- match = Match.T {rules, filePos},
- resultTy} =>
- let
- val vp = Pat.longvid (Longvid.short (Vid.fromVar var))
- in
- {clauses =
- Vector.map (rules, fn (pat, exp) =>
- {pats = Vector.new2 (vp, pat),
- body = exp,
- resultType = NONE}),
- filePos = filePos}
- end)))
-
fun exceptionn (exn: Con.t, to: Type.t option): t =
make (Exception (Vector.new1 (exn, make (Eb.Rhs.Gen to))))
@@ -634,8 +647,7 @@
fun vall (tyvars, var, exp): t =
make (Val {tyvars = tyvars,
- vbs = Vector.new1 {pat = Pat.var var, exp = exp,
- filePos = ""},
+ vbs = Vector.new1 {exp = exp, pat = Pat.var var},
rvbs = Vector.new0 ()})
local
1.10 +14 -20 mlton/mlton/ast/ast-core.sig
Index: ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- ast-core.sig 21 Jul 2003 21:53:50 -0000 1.9
+++ ast-core.sig 9 Oct 2003 18:17:30 -0000 1.10
@@ -54,7 +54,7 @@
fixop: Fixop.t,
pat: t,
var: Var.t}
- | List of t list
+ | List of t vector
| Record of {flexible: bool,
items: Item.t vector}
| Tuple of t vector
@@ -113,13 +113,12 @@
| Handle of t * match
| If of t * t * t
| Let of dec * t
- | List of t list
+ | List of t vector
| Orelse of t * t
| Prim of {kind: PrimKind.t,
name: string,
ty: Type.t}
- | Raise of {exn: t,
- filePos: string}
+ | Raise of t
| Record of t Record.t
| Selector of Record.Field.t
| Seq of t vector
@@ -136,13 +135,13 @@
val con: Con.t -> t
val const: Const.t -> t
val constraint: t * Type.t -> t
- val fnn: match -> t
+ val fnn: (Pat.t * t) vector -> t
val handlee: t * match -> t
val iff: t * t * t -> t
val layout: t -> Layout.t
val lett: dec vector * t -> t
val longvid: Longvid.t -> t
- val raisee: {exn: t, filePos: string} -> t
+ val raisee: t -> t
val record: t Record.t -> t
val select: {tuple: t, offset: int} -> t
val seq: t vector -> t
@@ -153,8 +152,11 @@
structure Match:
sig
- datatype t = T of {filePos: string,
- rules: (Pat.t * Exp.t) vector}
+ type t
+ datatype node = T of (Pat.t * Exp.t) vector
+ include WRAPPED
+ sharing type node' = node
+ sharing type obj = t
end where type t = Exp.match
structure EbRhs:
@@ -177,20 +179,18 @@
| Exception of (Con.t * EbRhs.t) vector
| Fix of {fixity: Fixity.t,
ops: Vid.t vector}
- | Fun of Tyvar.t vector * {clauses: {pats: Pat.t vector,
- resultType: Type.t option,
- body: Exp.t} vector,
- filePos: string} vector
+ | Fun of Tyvar.t vector * {pats: Pat.t vector,
+ resultType: Type.t option,
+ body: Exp.t} vector vector
| Local of t * t
| Open of Longstrid.t vector
- | Overload of Var.t * Type.t * Longvar.t vector
+ | Overload of Var.t * Tyvar.t vector * Type.t * Longvar.t vector
| SeqDec of t vector
| Type of TypBind.t
| Val of {rvbs: {match: Match.t,
pat: Pat.t} vector,
tyvars: Tyvar.t vector,
vbs: {exp: Exp.t,
- filePos: string,
pat: Pat.t} vector}
include WRAPPED sharing type node' = node
sharing type obj = t
@@ -201,15 +201,9 @@
val empty: t
val exceptionn: Con.t * Type.t option -> t
val fromExp: Exp.t -> t
- val funn: Tyvar.t vector * {var: Var.t,
- match: Match.t,
- resultTy: Type.t option} vector -> t
val layout: t -> Layout.t
val openn: Longstrid.t vector -> t
val vall: Tyvar.t vector * Var.t * Exp.t -> t
end
sharing type Dec.t = Exp.dec
-
- val layoutLet: Layout.t * Layout.t -> Layout.t
- val layoutLocal: Layout.t * Layout.t -> Layout.t
end
1.7 +116 -28 mlton/mlton/ast/ast.fun
Index: ast.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ast.fun 24 Nov 2002 01:19:43 -0000 1.6
+++ ast.fun 9 Oct 2003 18:17:30 -0000 1.7
@@ -11,12 +11,6 @@
open S
structure Const = AstConst ()
-structure Field = Field ()
-structure Record = Record (val isSorted = false
- structure Field = Field)
-structure SortedRecord = Record (val isSorted = true
- structure Field = Field)
-structure Tyvar = Tyvar ()
structure AstAtoms = AstAtoms (structure Const = Const
structure Record = Record
@@ -225,7 +219,7 @@
| _ => Split 3,
seq [Strid.layout name, SigConst.layout constraint],
layoutStrexp def))
- | Local (d, d') => layoutLocal (layoutStrdec d, layoutStrdec d')
+ | Local (d, d') => Pretty.locall (layoutStrdec d, layoutStrdec d')
| Seq ds => align (layoutStrdecs ds)
| Core d => Dec.layout d
@@ -240,7 +234,7 @@
| Constrained (e, c) => mayAlign [layoutStrexp e, SigConst.layout c]
| App (f, e) =>
seq [Fctid.layout f, str "(", layoutStrexp e, str ")"]
- | Let (dec, strexp) => layoutLet (layoutStrdec dec, layoutStrexp strexp)
+ | Let (dec, strexp) => Pretty.lett (layoutStrdec dec, layoutStrexp strexp)
structure Strexp =
struct
@@ -270,6 +264,7 @@
fun make n = makeRegion (n, Region.bogus)
val structuree = make o Structure
+
val locall = make o Local
val core = make o Core
val seq = make o Seq
@@ -279,6 +274,64 @@
val layout = layoutStrdec
val fromExp = core o Dec.fromExp
+
+ val trace = Trace.trace ("coalesce", layout, layout)
+ fun coalesce (d: t): t =
+ trace
+ (fn d =>
+ case node d of
+ Core _ => d
+ | Local (d1, d2) =>
+ let
+ val d1 = coalesce d1
+ val d2 = coalesce d2
+ val node =
+ case (node d1, node d2) of
+ (Core d1', Core d2') =>
+ Core (Dec.makeRegion
+ (Dec.Local (d1', d2'),
+ Region.append (region d1, region d2)))
+ | _ => Local (d1, d2)
+ in
+ makeRegion (node, region d)
+ end
+ | Seq ds =>
+ let
+ fun finish (ds: Dec.t list, ac: t list): t list =
+ case ds of
+ [] => ac
+ | _ =>
+ let
+ val d =
+ makeRegion (Core (Dec.makeRegion
+ (Dec.SeqDec (Vector.fromListRev ds),
+ Region.bogus)),
+ Region.bogus)
+ in
+ d :: ac
+ end
+ fun loop (ds, cores, ac) =
+ case ds of
+ [] => finish (cores, ac)
+ | d :: ds =>
+ let
+ val d = coalesce d
+ in
+ case node d of
+ Core d => loop (ds, d :: cores, ac)
+ | Seq ds' => loop (ds' @ ds, cores, ac)
+ | _ => loop (ds, [], d :: finish (cores, ac))
+ end
+ val r = region d
+ in
+ case loop (ds, [], []) of
+ [] => makeRegion (Core (Dec.makeRegion
+ (Dec.SeqDec (Vector.new0 ()), r)),
+ r)
+ | [d] => d
+ | ds => makeRegion (Seq (rev ds), r)
+ end
+ | Structure _ => d) d
end
structure FctArg =
@@ -348,6 +401,32 @@
fun layout (T ds) = Layout.align (List.map (ds, Topdec.layout))
+ fun coalesce (T ds) =
+ let
+ fun finish (sds, ac) =
+ case sds of
+ [] => ac
+ | _ =>
+ let
+ val t =
+ Topdec.makeRegion
+ (Topdec.Strdec (Strdec.makeRegion
+ (Strdec.Seq (rev sds), Region.bogus)),
+ Region.bogus)
+ in
+ t :: ac
+ end
+ fun loop (ds, sds, ac) =
+ case ds of
+ [] => finish (sds, ac)
+ | d :: ds =>
+ case Topdec.node d of
+ Topdec.Strdec d => loop (ds, d :: sds, ac)
+ | _ => loop (ds, [], d :: finish (sds, ac))
+ in
+ T (rev (loop (ds, [], [])))
+ end
+
fun size (T ds): int =
let
open Dec Exp Strexp Strdec Topdec
@@ -360,7 +439,7 @@
(Vector.foreach (vbs, exp o #exp)
; Vector.foreach (rvbs, match o #match))
| Fun (_, ds) =>
- Vector.foreach (ds, fn {clauses, ...} =>
+ Vector.foreach (ds, fn clauses =>
Vector.foreach (clauses, exp o #body))
| Abstype {body, ...} => dec body
| Exception cs => Vector.foreach (cs, fn _ => inc ())
@@ -369,28 +448,37 @@
| _ => ()
and exp (e: Exp.t): unit =
- (inc ();
- case Exp.node e of
- Fn m => match m
- | FlatApp es => exps es
- | Exp.App (e, e') => (exp e; exp e')
- | Case (e, m) => (exp e; match m)
- | Exp.Let (d, e) => (dec d; exp e)
- | Exp.Seq es => exps es
- | Record r => Record.foreach (r, exp)
- | List es => List.foreach (es, exp)
- | Constraint (e, _) => exp e
- | Handle (e, m) => (exp e; match m)
- | Raise {exn, ...} => exp exn
- | If (e1, e2, e3) => (exp e1; exp e2; exp e3)
- | Andalso (e1, e2) => (exp e1; exp e2)
- | Orelse (e1, e2) => (exp e1; exp e2)
- | While {test, expr} => (exp test; exp expr)
- | _ => ())
+ let
+ val _ = inc ()
+ datatype z = datatype Exp.node
+ in
+ case Exp.node e of
+ Andalso (e1, e2) => (exp e1; exp e2)
+ | App (e, e') => (exp e; exp e')
+ | Case (e, m) => (exp e; match m)
+ | Constraint (e, _) => exp e
+ | FlatApp es => exps es
+ | Fn m => match m
+ | Handle (e, m) => (exp e; match m)
+ | If (e1, e2, e3) => (exp e1; exp e2; exp e3)
+ | Let (d, e) => (dec d; exp e)
+ | List es => Vector.foreach (es, exp)
+ | Orelse (e1, e2) => (exp e1; exp e2)
+ | Raise exn => exp exn
+ | Record r => Record.foreach (r, exp)
+ | Seq es => exps es
+ | While {test, expr} => (exp test; exp expr)
+ | _ => ()
+ end
and exps es = Vector.foreach (es, exp)
- and match (Match.T {rules, ...}) = Vector.foreach (rules, exp o #2)
+ and match m =
+ let
+ val Match.T rules = Match.node m
+ in
+ Vector.foreach (rules, exp o #2)
+ end
fun strdec d =
case Strdec.node d of
1.4 +16 -10 mlton/mlton/ast/ast.sig
Index: ast.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ast.sig 24 Nov 2002 01:19:43 -0000 1.3
+++ ast.sig 9 Oct 2003 18:17:30 -0000 1.4
@@ -7,6 +7,10 @@
*)
signature AST_STRUCTS =
sig
+ structure Record: RECORD
+ structure SortedRecord: RECORD
+ sharing Record.Field = SortedRecord.Field
+ structure Tyvar: TYVAR
end
signature AST =
@@ -90,11 +94,11 @@
type t
datatype node =
- Var of Longstrid.t
- | Struct of strdec
+ App of Fctid.t * t
| Constrained of t * SigConst.t
- | App of Fctid.t * t
| Let of strdec * t
+ | Struct of strdec
+ | Var of Longstrid.t
include WRAPPED sharing type node' = node
sharing type obj = t
@@ -112,16 +116,17 @@
sig
type t
datatype node =
- Structure of {name: Strid.t,
+ Core of Dec.t
+ | Local of t * t
+ | Seq of t list
+ | Structure of {name: Strid.t,
def: Strexp.t,
constraint: SigConst.t} list
- | Seq of t list
- | Local of t * t
- | Core of Dec.t
include WRAPPED sharing type node' = node
sharing type obj = t
+ val coalesce: t -> t
val core: Dec.t -> t
val layout: t -> Layout.t
val locall: t * t -> t
@@ -147,12 +152,12 @@
sig
type t
datatype node =
- Strdec of Strdec.t
- | Signature of (Sigid.t * Sigexp.t) list
- | Functor of {name: Fctid.t,
+ Functor of {name: Fctid.t,
arg: FctArg.t,
result: SigConst.t,
body: Strexp.t} list
+ | Signature of (Sigid.t * Sigexp.t) list
+ | Strdec of Strdec.t
include WRAPPED sharing type node' = node
sharing type obj = t
@@ -172,6 +177,7 @@
datatype t = T of Topdec.t list
val append: t * t -> t
+ val coalesce: t -> t
val empty: t
val size: t -> int
val layout: t -> Layout.t
1.3 +1 -1 mlton/mlton/ast/prim-cons.fun
Index: prim-cons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-cons.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- prim-cons.fun 10 Apr 2002 07:02:18 -0000 1.2
+++ prim-cons.fun 9 Oct 2003 18:17:30 -0000 1.3
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor PrimCons(S: PRIM_CONS_STRUCTS) :> PRIM_CONS where type con = S.t =
+functor PrimCons (S: PRIM_CONS_STRUCTS): PRIM_CONS =
struct
open S
1.9 +42 -6 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- prim-tycons.fun 11 Sep 2003 00:51:07 -0000 1.8
+++ prim-tycons.fun 9 Oct 2003 18:17:30 -0000 1.9
@@ -56,14 +56,34 @@
(word16, W16),
(word32, W32),
(word64, W64)]
+
+datatype z = datatype Kind.t
val prims =
- [array, arrow, bool, char, exn,
- int8, int16, int32, int64, intInf,
- list, pointer, preThread,
- real32, real64,
- reff, thread, tuple, vector, weak,
- word8, word16, word32, word64]
+ [(array, Arity 1),
+ (arrow, Arity 2),
+ (bool, Arity 0),
+ (char, Arity 0),
+ (exn, Arity 0),
+ (int8, Arity 0),
+ (int16, Arity 0),
+ (int32, Arity 0),
+ (int64, Arity 0),
+ (intInf, Arity 0),
+ (list, Arity 1),
+ (pointer, Arity 0),
+ (preThread, Arity 0),
+ (real32, Arity 0),
+ (real64, Arity 0),
+ (reff, Arity 1),
+ (thread, Arity 0),
+ (tuple, Nary),
+ (vector, Arity 1),
+ (weak, Arity 1),
+ (word8, Arity 0),
+ (word16, Arity 0),
+ (word32, Arity 0),
+ (word64, Arity 0)]
val int =
fn I8 => int8
@@ -92,6 +112,22 @@
val isRealX = is [real32, real64]
val isWordX = is [word8, word16, word32, word64]
end
+
+fun layoutApp (c, ts) =
+ let
+ val tuple' = tuple
+ open Layout
+ in
+ if equals (c, arrow)
+ then seq [Vector.sub (ts, 0), str " -> ", Vector.sub (ts, 1)]
+ else if equals (c, tuple')
+ then tuple (Vector.toList ts)
+ else
+ case Vector.length ts of
+ 0 => layout c
+ | 1 => seq [Vector.sub (ts, 0), str " ", layout c]
+ | _ => seq [tuple (Vector.toList ts), str " ", layout c]
+ end
end
1.7 +6 -2 mlton/mlton/ast/prim-tycons.sig
Index: prim-tycons.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- prim-tycons.sig 23 Jun 2003 04:58:55 -0000 1.6
+++ prim-tycons.sig 9 Oct 2003 18:17:30 -0000 1.7
@@ -8,6 +8,7 @@
signature PRIM_TYCONS_STRUCTS =
sig
structure IntSize: INT_SIZE
+ structure Kind: TYCON_KIND
structure RealSize: REAL_SIZE
structure WordSize: WORD_SIZE
@@ -15,14 +16,16 @@
val fromString: string -> t
val equals: t * t -> bool
+ val layout: t -> Layout.t
end
signature PRIM_TYCONS =
sig
structure IntSize: INT_SIZE
+ structure Kind: TYCON_KIND
structure RealSize: REAL_SIZE
structure WordSize: WORD_SIZE
-
+
type tycon
val array: tycon
@@ -39,10 +42,11 @@
val isIntX: tycon -> bool
val isRealX: tycon -> bool
val isWordX: tycon -> bool
+ val layoutApp: tycon * Layout.t vector -> Layout.t
val list: tycon
val pointer: tycon
val preThread: tycon
- val prims: tycon list
+ val prims: (tycon * Kind.t) list
val real: RealSize.t -> tycon
val reals: (tycon * RealSize.t) list
val reff: tycon
1.5 +8 -1 mlton/mlton/ast/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/sources.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sources.cm 23 Jun 2003 04:58:55 -0000 1.4
+++ sources.cm 9 Oct 2003 18:17:30 -0000 1.5
@@ -8,20 +8,25 @@
Group
signature AST
-signature AST_ID
+signature FIELD
signature INT_SIZE
signature LONGID
signature PRIM_CONS
signature PRIM_TYCONS
signature REAL_SIZE
signature RECORD
+signature TYCON_KIND
signature TYVAR
signature WORD_SIZE
signature WRAPPED
functor Ast
+functor Field
functor PrimCons
functor PrimTycons
+functor Record
+functor TyconKind
+functor Tyvar
is
@@ -52,6 +57,8 @@
real-size.sig
record.fun
record.sig
+tycon-kind.fun
+tycon-kind.sig
tyvar.fun
tyvar.sig
word-size.fun
1.5 +1 -1 mlton/mlton/ast/tyvar.fun
Index: tyvar.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/tyvar.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- tyvar.fun 10 Apr 2002 07:02:18 -0000 1.4
+++ tyvar.fun 9 Oct 2003 18:17:30 -0000 1.5
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor Tyvar (S: TYVAR_STRUCTS) :> TYVAR =
+functor Tyvar (S: TYVAR_STRUCTS): TYVAR =
struct
open S
1.1 mlton/mlton/ast/tycon-kind.fun
Index: tycon-kind.fun
===================================================================
functor TyconKind (S: TYCON_KIND_STRUCTS): TYCON_KIND =
struct
open S
datatype t =
Arity of int
| Nary
val layout =
fn Arity n => Int.layout n
| Nary => Layout.str "n-ary"
end
1.1 mlton/mlton/ast/tycon-kind.sig
Index: tycon-kind.sig
===================================================================
type int = Int.t
signature TYCON_KIND_STRUCTS =
sig
end
signature TYCON_KIND =
sig
include TYCON_KIND_STRUCTS
datatype t =
Arity of int
| Nary
val layout: t -> Layout.t
end
1.11 +4 -31 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- atoms.fun 21 Jul 2003 21:53:50 -0000 1.10
+++ atoms.fun 9 Oct 2003 18:17:31 -0000 1.11
@@ -14,32 +14,12 @@
structure SourceInfo = SourceInfo ()
structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
- structure Var = Var (structure AstId = Ast.Var)
- structure Tycon = Tycon (structure AstId = Ast.Tycon
- structure IntSize = IntSize
+ structure Var = Var ()
+ structure Tycon = Tycon (structure IntSize = IntSize
structure RealSize = RealSize
structure WordSize = WordSize)
fun f (x: IntSize.t): Tycon.IntSize.t = x
- structure Type =
- Type (structure Ast = Ast
- structure IntSize = IntSize
- structure Record = Ast.SortedRecord
- structure Tyvar = Ast.Tyvar
- structure Tycon = Tycon
- structure WordSize = WordSize)
- structure Scheme: SCHEME =
- struct
- structure Arg =
- struct
- structure Tycon = Tycon
- structure Tyvar = Ast.Tyvar
- structure Type = Type
- end
- structure S = GenericScheme (Arg)
- open S Arg
- end
- structure Con = Con (structure AstId = Ast.Con
- structure Var = Var)
+ structure Con = Con (structure Var = Var)
structure CType = CType (structure IntSize = IntSize
structure RealSize = RealSize
structure WordSize = WordSize)
@@ -49,8 +29,7 @@
structure IntX = IntX (structure IntSize = IntSize)
structure RealX = RealX (structure RealSize = RealSize)
structure WordX = WordX (structure WordSize = WordSize)
- structure Const = Const (structure Ast = Ast
- structure IntX = IntX
+ structure Const = Const (structure IntX = IntX
structure RealX = RealX
structure WordX = WordX)
structure Prim = Prim (structure CFunction = CFunction
@@ -58,14 +37,8 @@
structure Con = Con
structure Const = Const
structure IntSize = IntSize
- structure Longid = Ast.Longvid
structure RealSize = RealSize
- structure Scheme = Scheme
- structure Type = Type
structure WordSize = WordSize)
- structure Record = Ast.Record
- structure SortedRecord = Ast.SortedRecord
- structure Tyvar = Ast.Tyvar
structure Tyvars = UnorderedSet (Tyvar)
structure Vars = UnorderedSet (Var)
structure Cons = UnorderedSet (Con)
1.11 +16 -16 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- atoms.sig 21 Jul 2003 21:53:50 -0000 1.10
+++ atoms.sig 9 Oct 2003 18:17:31 -0000 1.11
@@ -7,10 +7,14 @@
*)
signature ATOMS_STRUCTS =
sig
- structure Ast: AST
+ structure Field: FIELD
structure IntSize: INT_SIZE
structure RealSize: REAL_SIZE
+ structure Record: RECORD
+ structure SortedRecord: RECORD
+ structure Tyvar: TYVAR
structure WordSize: WORD_SIZE
+ sharing Field = Record.Field = SortedRecord.Field
end
signature ATOMS' =
@@ -27,39 +31,26 @@
structure Prim: PRIM
structure ProfileExp: PROFILE_EXP
structure RealX: REAL_X
- structure Record: RECORD
- structure Scheme: SCHEME
- structure SortedRecord: RECORD
structure SourceInfo: SOURCE_INFO
structure Tycon: TYCON
structure Tycons: SET
- structure Tyvar: TYVAR
structure Var: VAR
structure Vars: SET
structure Tyvars: SET
structure WordX: WORD_X
- sharing Ast = Const.Ast = Prim.Type.Ast
- sharing Ast.Con = Con.AstId
- sharing Ast.Tycon = Tycon.AstId
- sharing Ast.Tyvar = Scheme.Tyvar
- sharing Ast.Var = Var.AstId
sharing CFunction = Ffi.CFunction = Prim.CFunction
sharing CFunction.CType = CType = Ffi.CType = Prim.CType
sharing Con = Prim.Con
sharing Const = Prim.Const
+ sharing Field = Record.Field = SortedRecord.Field
sharing IntSize = CType.IntSize = IntX.IntSize = Prim.IntSize =
Tycon.IntSize
sharing IntX = Const.IntX
sharing RealSize = CType.RealSize = Prim.RealSize = RealX.RealSize
= Tycon.RealSize
sharing RealX = Const.RealX
- sharing Record = Ast.Record
- sharing Scheme = Prim.Scheme
- sharing SortedRecord = Ast.SortedRecord
sharing SourceInfo = ProfileExp.SourceInfo
- sharing Tycon = Scheme.Tycon
- sharing Tyvar = Ast.Tyvar
sharing WordSize = CType.WordSize = Prim.WordSize = Tycon.WordSize
= WordX.WordSize
sharing WordX = Const.WordX
@@ -75,14 +66,21 @@
include ATOMS'
- sharing Ast = Atoms.Ast
+ sharing CFunction = Atoms.CFunction
+ sharing CType = Atoms.CType
sharing Con = Atoms.Con
sharing Cons = Atoms.Cons
sharing Const = Atoms.Const
sharing Ffi = Atoms.Ffi
+ sharing Field = Atoms.Field
+ sharing IntSize = Atoms.IntSize
+ sharing IntX = Atoms.IntX
sharing Prim = Atoms.Prim
sharing ProfileExp = Atoms.ProfileExp
+ sharing RealSize = Atoms.RealSize
+ sharing RealX = Atoms.RealX
sharing Record = Atoms.Record
+ sharing SortedRecord = Atoms.SortedRecord
sharing SourceInfo = Atoms.SourceInfo
sharing Tycon = Atoms.Tycon
sharing Tycons = Atoms.Tycons
@@ -90,4 +88,6 @@
sharing Tyvars = Atoms.Tyvars
sharing Var = Atoms.Var
sharing Vars = Atoms.Vars
+ sharing WordSize = Atoms.WordSize
+ sharing WordX = Atoms.WordX
end
1.3 +1 -1 mlton/mlton/atoms/c-type.sig
Index: c-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- c-type.sig 25 Jul 2003 20:14:46 -0000 1.2
+++ c-type.sig 9 Oct 2003 18:17:31 -0000 1.3
@@ -29,7 +29,7 @@
val equals: t * t -> bool
val isPointer: t -> bool
val memo: (t -> 'a) -> t -> 'a
- (* name: R{32,64} I[8,16,32,64] P W[8,16,32] *)
+ (* name: R{32,64} I[8,16,32,64] P W[8,16,32,64] *)
val name: t -> string
val pointer: t
val layout: t -> Layout.t
1.12 +0 -21 mlton/mlton/atoms/const.fun
Index: const.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- const.fun 12 Sep 2003 01:22:55 -0000 1.11
+++ const.fun 9 Oct 2003 18:17:31 -0000 1.12
@@ -11,11 +11,6 @@
open S
local
- open Ast
-in
- structure Aconst = Const
-end
-local
open IntX
in
structure IntSize = IntSize
@@ -93,22 +88,6 @@
| Word8Vector v => String.hash (Word8.vectorToString v)
end
-fun 'a toAst (make: Ast.Const.t -> 'a, constrain: 'a * Ast.Type.t -> 'a) c =
- let
- val aconst =
- case c of
- Int i => Aconst.Int (IntX.toIntInf i)
- | IntInf i => Aconst.Int i
- | Real r => Aconst.Real (RealX.toString r)
- | Word w => Aconst.Word (WordX.toIntInf w)
- | Word8Vector v => Aconst.String (Word8.vectorToString v)
- in
- make (Ast.Const.makeRegion (aconst, Region.bogus))
- end
-
-val toAstExp = toAst (Ast.Exp.const, Ast.Exp.constraint)
-val toAstPat = toAst (Ast.Pat.const, Ast.Pat.constraint)
-
fun equals (c, c') =
case (c, c') of
(Int i, Int i') => IntX.equals (i, i')
1.9 +0 -3 mlton/mlton/atoms/const.sig
Index: const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- const.sig 2 Jul 2003 15:08:16 -0000 1.8
+++ const.sig 9 Oct 2003 18:17:31 -0000 1.9
@@ -10,7 +10,6 @@
signature CONST_STRUCTS =
sig
- structure Ast: AST
structure IntX: INT_X
structure RealX: REAL_X
structure WordX: WORD_X
@@ -41,8 +40,6 @@
val layout: t -> Layout.t
val real: RealX.t -> t
val string: string -> t
- val toAstExp: t -> Ast.Exp.t
- val toAstPat: t -> Ast.Pat.t
val toString: t -> string
val word: WordX.t -> t
val word8: Word8.t -> t
1.8 +5 -45 mlton/mlton/atoms/hash-type.fun
Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- hash-type.fun 23 Jun 2003 04:58:55 -0000 1.7
+++ hash-type.fun 9 Oct 2003 18:17:31 -0000 1.8
@@ -47,7 +47,7 @@
end
open Dest
- fun deconOpt t =
+ fun deConOpt t =
case dest t of
Con x => SOME x
| _ => NONE
@@ -86,18 +86,10 @@
in res
end
- local
- structure Atype = Ast.Type
- in
- fun toAst t =
- hom {ty = t,
- var = Atype.var,
- con = fn (c, ts) =>
- if Tycon.equals (c, Tycon.tuple) then Atype.tuple ts
- else Atype.con (Tycon.toAst c, ts)}
- end
-
- val layout = Ast.Type.layout o toAst
+ fun layout (ty: t): Layout.t =
+ hom {con = Tycon.layoutApp,
+ ty = ty,
+ var = Tyvar.layout}
val toString = Layout.toString o layout
@@ -165,22 +157,6 @@
structure Plist = PropertyList
-local structure Type = Ast.Type
-in
- fun toAst (t: t): Type.t =
- case dest t of
- Var a => Type.var a
- | Con (c, ts) =>
- let
- val ts = Vector.map (ts, toAst)
- in
- if Tycon.equals (c, Tycon.tuple) then Type.tuple ts
- else Type.con (Tycon.toAst c, ts)
- end
-end
-
-fun optionToAst z = Option.map (z, toAst)
-
fun ofConst c =
let
datatype z = datatype Const.t
@@ -237,22 +213,6 @@
; Layout.output (lay, out)
; print "\n"
; raise TypeError)
-end
-
-local
- structure Ptype = Prim.Type
-in
- fun fromPrims ts = Vector.map (ts, fromPrim)
- and fromPrim t =
- case t of
- Ptype.Var a => var a
- | Ptype.Con (c, ts) => con (c, fromPrims ts)
- | Ptype.Record r =>
- con (Tycon.tuple, fromPrims (SortedRecord.range r))
-
- fun toPrim t = hom {ty = t,
- var = Ptype.var,
- con = Ptype.con}
end
fun tycon t =
1.5 +0 -5 mlton/mlton/atoms/hash-type.sig
Index: hash-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- hash-type.sig 23 Jun 2003 04:58:55 -0000 1.4
+++ hash-type.sig 9 Oct 2003 18:17:31 -0000 1.5
@@ -32,7 +32,6 @@
val equals: t * t -> bool
(* for reporting type errors *)
val error: string * Layout.t -> 'a
- val fromPrim: Prim.Type.t -> t
val hash: t -> Word.t
val hom: {ty: t,
var: Tyvar.t -> 'a,
@@ -49,7 +48,6 @@
-> {hom: t -> 'a,
destroy: unit -> unit}
val ofConst: Const.t -> t
- val optionToAst: t option -> Ast.Type.t option
val plist: t -> PropertyList.t
val stats: unit -> Layout.t
val string: t (* synonym for word8Vector *)
@@ -58,9 +56,6 @@
* The ai's are not required to contain every free variable in t
*)
val substitute: t * (Tyvar.t * t) vector -> t
- (* conversion to Ast *)
- val toAst: t -> Ast.Type.t
- val toPrim: t -> Prim.Type.t
val toString: t -> string
val tycon: t -> Tycon.t
val var: Tyvar.t -> t
1.6 +0 -10 mlton/mlton/atoms/id.fun
Index: id.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- id.fun 7 Dec 2002 02:21:51 -0000 1.5
+++ id.fun 9 Oct 2003 18:17:31 -0000 1.6
@@ -122,11 +122,6 @@
open I
end
-val fromAst = newString o AstId.toString
-fun fromAsts l = List.map (l, fromAst)
-fun toAst id = AstId.fromString (toString id, Region.bogus)
-fun toAsts l = List.map (l, toAst)
-
end
functor HashId (S: ID_STRUCTS): HASH_ID =
@@ -228,11 +223,6 @@
printName = ref NONE,
hash = Random.word (),
plist = Plist.new ()}
-
-val fromAst = newString o AstId.toString
-fun fromAsts l = List.map (l, fromAst)
-fun toAst id = AstId.fromString (toString id, Region.bogus)
-fun toAsts l = List.map (l, toAst)
val clear = Plist.clear o plist
1.4 +0 -7 mlton/mlton/atoms/id.sig
Index: id.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- id.sig 7 Dec 2002 02:21:51 -0000 1.3
+++ id.sig 9 Oct 2003 18:17:31 -0000 1.4
@@ -33,18 +33,11 @@
signature ID_STRUCTS =
sig
include ID_NO_AST_STRUCTS
- structure AstId: AST_ID
end
signature ID =
sig
include ID_NO_AST
- structure AstId: AST_ID
-
- val fromAst: AstId.t -> t
- val fromAsts: AstId.t list -> t list
- val toAst: t -> AstId.t
- val toAsts: t list -> AstId.t list
end
signature HASH_ID =
1.4 +2 -2 mlton/mlton/atoms/int-x.fun
Index: int-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/int-x.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- int-x.fun 12 Sep 2003 01:22:55 -0000 1.3
+++ int-x.fun 9 Oct 2003 18:17:31 -0000 1.4
@@ -4,10 +4,10 @@
open S
datatype z = datatype IntSize.t
-
+
datatype t = T of {int: IntInf.t,
size: IntSize.t}
-
+
local
fun make f (T r) = f r
in
1.64 +104 -248 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- prim.fun 12 Sep 2003 01:22:55 -0000 1.63
+++ prim.fun 9 Oct 2003 18:17:31 -0000 1.64
@@ -25,12 +25,6 @@
structure IntX = IntX
structure WordX = WordX
end
-local
- open Type
-in
- structure Tycon = Tycon
- structure Tyvar = Tyvar
-end
structure Kind =
struct
@@ -50,7 +44,6 @@
| Array_sub (* backend *)
| Array_toVector (* backend *)
| Array_update (* backend *)
- | BuildConstant of string (* type inference *)
| C_CS_charArrayToWord8Array (* type inference *)
| Char_chr (* type inference *)
| Char_ge (* type inference *)
@@ -59,7 +52,6 @@
| Char_lt (* type inference *)
| Char_ord (* type inference *)
| Char_toWord8 (* type inference *)
- | Constant of string (* type inference *)
| Cpointer_isNull (* codegen *)
| Exn_extra (* implement exceptions *)
| Exn_keepHistory (* a compile-time boolean *)
@@ -459,9 +451,7 @@
fun toString n =
case n of
- BuildConstant s => s
- | Constant s => s
- | FFI f => CFunction.name f
+ FFI f => CFunction.name f
| FFI_Symbol {name, ...} => name
| _ => (case List.peek (strings, fn (n', _, _) => n = n') of
NONE => Error.bug "Prim.toString missing name"
@@ -473,17 +463,13 @@
datatype t =
T of {name: Name.t,
nameString: string,
- scheme: Scheme.t,
- kind: Kind.t,
- numArgs: int option}
+ kind: Kind.t}
local
fun make sel (T r) = sel r
in
val kind = make #kind
val name = make #name
- val numArgs = make #numArgs
- val scheme = make #scheme
val toString = make #nameString
end
@@ -501,270 +487,136 @@
val mayOverflow = Name.mayOverflow o name
val mayRaise = Name.mayRaise o name
-structure CType =
- struct
- open CType
+fun make (n: Name.t, k: Kind.t): t =
+ T {kind = k,
+ name = n,
+ nameString = Name.toString n}
- val toType =
- memo (fn t =>
- case t of
- Int s => Type.int s
- | Pointer => Type.pointer
- | Real s => Type.real s
- | Word s => Type.word s)
- end
+fun equals (p, p') = Name.equals (name p, name p')
-structure Scheme =
- struct
- open Scheme
-
- fun numArgs (s: t): int option =
- case Type.dearrowOpt (ty s) of
- NONE => NONE
- | SOME (t, _) => (case Type.detupleOpt t of
- NONE => SOME 1
- | SOME ts => SOME (Vector.length ts))
+val new: Name.t -> t =
+ fn n =>
+ let
+ val k =
+ case n of
+ Name.FFI _ => Kind.SideEffect
+ | Name.FFI_Symbol _ => Kind.DependsOnState
+ | _ => (case List.peek (Name.strings, fn (n', _, _) => n = n') of
+ NONE => Error.bug (concat ["strange name: ",
+ Name.toString n])
+ | SOME (_, k, _) => k)
+ in
+ make (n, k)
end
-fun new (n: Name.t, k: Kind.t, s: Scheme.t): t =
- T {
- kind = k,
- name = n,
- nameString = Name.toString n,
- numArgs = Scheme.numArgs s,
- scheme = s
- }
+val array = new Name.Array_array
+val assign = new Name.Ref_assign
+val bogus = new Name.MLton_bogus
+val bug = new Name.MLton_bug
+val deref = new Name.Ref_deref
+val deserialize = new Name.MLton_deserialize
+val eq = new Name.MLton_eq
+val equal = new Name.MLton_equal
+val gcCollect = new Name.GC_collect
+val intInfEqual = new Name.IntInf_equal
+val intInfNeg = new Name.IntInf_neg
+val intInfNotb = new Name.IntInf_notb
+val reff = new Name.Ref_ref
+val serialize = new Name.MLton_serialize
+val vectorLength = new Name.Vector_length
+val vectorSub = new Name.Vector_sub
local
- fun make f (name: string, s: Scheme.t): t =
- new (f name, Kind.Functional, s)
+ fun make n = IntSize.memoize (new o n)
in
- val buildConstant = make Name.BuildConstant
- val constant = make Name.Constant
+ val intAdd = make Name.Int_add
+ val intAddCheck = make Name.Int_addCheck
+ val intEqual = make Name.Int_equal
+ val intNeg = make Name.Int_neg
+ val intNegCheck = make Name.Int_negCheck
+ val intMul = make Name.Int_mul
+ val intMulCheck = make Name.Int_mulCheck
+ val intSub = make Name.Int_sub
+ val intSubCheck = make Name.Int_subCheck
end
-fun equals (p, p') = Name.equals (name p, name p')
-
local
- val newPrim = new
- open Type Scheme
- val new = newPrim
- val --> = arrow
- infix -->
+ fun make n = WordSize.memoize (new o n)
+in
+ val wordAdd = make Name.Word_add
+ val wordAddCheck = make Name.Word_addCheck
+ val wordAndb = make Name.Word_andb
+ val wordEqual = make Name.Word_equal
+ val wordGe = make Name.Word_ge
+ val wordGt = make Name.Word_gt
+ val wordLe = make Name.Word_le
+ val wordLt = make Name.Word_lt
+ val wordMul = make Name.Word_mul
+ val wordMulCheck = make Name.Word_mulCheck
+ val wordNeg = make Name.Word_neg
+ val wordNotb = make Name.Word_notb
+ val wordRshift = make Name.Word_rshift
+ val wordSub = make Name.Word_sub
+end
- val new =
- fn (n: Name.t, s: Scheme.t) =>
+local
+ fun make (name, memo, memo') =
let
- val k =
- case n of
- Name.FFI _ => Kind.SideEffect
- | Name.FFI_Symbol _ => Kind.DependsOnState
- | _ => (case List.peek (Name.strings, fn (n', _, _) => n = n') of
- NONE => Error.bug (concat ["strange name: ",
- Name.toString n])
- | SOME (_, k, _) => k)
+ val f = memo (fn s => memo' (fn s' => name (s, s')))
in
- new (n, k, s)
+ fn (s, s') => new (f s s')
end
- val tuple = tuple o Vector.fromList
+ val int = IntSize.memoize
+ val word = WordSize.memoize
in
- val array = new (Name.Array_array, make1 (fn a => int I32 --> array a))
- val assign =
- new (Name.Ref_assign, make1 (fn a => tuple [reff a, a] --> unit))
- val bogus = new (Name.MLton_bogus, make1 (fn a => a))
- val bug = new (Name.MLton_bug, make0 (word8Vector --> unit))
- val deref = new (Name.Ref_deref, make1 (fn a => reff a --> a))
- val deserialize =
- new (Name.MLton_deserialize, make1 (fn a => vector (word W8) --> a))
- val eq = new (Name.MLton_eq, makeEqual1 (fn a => tuple [a, a] --> bool))
- val equal = new (Name.MLton_equal, makeEqual1 (fn a => tuple [a, a] --> bool))
- val gcCollect = new (Name.GC_collect, make0 (tuple [word W32, bool] --> unit))
- val reff = new (Name.Ref_ref, make1 (fn a => a --> reff a))
- val serialize = new (Name.MLton_serialize,
- make1 (fn a => a --> vector (word W8)))
- val vectorLength =
- new (Name.Vector_length, make1 (fn a => vector a --> int I32))
- val vectorSub =
- new (Name.Vector_sub, make1 (fn a => tuple [vector a, int I32] --> a))
-
- fun new0 (name, ty) = new (name, make0 ty)
-
- fun intEqual s = new0 (Name.Int_equal s, tuple [int s, int s] --> bool)
- fun intNeg s = new0 (Name.Int_neg s, int s --> int s)
- fun intNegCheck s = new0 (Name.Int_negCheck s, int s --> int s)
- val intInfNeg =
- new0 (Name.IntInf_neg, tuple [intInf, word W32] --> intInf)
- val intInfNotb =
- new0 (Name.IntInf_notb, tuple [intInf, word W32] --> intInf)
- val intInfEqual = new0 (Name.IntInf_equal, tuple [intInf, intInf] --> bool)
-
- fun wordEqual s = new0 (Name.Word_equal s, tuple [word s, word s] --> bool)
- fun wordNotb (s: WordSize.t) = new0 (Name.Word_notb s, word s --> word s)
- fun wordNeg (s: WordSize.t) = new0 (Name.Word_neg s, word s --> word s)
-
- local
- fun make n =
- IntSize.memoize (fn s => new0 (n s, tuple [int s, int s] --> int s))
- in
- val intAdd = make Name.Int_add
- val intAddCheck = make Name.Int_addCheck
- val intMul = make Name.Int_mul
- val intMulCheck = make Name.Int_mulCheck
- val intSub = make Name.Int_sub
- val intSubCheck = make Name.Int_subCheck
- end
-
- local
- fun make n =
- WordSize.memoize
- (fn s => new0 (n s, tuple [word s, word s] --> word s))
- in
- val wordAdd = make Name.Word_add
- val wordAddCheck = make Name.Word_addCheck
- val wordAndb = make Name.Word_andb
- val wordMul = make Name.Word_mul
- val wordMulCheck = make Name.Word_mulCheck
- val wordRshift = make Name.Word_rshift
- val wordSub = make Name.Word_sub
- end
-
- local
- fun make n =
- WordSize.memoize
- (fn s => new0 (n s, tuple [word s, word s] --> bool))
- in
- val wordGe = make Name.Word_ge
- val wordGt = make Name.Word_gt
- val wordLe = make Name.Word_le
- val wordLt = make Name.Word_lt
- end
-
- local
- fun make (name, (ty, memo), (ty', memo')) =
- let
- val f =
- memo (fn s => memo' (fn s' => new0 (name (s, s'),
- ty s --> ty' s')))
- in
- fn (s, s') => f s s'
- end
- val int = (int, IntSize.memoize)
- val word = (word, WordSize.memoize)
- in
- val intToWord = make (Name.Int_toWord, int, word)
- val wordToInt = make (Name.Word_toInt, word, int)
- val wordToIntX = make (Name.Word_toIntX, word, int)
- end
-
- fun ffi (f: CFunction.t, s: Scheme.t) =
- new (Name.FFI f, s)
-
- fun newNullary f = new0 (Name.FFI f, unit --> unit)
-
- val allocTooLarge = newNullary CFunction.allocTooLarge
-
- fun ffiSymbol (z as {ty, ...}) =
- new (Name.FFI_Symbol z, Scheme.fromType (CType.toType ty))
+ val intToWord = make (Name.Int_toWord, int, word)
+ val wordToInt = make (Name.Word_toInt, word, int)
+ val wordToIntX = make (Name.Word_toIntX, word, int)
end
+
+val ffi = new o Name.FFI
+
+fun newNullary f = new (Name.FFI f)
+
+val allocTooLarge = newNullary CFunction.allocTooLarge
+
+fun ffiSymbol z = new (Name.FFI_Symbol z)
-val new: string * Scheme.t -> t =
- fn (name, scheme) =>
+val new: string -> t =
+ fn name =>
let
val (name, kind) =
case List.peek (Name.strings, fn (_, _, s) => s = name) of
NONE => Error.bug (concat ["unknown primitive: ", name])
| SOME (n, k, _) => (n, k)
in
- new (name, kind, scheme)
+ make (name, kind)
end
-val new = Trace.trace2 ("Prim.new", String.layout, Scheme.layout, layout) new
-
-fun 'a checkApp {prim, targs, args,
- con, detupleOpt, dearrowOpt, equals, isUnit}
- : 'a option =
- let
- val error = NONE
- val Scheme.T {tyvars, ty} = scheme prim
- fun show s =
- if true
- then ()
- else Out.print s
- in
- if Vector.length targs <> Vector.length tyvars
- then
- (show (concat ["primapp error, #targs=",
- Int.toString (Vector.length targs),
- ", #tyvars=",
- Int.toString (Vector.length tyvars), "\n"])
- ; error)
- else
- let
- val con = fn (c, ts) =>
- let
- val c = if Tycon.equals (c, Tycon.char)
- then Tycon.word W8
- else c
- in
- con (c, ts)
- end
- val env = Vector.zip (tyvars, targs)
- fun var a =
- case Vector.peek (env, fn (a', _) => Tyvar.equals (a, a')) of
- NONE => Error.bug "prim scheme with free tyvar"
- | SOME (_, t) => t
- val ty = Type.hom {ty = ty, var = var, con = con}
- in
- case numArgs prim of
- NONE => if Vector.isEmpty args
- then SOME ty
- else (show "primapp error, no numArgs\n"
- ; error)
- | SOME n =>
- case dearrowOpt ty of
- NONE => error
- | SOME (argType, result) =>
- case (n, Vector.length args) of
- (0, 0) => SOME result
- | (1, 1) =>
- if equals (argType, Vector.sub (args, 0))
- then SOME result
- else error
- | _ =>
- case detupleOpt argType of
- NONE => error
- | SOME argTypes =>
- if Vector.equals (args, argTypes, equals)
- then SOME result
- else error
- end
- end
+val new = Trace.trace ("Prim.new", String.layout, layout) new
-fun returnsBool p =
- case Type.dearrowOpt (Scheme.ty (scheme p)) of
- SOME (_, Type.Con (tycon, _)) => Tycon.equals (tycon, Tycon.bool)
- | _ => false
-
-fun 'a extractTargs {prim, args, result,
- dearray,
- dearrow: 'a -> 'a * 'a,
- deref,
- devector,
- deweak} =
+fun 'a extractTargs {args: 'a vector,
+ deArray: 'a -> 'a,
+ deArrow: 'a -> 'a * 'a,
+ deRef: 'a -> 'a,
+ deVector: 'a -> 'a,
+ deWeak: 'a -> 'a,
+ prim: t,
+ result: 'a} =
let
val one = Vector.new1
fun arg i = Vector.sub (args, i)
datatype z = datatype Name.t
in
case name prim of
- Array_array => one (dearray result)
- | Array_array0Const => one (dearray result)
+ Array_array => one (deArray result)
+ | Array_array0Const => one (deArray result)
| Array_sub => one result
- | Array_toVector => one (dearray (arg 0))
+ | Array_toVector => one (deArray (arg 0))
| Array_update => one (arg 2)
- | Array_length => one (dearray (arg 0))
+ | Array_length => one (deArray (arg 0))
| Exn_extra => one result
- | Exn_setExtendExtra => one (#2 (dearrow (arg 0)))
+ | Exn_setExtendExtra => one (#2 (deArrow (arg 0)))
| Exn_setInitExtra => one (arg 0)
| FFI_getPointer => one result
| FFI_setPointer => one (arg 0)
@@ -773,18 +625,22 @@
| MLton_eq => one (arg 0)
| MLton_equal => one (arg 0)
| MLton_serialize => one (arg 0)
- | MLton_size => one (deref (arg 0))
+ | MLton_size => one (deRef (arg 0))
| MLton_touch => one (arg 0)
| Ref_assign => one (arg 1)
| Ref_deref => one result
| Ref_ref => one (arg 0)
- | Vector_length => one (devector (arg 0))
+ | Vector_length => one (deVector (arg 0))
| Vector_sub => one result
- | Weak_canGet => one (deweak (arg 0))
+ | Weak_canGet => one (deWeak (arg 0))
| Weak_get => one result
| Weak_new => one (arg 0)
| _ => Vector.new0 ()
end
+
+val extractTargs =
+ fn z =>
+ Trace.trace ("extractTargs", layout o #prim, Layout.ignore) extractTargs z
structure SmallIntInf = Const.SmallIntInf
1.48 +11 -32 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -r1.47 -r1.48
--- prim.sig 31 Jul 2003 20:32:59 -0000 1.47
+++ prim.sig 9 Oct 2003 18:17:31 -0000 1.48
@@ -15,16 +15,11 @@
structure Const: CONST
structure IntSize: INT_SIZE
structure RealSize: REAL_SIZE
- structure Scheme: SCHEME
- structure Type: TYPE
structure WordSize: WORD_SIZE
sharing CFunction.CType = CType
- sharing IntSize = CType.IntSize = Const.IntX.IntSize = Type.Tycon.IntSize
+ sharing IntSize = CType.IntSize = Const.IntX.IntSize
sharing RealSize = CType.RealSize = Const.RealX.RealSize
- = Type.Tycon.RealSize
- sharing Type = Scheme.Type
sharing WordSize = CType.WordSize = Const.WordX.WordSize
- = Type.Tycon.WordSize
end
signature PRIM =
@@ -40,7 +35,6 @@
| Array_sub (* backend *)
| Array_toVector (* backend *)
| Array_update (* backend *)
- | BuildConstant of string (* type inference *)
| C_CS_charArrayToWord8Array (* type inference *)
| Char_chr (* type inference *)
| Char_ge (* type inference *)
@@ -49,7 +43,6 @@
| Char_lt (* type inference *)
| Char_ord (* type inference *)
| Char_toWord8 (* type inference *)
- | Constant of string (* type inference *)
| Cpointer_isNull (* codegen *)
| Exn_extra (* implement exceptions *)
| Exn_keepHistory (* a compile-time boolean *)
@@ -246,32 +239,20 @@
val assign: t
val bogus: t
val bug: t
- val buildConstant: string * Scheme.t -> t
- val checkApp: {
- prim: t,
- targs: 'a vector,
- args: 'a vector,
- con: Type.Tycon.t * 'a vector -> 'a,
- equals: 'a * 'a -> bool,
- dearrowOpt: 'a -> ('a * 'a) option,
- detupleOpt: 'a -> 'a vector option,
- isUnit: 'a -> bool
- } -> 'a option
- val constant: string * Scheme.t -> t
val deref: t
val deserialize: t
val eq: t (* pointer equality *)
val equal: t (* polymorphic equality *)
val equals: t * t -> bool (* equality of names *)
- val extractTargs: {prim: t,
- args: 'a vector,
- result: 'a,
- dearray: 'a -> 'a,
- dearrow: 'a -> 'a * 'a,
- deref: 'a -> 'a,
- devector: 'a -> 'a,
- deweak: 'a -> 'a} -> 'a vector
- val ffi: CFunction.t * Scheme.t -> t
+ val extractTargs: {args: 'a vector,
+ deArray: 'a -> 'a,
+ deArrow: 'a -> 'a * 'a,
+ deRef: 'a -> 'a,
+ deVector: 'a -> 'a,
+ deWeak: 'a -> 'a,
+ prim: t,
+ result: 'a} -> 'a vector
+ val ffi: CFunction.t -> t
val ffiSymbol: {name: string, ty: CType.t} -> t
val gcCollect: t
val intInfEqual: t
@@ -302,11 +283,9 @@
*)
val maySideEffect: t -> bool
val name: t -> Name.t
- val new: string * Scheme.t -> t
+ val new: string -> t
val newNullary: CFunction.t -> t (* new of type unit -> unit *)
- val numArgs: t -> int option
val reff: t
- val scheme: t -> Scheme.t
val serialize: t
val toString: t -> string
val vectorLength: t
1.15 +2 -2 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- sources.cm 19 Jul 2003 01:23:26 -0000 1.14
+++ sources.cm 9 Oct 2003 18:17:31 -0000 1.15
@@ -53,8 +53,8 @@
c-function.fun
c-type.sig
c-type.fun
-cons.fun
-cons.sig
+con.fun
+con.sig
const.fun
const.sig
ffi.fun
1.4 +5 -3 mlton/mlton/atoms/tycon.fun
Index: tycon.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- tycon.fun 23 Jun 2003 04:58:55 -0000 1.3
+++ tycon.fun 9 Oct 2003 18:17:31 -0000 1.4
@@ -10,11 +10,13 @@
open S
-structure Id = HashId (structure AstId = AstId
- val noname = "t")
+structure Id = HashId (val noname = "t")
open Id
+structure Kind = TyconKind ()
+
structure P = PrimTycons (structure IntSize = IntSize
+ structure Kind = Kind
structure RealSize = RealSize
structure WordSize = WordSize
open Id)
@@ -24,7 +26,7 @@
let open Layout
in
align
- (List.map (prims, fn c =>
+ (List.map (prims, fn (c, _) =>
seq [layout c, str " size is ",
Int.layout (MLton.size c),
str " plist length is ",
1.4 +5 -2 mlton/mlton/atoms/tycon.sig
Index: tycon.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- tycon.sig 23 Jun 2003 04:58:55 -0000 1.3
+++ tycon.sig 9 Oct 2003 18:17:31 -0000 1.4
@@ -5,9 +5,11 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+type int = Int.t
+type word = Word.t
+
signature TYCON_STRUCTS =
sig
- structure AstId: AST_ID
structure IntSize: INT_SIZE
structure RealSize: REAL_SIZE
structure WordSize: WORD_SIZE
@@ -16,7 +18,8 @@
signature TYCON =
sig
include HASH_ID
- include PRIM_TYCONS where type tycon = t
+ include PRIM_TYCONS
+ sharing type t = tycon
val stats: unit -> Layout.t
end
1.8 +37 -36 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- type-ops.fun 5 Jul 2003 23:30:25 -0000 1.7
+++ type-ops.fun 9 Oct 2003 18:17:31 -0000 1.8
@@ -62,25 +62,25 @@
val arrow = Trace.trace ("arrow", Layout.tuple2 (layout, layout), layout) arrow
fun deUnaryOpt tycon t =
- case deconOpt t of
+ case deConOpt t of
SOME (c, ts) => if Tycon.equals (c, tycon)
then SOME (Vector.sub (ts, 0))
else NONE
| _ => NONE
-val dearrayOpt = deUnaryOpt Tycon.array
-val derefOpt = deUnaryOpt Tycon.reff
-val deweakOpt = deUnaryOpt Tycon.weak
+val deArrayOpt = deUnaryOpt Tycon.array
+val deRefOpt = deUnaryOpt Tycon.reff
+val deWeakOpt = deUnaryOpt Tycon.weak
fun deUnary tycon t =
case deUnaryOpt tycon t of
SOME t => t
| NONE => Error.bug "deUnary"
-val dearray = deUnary Tycon.array
-val deref = deUnary Tycon.reff
-val devector = deUnary Tycon.vector
-val deweak = deUnary Tycon.weak
+val deArray = deUnary Tycon.array
+val deRef = deUnary Tycon.reff
+val deVector = deUnary Tycon.vector
+val deWeak = deUnary Tycon.weak
fun tuple ts =
if 1 = Vector.length ts
@@ -89,57 +89,58 @@
val unit = tuple (Vector.new0 ())
-fun detupleOpt t =
- case deconOpt t of
+fun deTupleOpt t =
+ case deConOpt t of
SOME (c, ts) => if Tycon.equals (c, Tycon.tuple) then SOME ts else NONE
| NONE => NONE
-val isTuple = Option.isSome o detupleOpt
+val isTuple = Option.isSome o deTupleOpt
-fun detuple t =
- case detupleOpt t of
+fun deTuple t =
+ case deTupleOpt t of
SOME t => t
| NONE => Error.bug "detuple"
-fun nth (t, n) = Vector.sub (detuple t, n)
+fun nth (t, n) = Vector.sub (deTuple t, n)
val unitRef = reff unit
-fun detycon t =
- case deconOpt t of
+fun deTycon t =
+ case deConOpt t of
SOME (c, _) => c
| NONE => Error.bug "detycon"
-fun deconConstOpt t =
- case deconOpt t of
- SOME (c, ts) => SOME (c, Vector.map (ts, fn t =>
- case deconOpt t of
- SOME (c, _) => c
- | NONE => Error.bug "deconConstOpt"))
- | NONE => NONE
-fun deconConst t =
- case deconOpt t of
- SOME (c, ts) => (c, Vector.map (ts, fn t =>
- case deconOpt t of
- SOME (c, _) => c
- | NONE => Error.bug "deconConst"))
- | NONE => Error.bug "deconConst"
+fun deConConstOpt t =
+ Option.map
+ (deConOpt t, fn (c, ts) =>
+ (c, Vector.map (ts, fn t =>
+ case deConOpt t of
+ SOME (c, _) => c
+ | NONE => Error.bug "deConConstOpt")))
+
+fun deConConst t =
+ case deConOpt t of
+ NONE => Error.bug "deConConst"
+ | SOME (c, ts) => (c, Vector.map (ts, fn t =>
+ case deConOpt t of
+ NONE => Error.bug "deConConst"
+ | SOME (c, _) => c))
-fun dearrowOpt t =
- case deconOpt t of
+fun deArrowOpt t =
+ case deConOpt t of
SOME (c, ts) => if Tycon.equals (c, Tycon.arrow)
then SOME (Vector.sub (ts, 0), Vector.sub (ts, 1))
else NONE
| _ => NONE
-fun dearrow t =
- case dearrowOpt t of
+fun deArrow t =
+ case deArrowOpt t of
SOME x => x
- | NONE => Error.bug "Type.dearrow"
+ | NONE => Error.bug "Type.deArrow"
val dearrow =
- Trace.trace ("dearrow", layout, Layout.tuple2 (layout, layout)) dearrow
+ Trace.trace ("deArrow", layout, Layout.tuple2 (layout, layout)) deArrow
val arg = #1 o dearrow
val result = #2 o dearrow
1.8 +16 -16 mlton/mlton/atoms/type-ops.sig
Index: type-ops.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- type-ops.sig 5 Jul 2003 23:30:25 -0000 1.7
+++ type-ops.sig 9 Oct 2003 18:17:31 -0000 1.8
@@ -15,7 +15,7 @@
type t
val con: Tycon.t * t vector -> t
- val deconOpt: t -> (Tycon.t * t vector) option
+ val deConOpt: t -> (Tycon.t * t vector) option
val layout: t -> Layout.t
end
@@ -36,24 +36,24 @@
val arrow: t * t -> t
val bool: t
val con: tycon * t vector -> t
- val dearray: t -> t
- val dearrayOpt: t -> t option
- val dearrow: t -> t * t
- val dearrowOpt: t -> (t * t) option
- val deconOpt: t -> (tycon * t vector) option
- val deconConstOpt: t -> (tycon * tycon vector) option
- val deconConst: t -> (tycon * tycon vector)
+ val deArray: t -> t
+ val deArrayOpt: t -> t option
+ val deArrow: t -> t * t
+ val deArrowOpt: t -> (t * t) option
+ val deConOpt: t -> (tycon * t vector) option
+ val deConConstOpt: t -> (tycon * tycon vector) option
+ val deConConst: t -> (tycon * tycon vector)
+ val deRef: t -> t
+ val deRefOpt: t -> t option
+ val deTuple: t -> t vector
+ val deTupleOpt: t -> t vector option
+ val deTycon: t -> tycon
+ val deVector: t -> t
+ val deWeak: t -> t
+ val deWeakOpt: t -> t option
val defaultInt: t
val defaultReal: t
val defaultWord: t
- val deref: t -> t
- val derefOpt: t -> t option
- val detuple: t -> t vector
- val detupleOpt: t -> t vector option
- val detycon: t -> tycon
- val devector: t -> t
- val deweak: t -> t
- val deweakOpt: t -> t option
val exn: t
val int: intSize -> t
val intInf: t
1.4 +2 -10 mlton/mlton/atoms/type.fun
Index: type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- type.fun 23 Jun 2003 04:58:55 -0000 1.3
+++ type.fun 9 Oct 2003 18:17:31 -0000 1.4
@@ -33,20 +33,14 @@
val record = Record
- val deconOpt =
+ val deConOpt =
fn Con (c, ts) => SOME (c, ts)
| Record r => (case Record.detupleOpt r of
NONE => NONE
| SOME ts => SOME (Tycon.tuple, ts))
| _ => NONE
- fun toAst t =
- case t of
- Var a => Ast.Type.var a
- | Con (c, ts) => Ast.Type.con (Tycon.toAst c, Vector.map (ts, toAst))
- | Record r => Ast.Type.record (Record.map (r, toAst))
-
- val layout = Ast.Type.layout o toAst
+ val layout = fn _ => Layout.str "<type>"
end
structure Ops = TypeOps (structure Tycon = Tycon
@@ -75,8 +69,6 @@
Tyvars.union (ac, tyvars t))
val tyvars = Tyvars.toList o tyvars
-
-fun optionToAst z = Option.map (z, toAst)
fun substitute (t, sub) =
let
1.5 +0 -6 mlton/mlton/atoms/type.sig
Index: type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- type.sig 23 Jun 2003 04:58:55 -0000 1.4
+++ type.sig 9 Oct 2003 18:17:31 -0000 1.5
@@ -7,13 +7,9 @@
*)
signature TYPE_STRUCTS =
sig
- structure Ast: AST
structure Record: RECORD
structure Tycon: TYCON
structure Tyvar: TYVAR
- sharing Record = Ast.SortedRecord
- sharing Tyvar = Ast.Tyvar
- sharing Ast.Tycon = Tycon.AstId
end
signature TYPE =
@@ -36,13 +32,11 @@
var: Tyvar.t -> 'a,
con: Tycon.t * 'a vector -> 'a} -> 'a
val layout: t -> Layout.t
- val optionToAst: t option -> Ast.Type.t option
val record: t Record.t -> t
(* substitute(t, [(a1, t1), ..., (an, tn)]) performs simultaneous
* substitution of the ti for ai in t.
*)
val substitute: t * (Tyvar.t * t) vector -> t
- val toAst: t -> Ast.Type.t
(* tyvars returns a list (without duplicates) of all the type variables
* in a type.
*)
1.3 +2 -3 mlton/mlton/atoms/var.fun
Index: var.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/var.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- var.fun 10 Apr 2002 07:02:19 -0000 1.2
+++ var.fun 9 Oct 2003 18:17:31 -0000 1.3
@@ -5,13 +5,12 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor Var(S: VAR_STRUCTS): VAR =
+functor Var (S: VAR_STRUCTS): VAR =
struct
open S
-structure V = HashId(structure AstId = AstId
- val noname = "x")
+structure V = HashId (val noname = "x")
open V
end
1.3 +0 -1 mlton/mlton/atoms/var.sig
Index: var.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/var.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- var.sig 10 Apr 2002 07:02:19 -0000 1.2
+++ var.sig 9 Oct 2003 18:17:31 -0000 1.3
@@ -7,7 +7,6 @@
*)
signature VAR_STRUCTS =
sig
- structure AstId: AST_ID
end
signature VAR =
1.4 +10 -13 mlton/mlton/atoms/con.fun
1.3 +6 -3 mlton/mlton/atoms/con.sig
1.18 +1 -1 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- representation.fun 19 Jul 2003 01:23:26 -0000 1.17
+++ representation.fun 9 Oct 2003 18:17:32 -0000 1.18
@@ -558,7 +558,7 @@
SOME (pointer {fin = fn r => setTupleRep (t, r),
isNormal = true,
mutable = false,
- tys = S.Type.detuple t})
+ tys = S.Type.deTuple t})
| Vector t => SOME (array {mutable = false, ty = t})
| Weak t =>
(case toRtype t of
1.49 +1 -4 mlton/mlton/backend/ssa-to-rssa.fun
Index: ssa-to-rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.fun,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- ssa-to-rssa.fun 11 Sep 2003 00:51:07 -0000 1.48
+++ ssa-to-rssa.fun 9 Oct 2003 18:17:32 -0000 1.49
@@ -1148,10 +1148,7 @@
(case targ () of
NONE => none ()
| SOME ty => arrayUpdate ty)
- | FFI f =>
- if Option.isNone (Prim.numArgs prim)
- then normal ()
- else simpleCCall f
+ | FFI f => simpleCCall f
| FFI_getPointer =>
simpleCCall CFunction.getPointer
| FFI_setPointer =>
1.10 +19 -18 mlton/mlton/closure-convert/abstract-value.fun
Index: abstract-value.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- abstract-value.fun 12 Sep 2003 00:44:33 -0000 1.9
+++ abstract-value.fun 9 Oct 2003 18:17:32 -0000 1.10
@@ -276,27 +276,29 @@
fun select (v, i) =
case tree v of
- Type t => fromType (Vector.sub (Type.detuple t, i))
+ Type t => fromType (Vector.sub (Type.deTuple t, i))
| Tuple vs => Vector.sub (vs, i)
| _ => Error.bug "Value.select expected tuple"
-fun deref v =
+fun deRef v =
case tree v of
- Type t => fromType (Type.deref t)
+ Type t => fromType (Type.deRef t)
| Unify (_, v) => v
- | _ => Error.bug "Value.deref"
+ | _ => Error.bug "Value.deRef"
-fun deweak v =
+val deRef = Trace.trace ("Value.deRef", layout, layout) deRef
+
+fun deWeak v =
case tree v of
- Type t => fromType (Type.deweak t)
+ Type t => fromType (Type.deWeak t)
| Unify (_, v) => v
- | _ => Error.bug "Value.deweak"
+ | _ => Error.bug "Value.deWeak"
-fun dearray v =
+fun deArray v =
case tree v of
- Type t => fromType (Type.dearray t)
+ Type t => fromType (Type.deArray t)
| Unify (_, v) => v
- | _ => Error.bug "Value.dearray"
+ | _ => Error.bug "Value.deArray"
fun lambda (l: Sxml.Lambda.t, t: Type.t): t =
new (Lambdas (LambdaNode.lambda l), t)
@@ -309,15 +311,14 @@
else let val t = tree v
val t' = tree v'
in Dset.union (v, v')
- ; (case (t, t') of
- (Type t, Type t') => if Type.equals (t, t')
- then ()
- else Error.bug "unify"
+ ; (case (t, t') of
+ (Type t, Type t') => if Type.equals (t, t')
+ then ()
+ else Error.bug "unify"
| (Unify (_, v), Unify (_, v')) => unify (v, v')
- | (Tuple vs, Tuple vs') =>
- Vector.foreach2 (vs, vs', unify)
- | (Lambdas l, Lambdas l') => LambdaNode.unify (l, l')
- | _ => Error.bug "impossible unify")
+ | (Tuple vs, Tuple vs') => Vector.foreach2 (vs, vs', unify)
+ | (Lambdas l, Lambdas l') => LambdaNode.unify (l, l')
+ | _ => Error.bug "impossible unify")
end
val unify = Trace.trace2 ("Value.unify", layout, layout, Unit.layout) unify
1.5 +3 -3 mlton/mlton/closure-convert/abstract-value.sig
Index: abstract-value.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/abstract-value.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- abstract-value.sig 18 Apr 2003 22:45:00 -0000 1.4
+++ abstract-value.sig 9 Oct 2003 18:17:32 -0000 1.5
@@ -48,12 +48,12 @@
val addHandler: t * (Lambda.t -> unit) -> unit
val coerce: {from: t, to: t} -> unit
val ssaType: t -> Ssa.Type.t option ref
- val dearray: t -> t
- val deref: t -> t
+ val deArray: t -> t
+ val deRef: t -> t
+ val deWeak: t -> t
val dest: t -> dest
(* Destroy info associated with Sxml.Type used to keep track of arrows. *)
val destroy: unit -> unit
- val deweak: t -> t
val equals: t * t -> bool
val fromType: Sxml.Type.t -> t
val isEmpty: t -> bool (* no possible values correspond to me *)
1.28 +12 -10 mlton/mlton/closure-convert/closure-convert.fun
Index: closure-convert.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/closure-convert.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- closure-convert.fun 23 Jun 2003 04:58:58 -0000 1.27
+++ closure-convert.fun 9 Oct 2003 18:17:32 -0000 1.28
@@ -901,7 +901,7 @@
let
val a = varExpInfo (arg 0)
val y = varExpInfo (arg 2)
- val v = Value.dearray (VarInfo.value a)
+ val v = Value.deArray (VarInfo.value a)
in
primApp (v1 (valueType v),
v3 (convertVarInfo a,
@@ -927,12 +927,14 @@
| _ => doit ()
end
| MLton_handlesSignals =>
- if handlesSignals then Dexp.truee else Dexp.falsee
+ if handlesSignals
+ then Dexp.truee
+ else Dexp.falsee
| Ref_assign =>
let
val r = varExpInfo (arg 0)
val y = varExpInfo (arg 1)
- val v = Value.deref (VarInfo.value r)
+ val v = Value.deRef (VarInfo.value r)
in
primApp (v1 (valueType v),
v2 (convertVarInfo r,
@@ -942,7 +944,7 @@
| Ref_ref =>
let
val y = varExpInfo (arg 0)
- val v = Value.deref v
+ val v = Value.deRef v
in
primApp (v1 (valueType v),
v1 (coerce (convertVarInfo y,
@@ -961,7 +963,7 @@
| Weak_new =>
let
val y = varExpInfo (arg 0)
- val v = Value.deweak v
+ val v = Value.deWeak v
in
primApp (v1 (valueType v),
v1 (coerce (convertVarInfo y,
@@ -976,11 +978,11 @@
{prim = prim,
args = Vector.map (args, varInfoType),
result = ty,
- dearray = Type.dearray,
- dearrow = Type.dearrow,
- deref = Type.deref,
- devector = Type.devector,
- deweak = Type.deweak},
+ deArray = Type.deArray,
+ deArrow = Type.deArrow,
+ deRef = Type.deRef,
+ deVector = Type.deVector,
+ deWeak = Type.deWeak},
Vector.map (args, convertVarInfo))
end)
end
1.69 +1 -46 mlton/mlton/codegen/c-codegen/c-codegen.fun
Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.68
retrieving revision 1.69
diff -u -r1.68 -r1.69
--- c-codegen.fun 10 Sep 2003 01:00:10 -0000 1.68
+++ c-codegen.fun 9 Oct 2003 18:17:32 -0000 1.69
@@ -242,9 +242,7 @@
}: unit =
let
fun declareExports () =
- if Ffi.numExports () > 0
- then Ffi.declareExports {print = print}
- else ()
+ Ffi.declareExports {print = print}
fun declareLoadSaveGlobals () =
let
val _ =
@@ -437,49 +435,6 @@
| Word s => word s
| _ => Error.bug (concat ["Type.toC strange type: ", toString t])
end
- end
-
-structure Prim =
- struct
- open Prim
- structure Type =
- struct
- open Type
-
- local
- val {get: Tycon.t -> string option, set, ...} =
- Property.getSetOnce (Tycon.plist, Property.initConst NONE)
- val tycons =
- List.map
- (IntSize.all, fn s =>
- (Tycon.int s, concat ["Int", IntSize.toString s]))
- @ [(Tycon.intInf, "Pointer"),
- (Tycon.pointer, "Pointer"),
- (Tycon.preThread, "Pointer")]
- @ (List.map
- (RealSize.all, fn s =>
- (Tycon.real s, concat ["Real", RealSize.toString s])))
- @ [(Tycon.reff, "Pointer"),
- (Tycon.thread, "Pointer"),
- (Tycon.tuple, "Pointer"),
- (Tycon.vector, "Pointer"),
- (Tycon.weak, "Pointer")]
- @ (List.map
- (WordSize.all, fn s =>
- (Tycon.word s, concat ["Word", WordSize.toString s])))
- val _ =
- List.foreach (tycons, fn (tycon, s) => set (tycon, SOME s))
- in
- fun toC (ty: t): string =
- case ty of
- Con (c, _) =>
- (case get c of
- NONE => Error.bug (concat ["strange tycon: ",
- Tycon.toString c])
- | SOME s => s)
- | _ => Error.bug "strange type"
- end
- end
end
fun contents (ty, z) = concat ["C", C.args [Type.toC ty, z]]
1.46 +2 -1 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- x86.fun 10 Sep 2003 01:00:11 -0000 1.45
+++ x86.fun 9 Oct 2003 18:17:32 -0000 1.46
@@ -570,7 +570,8 @@
| (Const c1, ImmedBinExp _) => LESS
| (Label l1, Label l2)
=> lexical [fn () => EQUAL,
- fn () => Label.AstId.compare(Label.toAst l1, Label.toAst l2)]
+ fn () => String.compare (Label.toString l1,
+ Label.toString l2)]
| (Label l1, ImmedUnExp _) => LESS
| (Label l1, ImmedBinExp _) => LESS
| (ImmedUnExp {oper = oper1, exp = exp1},
1.98 +5 -1 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.97
retrieving revision 1.98
diff -u -r1.97 -r1.98
--- control.sml 29 Aug 2003 00:25:21 -0000 1.97
+++ control.sml 9 Oct 2003 18:17:32 -0000 1.98
@@ -715,7 +715,11 @@
let
val _ = Int.inc numErrors
open Layout
- val _ = outputl (align [seq [Region.layout r, str " Error: ", msg],
+ val p =
+ case Region.left r of
+ NONE => "<bogus>"
+ | SOME p => SourcePos.toString p
+ val _ = outputl (align [seq [str "Error: ", str p, str ": ", msg],
indent (extra, 3)],
Out.error)
in
1.6 +1 -1 mlton/mlton/control/source-pos.sml
Index: source-pos.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/source-pos.sml,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- source-pos.sml 11 Feb 2003 18:44:03 -0000 1.5
+++ source-pos.sml 9 Oct 2003 18:17:32 -0000 1.6
@@ -45,7 +45,7 @@
line = ~1}
fun toString (p as T {column, line, ...}) =
- concat [file p, ":", Int.toString line, ".", Int.toString column]
+ concat [file p, " ", Int.toString line, ".", Int.toString column]
fun posToString (T {line, column, ...}) =
concat [Int.toString line, ".", Int.toString column]
1.5 +3 -0 mlton/mlton/control/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/sources.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sources.cm 12 Dec 2002 01:14:22 -0000 1.4
+++ sources.cm 9 Oct 2003 18:17:32 -0000 1.5
@@ -10,6 +10,7 @@
signature REGION
structure Control
+structure Pretty
structure Region
structure Source
structure SourcePos
@@ -21,6 +22,8 @@
control.sig
control.sml
+pretty.sig
+pretty.sml
region.sig
region.sml
source-pos.sig
1.1 mlton/mlton/control/layout.sml
Index: layout.sml
===================================================================
structure Code =
struct
fun nest (prefix, x, y) =
align [seq [str prefix, x],
seq [str "in ", y],
str "end"]
fun layoutLet (d, e) = nest ("let ", d, e)
fun layoutLocal (d, d') = nest ("local ", d, d')
1.1 mlton/mlton/control/pretty.sig
Index: pretty.sig
===================================================================
signature PRETTY =
sig
type t = Layout.t
val casee: {default: t option,
rules: (t * t) vector,
test: t} -> t
val conApp: {arg: t option,
con: Layout.t,
targs: Layout.t vector} -> t
val handlee: {catch: t,
handler: t,
try: t} -> t
val lett: t * t -> t
val locall: t * t -> t
val primApp: {args: t vector,
prim: t,
targs: t vector} -> t
val raisee: t -> t
val seq: t vector -> t
val var: {targs: t vector,
var: t} -> t
end
1.1 mlton/mlton/control/pretty.sml
Index: pretty.sml
===================================================================
structure Pretty: PRETTY =
struct
open Layout
fun casee {default, rules, test} =
align [seq [str "case ", test, str " of"],
indent (alignPrefix (Vector.toListMap
(rules, fn (lhs, rhs) =>
mayAlign [seq [lhs, str " =>"], rhs]),
"| "),
2)]
fun conApp {arg, con, targs} =
seq [con,
if !Control.showTypes
then tuple (Vector.toList targs)
else empty,
case arg of
NONE => empty
| SOME x => seq [str " ", x]]
fun handlee {catch, handler, try} =
align [try,
seq [str "handle ", catch, str " => ", handler]]
fun nest (prefix, x, y) =
align [seq [str prefix, x],
str "in",
indent (y, 3),
str "end"]
fun lett (d, e) = nest ("let ", d, e)
fun locall (d, d') = nest ("local ", d, d')
fun primApp {args, prim, targs} =
seq [prim,
if !Control.showTypes
andalso 0 < Vector.length targs
then list (Vector.toList targs)
else empty,
str " ",
tuple (Vector.toList args)]
fun raisee exn = seq [str "raise ", exn]
fun var {targs, var} =
if !Control.showTypes
then seq [var, tuple (Vector.toList targs)]
else var
fun seq es = mayAlign (separateLeft (Vector.toList es, ";"))
end
1.11 +334 -501 mlton/mlton/core-ml/core-ml.fun
Index: core-ml.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- core-ml.fun 14 Jan 2003 00:08:16 -0000 1.10
+++ core-ml.fun 9 Oct 2003 18:17:32 -0000 1.11
@@ -10,578 +10,411 @@
open S
-local open Ast
-in
- structure Adec = Dec
- structure Apat = Pat
-end
+structure Field = Record.Field
-structure Wrap = Region.Wrap
-
-fun makeList (con, app, tuple) (l, r) =
- List.foldr (l, Wrap.makeRegion (con Con.nill, r), fn (x1, x2) =>
- Wrap.makeRegion (app (Con.cons, tuple (Vector.new2 (x1, x2), r)),
- r))
+fun maybeConstrain (x, t) =
+ let
+ open Layout
+ in
+ if !Control.showTypes
+ then seq [x, str ": ", Type.layout t]
+ else x
+ end
structure Pat =
struct
- open Wrap
-
- datatype node =
- Wild
- | Var of Var.t
- | Const of Ast.Const.t
- | Con of {con: Con.t, arg: t option}
- | Record of {flexible: bool, record: t Record.t}
- | Constraint of t * Type.t
+ datatype t = T of {node: node,
+ ty: Type.t}
+ and node =
+ Con of {arg: t option,
+ con: Con.t,
+ targs: Type.t vector}
+ | Const of unit -> Const.t
| Layered of Var.t * t
- withtype t = node Wrap.t
- type node' = node
- type obj = t
+ | List of t vector
+ | Record of t Record.t
+ | Tuple of t vector
+ | Var of Var.t
+ | Wild
local
- structure Pat = Ast.Pat
+ fun make f (T r) = f r
in
- fun toAst p =
- case node p of
- Wild => Pat.wild
- | Var x => Pat.var (Var.toAst x)
- | Const c => Pat.const c
- | Record {record, flexible} =>
- (case (flexible, Record.detupleOpt record) of
- (false, SOME ps) => Pat.tuple (Vector.map (ps, toAst))
- | _ =>
- Pat.makeRegion
- (Pat.Record
- {flexible = flexible,
- items = (Vector.map
- (Record.toVector record, fn (field, p) =>
- Pat.Item.Field (field, toAst p)))},
- Region.bogus))
- | Con {con, arg} =>
- let
- val con = Con.toAst con
- in
- case arg of
- NONE => Pat.con con
- | SOME p => Pat.app (con, toAst p)
- end
- | Constraint (p, t) => Pat.constraint (toAst p, Type.toAst t)
- | Layered (x, p) =>
- Pat.layered {fixop = Ast.Fixop.None,
- var = Var.toAst x,
- constraint = NONE,
- pat = toAst p}
-
- val layout = Pat.layout o toAst
+ val dest = make (fn {node, ty} => (node, ty))
+ val node = make #node
+ val ty = make #ty
end
- fun isWild p =
- case node p of
- Wild => true
- | _ => false
-
- fun isRefutable p =
- case node p of
- Wild => false
- | Var _ => false
- | Const _ => true
- | Con _ => true
- | Record {record, ...} => Record.exists (record, isRefutable)
- | Constraint (p, _) => isRefutable p
- | Layered (_, p) => isRefutable p
-
- fun vars'(p, l) =
- case node p of
- Wild => l
- | Var x => x :: l
- | Const _ => l
- | Con {arg, ...} => (case arg of
- NONE => l
- | SOME p => vars'(p, l))
- | Record {record, ...} => Record.fold (record, l, vars')
- | Constraint (p, _) => vars'(p, l)
- | Layered (x, p) => vars'(p, x :: l)
-
- fun vars p = vars'(p, [])
+ fun make (n, t) = T {node = n, ty = t}
- fun removeVarsPred (p: t, pred: Var.t -> bool): t =
+ fun layout p =
let
- fun loop p =
- let
- fun doit n = makeRegion (n, region p)
- in
- case node p of
- Wild => p
- | Const _ => p
- | Var x => if pred x
- then doit Wild
- else p
- | Record {flexible, record} =>
- doit (Record {flexible = flexible,
- record = Record.map (record, loop)})
- | Con {con, arg} =>
- doit (Con {con = con,
- arg = (case arg of
- NONE => NONE
- | SOME p => SOME (loop p))})
- | Constraint (p, t) => doit (Constraint (loop p, t))
- | Layered (_, p) => loop p
- end
- in loop p
- end
-
- fun removeVars p = removeVarsPred (p, fn _ => true)
-
- fun removeOthersReplace (p, x, y) =
- let
- fun loop p =
- let
- fun doit n = makeRegion (n, region p)
- in
- case node p of
- Wild => doit Wild
- | Const _ => p
- | Var x' =>
- doit (if Var.equals (x, x') then Var y else Wild)
- | Record {record, flexible} =>
- doit (Record {flexible = flexible,
- record = Record.map (record, loop)})
- | Con {con, arg} =>
- doit (Con {con = con,
- arg = (case arg of
- NONE => NONE
- | SOME p => SOME (loop p))})
- | Constraint (p, _) => loop p
- | Layered (x', p) =>
- if Var.equals (x, x')
- then doit (Var y)
- else loop p
- end
+ val t = ty p
+ open Layout
in
- loop p
+ case node p of
+ Con {arg, con, targs} =>
+ seq [Con.layout con,
+ if !Control.showTypes andalso 0 < Vector.length targs
+ then tuple (Vector.toListMap (targs, Type.layout))
+ else empty,
+ case arg of
+ NONE => empty
+ | SOME p => seq [str " ", layout p]]
+ | Const f => Const.layout (f ())
+ | Layered (x, p) =>
+ seq [maybeConstrain (Var.layout x, t), str " as ", layout p]
+ | List ps => list (Vector.toListMap (ps, layout))
+ | Record r =>
+ record (Vector.toListMap
+ (Record.toVector r, fn (f, p) =>
+ (Field.toString f, layout p)))
+ | Tuple ps => tuple (Vector.toListMap (ps, layout))
+ | Var x => maybeConstrain (Var.layout x, t)
+ | Wild => str "_"
end
- val removeOthersReplace =
- Trace.trace3 ("Pat.removeOthersReplace",
- layout, Var.layout, Var.layout, layout)
- removeOthersReplace
-
- fun tuple (ps, region) =
- if 1 = Vector.length ps
- then Vector.sub (ps, 0)
- else makeRegion (Record {flexible = false, record = Record.tuple ps},
- region)
+ fun var (x, t) = make (Var x, t)
- fun unit r = tuple (Vector.new0 (), r)
+ fun tuple ps = make (Tuple ps, Type.tuple (Vector.map (ps, ty)))
- val list =
- makeList (fn c => Con {con = c, arg = NONE},
- fn (c, p) => Con {con = c, arg = SOME p},
- tuple)
-
- fun var (x, r) = makeRegion (Var x, r)
-
- fun record {flexible, record, region} =
- makeRegion (Record {flexible = flexible, record = record},
- region)
-
local
- fun make c r = makeRegion (Con {con = c, arg = NONE}, r)
+ fun bool c = make (Con {arg = NONE, con = c, targs = Vector.new0 ()},
+ Type.bool)
in
- val truee = make Con.truee
- val falsee = make Con.falsee
+ val falsee: t = bool Con.falsee
+ val truee: t = bool Con.truee
end
-
- fun foreachVar (p, f) =
- let
- fun loop p =
- case node p of
- Var x => f x
- | Con {arg = SOME p, ...} => loop p
- | Record {record, ...} => Record.foreach (record, loop)
- | Constraint (p, _) => loop p
- | Layered (x, p) => (f x; loop p)
- | _ => ()
- in loop p
- end
+
+ fun isWild (p: t): bool =
+ case node p of
+ Wild => true
+ | _ => false
+
+ fun isRefutable (p: t): bool =
+ case node p of
+ Con _ => true
+ | Const _ => true
+ | Layered (_, p) => isRefutable p
+ | List _ => true
+ | Record r => Record.exists (r, isRefutable)
+ | Tuple ps => Vector.exists (ps, isRefutable)
+ | Var _ => false
+ | Wild => false
end
-datatype decNode =
- Val of {exp: exp,
- filePos: string,
- pat: Pat.t,
- tyvars: Tyvar.t vector}
- | Fun of {tyvars: Tyvar.t vector,
- decs: {match: match,
- profile: SourceInfo.t option,
- types: Type.t vector,
- var: Var.t} vector}
- | Datatype of {
- tyvars: Tyvar.t vector,
- tycon: Tycon.t,
- cons: {
- con: Con.t,
- arg: Type.t option
- } vector
- } vector
- | Exception of {
- con: Con.t,
- arg: Type.t option
- }
- | Overload of {var: Var.t,
- scheme: Scheme.t,
- ovlds: Var.t vector}
-and expNode =
- Var of Var.t
- | Prim of Prim.t
- | Const of Ast.Const.t
- | Con of Con.t
- | Record of exp Record.t
- | Fn of {match: match,
- profile: SourceInfo.t option}
- | App of exp * exp
- | Let of dec vector * exp
- | Constraint of exp * Type.t
- | Handle of exp * match
- | Raise of {exn: exp, filePos: string}
-and match = Match of {filePos: string,
- rules: (Pat.t * exp) vector}
-withtype exp = expNode Wrap.t
-and dec = decNode Wrap.t
-
-structure Match =
+structure NoMatch =
struct
- type t = match
+ datatype t = Impossible | RaiseAgain | RaiseBind | RaiseMatch
- local
- fun make f m =
- let
- val Match r = m
- in
- f r
- end
- in
- val filePos = make #filePos
- val rules = make #rules
- end
+ val toString =
+ fn Impossible => "Impossible"
+ | RaiseAgain => "RaiseAgain"
+ | RaiseBind => "RaiseBind"
+ | RaiseMatch => "RaiseMatch"
- fun region m =
- Wrap.region (#1 (Vector.sub (rules m, 0)))
-
-
- fun new {filePos, rules} =
- Match {filePos = filePos,
- rules = rules}
+ val layout = Layout.str o toString
end
+datatype noMatch = datatype NoMatch.t
+
+datatype dec =
+ Datatype of {cons: {arg: Type.t option,
+ con: Con.t} vector,
+ tycon: Tycon.t,
+ tyvars: Tyvar.t vector} vector
+ | Exception of {arg: Type.t option,
+ con: Con.t}
+ | Fun of {decs: {lambda: lambda,
+ var: Var.t} vector,
+ tyvars: unit -> Tyvar.t vector}
+ | Val of {rvbs: {lambda: lambda,
+ var: Var.t} vector,
+ tyvars: unit -> Tyvar.t vector,
+ vbs: {exp: exp,
+ pat: Pat.t,
+ patRegion: Region.t} vector}
+and exp = Exp of {node: expNode,
+ ty: Type.t}
+and expNode =
+ App of exp * exp
+ | Case of {noMatch: noMatch,
+ region: Region.t,
+ rules: (Pat.t * exp) vector,
+ test: exp}
+ | Con of Con.t * Type.t vector
+ | Const of unit -> Const.t
+ | EnterLeave of exp * SourceInfo.t
+ | Handle of {catch: Var.t * Type.t,
+ handler: exp,
+ try: exp}
+ | Lambda of lambda
+ | Let of dec vector * exp
+ | List of exp vector
+ | PrimApp of {args: exp vector,
+ prim: Prim.t,
+ targs: Type.t vector}
+ | Raise of {exn: exp,
+ region: Region.t}
+ | Record of exp Record.t
+ | Seq of exp vector
+ | Var of (unit -> Var.t) * (unit -> Type.t vector)
+and lambda = Lam of {arg: Var.t,
+ argType: Type.t,
+ body: exp}
+
local
- local
- open Ast
- in
- structure Dec = Dec
- structure Exp = Exp
- structure Longvar = Longvar
- end
+ open Layout
in
- fun astDatatype ds =
- Dec.datatypee
- (Vector.map
- (ds, fn {tyvars, tycon, cons} =>
- {tyvars = tyvars,
- tycon = Tycon.toAst tycon,
- cons = Vector.map (cons, fn {con, arg} =>
- (Con.toAst con, Type.optionToAst arg))}))
-
- fun decToAst (d: dec) =
- let
- fun doit n = Dec.makeRegion (n, Region.bogus)
- in
- case Wrap.node d of
- Val {pat, filePos, tyvars, exp} =>
- doit (Dec.Val {tyvars = tyvars,
- vbs = Vector.new1 {pat = Pat.toAst pat,
- exp = expToAst exp,
- filePos = filePos},
- rvbs = Vector.new0 ()})
- | Fun {tyvars, decs} =>
- doit (Dec.Val
- {tyvars = tyvars,
- vbs = Vector.new0 (),
- rvbs = (Vector.map
- (decs, fn {match, types, var, ...} =>
- {pat = (Vector.fold
- (types, Apat.var (Var.toAst var),
- fn (t, p) =>
- Apat.constraint (p, Type.toAst t))),
- match = matchToAst match}))})
- | Datatype ds => astDatatype ds
- | Exception {con, arg} =>
- Dec.exceptionn (Con.toAst con, Type.optionToAst arg)
- | Overload {var, scheme, ovlds} =>
- doit (Dec.Overload
- (Var.toAst var,
- Type.toAst (Scheme.ty scheme),
- Vector.map (ovlds, fn x =>
- Longvar.short (Var.toAst x))))
- end
- and expToAst e =
- case Wrap.node e of
- App (e1, e2) => Exp.app (expToAst e1, expToAst e2)
- | Con c => Exp.con (Con.toAst c)
- | Const c => Exp.const c
- | Constraint (e, t) => Exp.constraint (expToAst e, Type.toAst t)
- | Fn {match, ...} => Exp.fnn (matchToAst match)
- | Handle (try, match) => Exp.handlee (expToAst try, matchToAst match)
- | Let (ds, e) => Exp.lett (Vector.map (ds, decToAst), expToAst e)
- | Prim p => Exp.longvid (Ast.Longvid.short
- (Ast.Longvid.Id.fromString (Prim.toString p,
- Region.bogus)))
- | Raise {exn, filePos} =>
- Exp.raisee {exn = expToAst exn, filePos = filePos}
- | Record r => Exp.record (Record.map (r, expToAst))
- | Var x => Exp.var (Var.toAst x)
-
- and matchToAst m =
- let
- val Match {rules, filePos} = m
- in
- Ast.Match.T
- {filePos = filePos,
- rules = Vector.map (rules, fn (p, e) => (Pat.toAst p, expToAst e))}
- end
+ fun layoutTyvars ts =
+ case Vector.length ts of
+ 0 => empty
+ | 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
+ | _ => seq [str " ", tuple (Vector.toListMap (ts, Tyvar.layout))]
+
+ fun layoutConArg {arg, con} =
+ seq [Con.layout con,
+ case arg of
+ NONE => empty
+ | SOME t => seq [str " of ", Type.layout t]]
+
+ fun layoutDec d =
+ case d of
+ Datatype v =>
+ seq [str "datatype",
+ align
+ (Vector.toListMap
+ (v, fn {cons, tycon, tyvars} =>
+ seq [layoutTyvars tyvars, Tycon.layout tycon, str " = ",
+ align
+ (separateLeft (Vector.toListMap (cons, layoutConArg),
+ "| "))]))]
+ | Exception ca =>
+ seq [str "exception ", layoutConArg ca]
+ | Fun {decs, tyvars, ...} => layoutFuns (tyvars, decs)
+ | Val {rvbs, tyvars, vbs, ...} =>
+ align [layoutFuns (tyvars, rvbs),
+ align (Vector.toListMap
+ (vbs, fn {exp, pat, ...} =>
+ seq [str "val",
+ mayAlign [seq [layoutTyvars (tyvars ()),
+ str " ", Pat.layout pat,
+ str " ="],
+ layoutExp exp]]))]
+ and layoutExp (Exp {node, ...}) =
+ case node of
+ App (e1, e2) => paren (seq [layoutExp e1, str " ", layoutExp e2])
+ | Case {noMatch, rules, test, ...} =>
+ Pretty.casee {default = NONE,
+ rules = Vector.map (rules, fn (p, e) =>
+ (Pat.layout p, layoutExp e)),
+ test = layoutExp test}
+ | Con (c, _) => Con.layout c
+ | Const f => Const.layout (f ())
+ | EnterLeave (e, _) => layoutExp e
+ | Handle {catch, handler, try} =>
+ Pretty.handlee {catch = Var.layout (#1 catch),
+ handler = layoutExp handler,
+ try = layoutExp try}
+ | Lambda l => layoutLambda l
+ | Let (ds, e) =>
+ Pretty.lett (align (Vector.toListMap (ds, layoutDec)),
+ layoutExp e)
+ | List es => list (Vector.toListMap (es, layoutExp))
+ | PrimApp {args, prim, targs} =>
+ Pretty.primApp {args = Vector.map (args, layoutExp),
+ prim = Prim.layout prim,
+ targs = Vector.map (targs, Type.layout)}
+ | Raise {exn, ...} => Pretty.raisee (layoutExp exn)
+ | Record r =>
+ Record.layout
+ {extra = "",
+ layoutElt = layoutExp,
+ layoutTuple = fn es => tuple (Vector.toListMap (es, layoutExp)),
+ record = r,
+ separator = " = "}
+ | Seq es => Pretty.seq (Vector.map (es, layoutExp))
+ | Var (x, targs) => Var.layout (x ())
+ and layoutFuns (tyvars, decs) =
+ if 0 = Vector.length decs
+ then empty
+ else
+ align [seq [str "val rec", layoutTyvars (tyvars ())],
+ indent (align (Vector.toListMap
+ (decs, fn {lambda, var} =>
+ align [seq [Var.layout var, str " = "],
+ indent (layoutLambda lambda, 3)])),
+ 3)]
+ and layoutLambda (Lam {arg, argType, body}) =
+ paren (align [seq [str "fn ", Var.layout arg, str " =>"],
+ layoutExp body])
end
-fun makeForeachVar f =
- let
- fun exp e =
- case Wrap.node e of
- App (e1, e2) => (exp e1; exp e2)
- | Constraint (e, _) => exp e
- | Fn {match = m, ...} => match m
- | Handle (e, m) => (exp e; match m)
- | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
- | Raise {exn, ...} => exp exn
- | Record r => Record.foreach (r, exp)
- | Var x => f x
- | _ => ()
- and match m = Vector.foreach (Match.rules m, exp o #2)
- and dec d =
- case Wrap.node d of
- Fun {decs, ...} => Vector.foreach (decs, match o #match)
- | Overload {ovlds, ...} => Vector.foreach (ovlds, f)
- | Val {exp = e, ...} => exp e
- | _ => ()
- in
- {exp = exp, dec = dec}
+structure Lambda =
+ struct
+ datatype t = datatype lambda
+
+ val layout = layoutLambda
+
+ val make = Lam
+
+ fun dest (Lam r) = r
end
structure Exp =
struct
- open Wrap
type dec = dec
- type match = match
+ type lambda = lambda
+ datatype t = datatype exp
datatype node = datatype expNode
- type t = exp
- type node' = node
- type obj = t
-
- val toAst = expToAst
-
- fun foreachVar (e, f) = #exp (makeForeachVar f) e
- fun fnn (m, r) = makeRegion (Fn m, r)
+ datatype noMatch = datatype noMatch
+
+ val layout = layoutExp
- fun fn1 {exp, pat, profile, region}=
- fnn ({match = Match.new {filePos = "",
- rules = Vector.new1 (pat, exp)},
- profile = profile},
- region)
+ local
+ fun make f (Exp r) = f r
+ in
+ val dest = make (fn {node, ty} => (node, ty))
+ val node = make #node
+ val ty = make #ty
+ end
+
+ fun make (n, t) = Exp {node = n,
+ ty = t}
- fun isExpansive e =
+ fun enterLeave (e, si) = make (EnterLeave (e, si), ty e)
+
+ fun var (x: Var.t, ty: Type.t): t =
+ make (Var (fn () => x, fn () => Vector.new0 ()), ty)
+
+ fun isExpansive (e: t): bool =
case node e of
- Var _ => false
- | Const _ => false
- | Con _ => false
- | Fn _ => false
- | Prim _ => false
- | Record r => Record.exists (r, isExpansive)
- | Constraint (e, _) => isExpansive e
- | App (e1, e2) =>
+ App (e1, e2) =>
(case node e1 of
- Con c => Con.equals (c, Con.reff) orelse isExpansive e2
+ Con (c, _) => Con.equals (c, Con.reff) orelse isExpansive e2
| _ => true)
- | _ => true
-
- fun record (record, r) = makeRegion (Record record, r)
-
- fun lambda (x, e, p, r) =
- fn1 {exp = e,
- pat = makeRegion (Pat.Var x, r),
- profile = p,
- region = r}
-
- fun casee (test, rules, r) =
- makeRegion (App (makeRegion (Fn {match = rules,
- profile = NONE},
- r),
- test),
- r)
+ | Case _ => true
+ | Con _ => false
+ | Const _ => false
+ | EnterLeave _ => true
+ | Handle _ => true
+ | Lambda _ => false
+ | Let _ => true
+ | List es => Vector.exists (es, isExpansive)
+ | PrimApp _ => true
+ | Raise _ => true
+ | Record r => Record.exists (r, isExpansive)
+ | Seq _ => true
+ | Var _ => false
- fun tuple (es, r) =
+ fun tuple es =
if 1 = Vector.length es
then Vector.sub (es, 0)
- else record (Record.tuple es, r)
+ else make (Record (Record.tuple es),
+ Type.tuple (Vector.map (es, ty)))
- fun unit r = tuple (Vector.new0 (), r)
+ val unit = tuple (Vector.new0 ())
- fun seq (es, r) =
- if 1 = Vector.length es
- then Vector.sub (es, 0)
- else
- let
- val (es, e) = Vector.splitLast es
- in
- makeRegion
- (Let (Vector.map (es, fn e =>
- makeRegion (Val {pat = makeRegion (Pat.Wild, r),
- tyvars = Vector.new0 (),
- exp = e,
- filePos = ""},
- r)),
- e),
- r)
- end
+ local
+ fun bool c = make (Con (c, Vector.new0 ()), Type.bool)
+ in
+ val falsee: t = bool Con.falsee
+ val truee: t = bool Con.truee
+ end
- fun force (e, r) = makeRegion (App (e, unit r), r)
-
- fun list (l, r) =
- makeList (Con, fn (c, e) => App (makeRegion (Con c, r), e), tuple)
- (l, r)
+ fun lambda (l as Lam {argType, body, ...}) =
+ make (Lambda l, Type.arrow (argType, ty body))
- fun var (x, r) = makeRegion (Var x, r)
-
- fun selector (f, r) =
- let
- val x = Var.newNoname ()
- in
- fn1 {exp = var (x, r),
- pat = (Pat.record
- {flexible = true,
- record = Record.fromVector (Vector.new1
- (f, Pat.var (x, r))),
- region = r}),
- profile = NONE,
- region = r}
- end
+ fun casee (z as {rules, ...}) =
+ if 0 = Vector.length rules
+ then Error.bug "CoreML.casee"
+ else make (Case z, ty (#2 (Vector.sub (rules, 0))))
+
+ fun iff (test, thenCase, elseCase): t =
+ casee {noMatch = Impossible,
+ region = Region.bogus,
+ rules = Vector.new2 ((Pat.truee, thenCase),
+ (Pat.falsee, elseCase)),
+ test = test}
- fun iff (test, thenCase, elseCase, r) =
- casee (test,
- Match.new {filePos = "",
- rules = Vector.new2 ((Pat.truee r, thenCase),
- (Pat.falsee r, elseCase))},
- r)
-
- fun con (c, r) = makeRegion (Con c, r)
- fun truee r = con (Con.truee, r)
- fun falsee r = con (Con.falsee, r)
+ fun andAlso (e1, e2) = iff (e1, e2, falsee)
- fun andAlso (e1, e2, r) = iff (e1, e2, falsee r, r)
- fun orElse (e1, e2, r) = iff (e1, truee r, e2, r)
+ fun orElse (e1, e2) = iff (e1, truee, e2)
- fun whilee {test, expr, region = r} =
+ fun whilee {expr, test} =
let
val loop = Var.newNoname ()
- val call = makeRegion (App (var (loop, r), unit r), r)
- val match =
- Match.new {filePos = "",
- rules = (Vector.new1
- (Pat.tuple (Vector.new0 (), r),
- iff (test,
- seq (Vector.new2 (expr, call), r),
- unit r,
- r)))}
+ val loopTy = Type.arrow (Type.unit, Type.unit)
+ val call = make (App (var (loop, loopTy), unit), Type.unit)
+ val lambda =
+ Lambda.make
+ {arg = Var.newNoname (),
+ argType = Type.unit,
+ body = iff (test,
+ make (Seq (Vector.new2 (expr, call)),
+ Type.unit),
+ unit)}
in
- makeRegion
- (Let (Vector.new1
- (makeRegion
- (Fun {tyvars = Vector.new0 (),
- decs = (Vector.new1
- {match = match,
- profile = SOME (SourceInfo.anonymous r),
- types = Vector.new0 (),
- var = loop})},
- r)),
+ make
+ (Let (Vector.new1 (Fun {decs = Vector.new1 {lambda = lambda,
+ var = loop},
+ tyvars = fn () => Vector.new0 ()}),
call),
- r)
+ Type.unit)
end
- val layout = Ast.Exp.layout o toAst
end
structure Dec =
struct
- open Wrap
- type t = dec
- datatype node = datatype decNode
- type node' = node
- type obj = t
-
- fun isExpansive d =
- case node d of
- Val {exp, ...} => Exp.isExpansive exp
- | _ => false
+ datatype t = datatype dec
- val toAst = decToAst
-
- val layout = Adec.layout o toAst
+ val layout = layoutDec
end
structure Program =
struct
datatype t = T of {decs: Dec.t vector}
- fun toAst (T {decs, ...}) =
- Adec.makeRegion
- (Adec.Local
- (Adec.makeRegion (Adec.SeqDec (Vector.map (decs, Dec.toAst)),
- Region.bogus),
- Adec.empty),
- Region.bogus)
-
- val layout = Adec.layout o toAst
+ fun layout (T {decs, ...}) =
+ Layout.align (Vector.toListMap (decs, Dec.layout))
- fun size (T {decs = ds, ...}): int =
- let
- val n = ref 0
- fun inc () = n := 1 + !n
- fun exp e =
- (inc ()
- ; (case Exp.node e of
- App (e, e') => (exp e; exp e')
- | Constraint (e, _) => exp e
- | Fn {match = m, ...} => match m
- | Handle (e, m) => (exp e; match m)
- | Let (ds, e) => (Vector.foreach (ds, dec); exp e)
- | Raise {exn, ...} => exp exn
- | Record r => Record.foreach (r, exp)
- | _ => ()))
- and match m = Vector.foreach (Match.rules m, exp o #2)
- and dec d =
- case Dec.node d of
- Exception _ => inc ()
- | Fun {decs, ...} => Vector.foreach (decs, match o #match)
- | Val {exp = e, ...} => exp e
- | _ => ()
- val _ = Vector.foreach (ds, dec)
- in
- !n
- end
-
- fun layoutStats p =
- let open Layout
- in seq [str "size = ", Int.layout (size p)]
- end
+(* fun typeCheck (T {decs, ...}) =
+ * let
+ * fun checkExp (e: Exp.t): Ty.t =
+ * let
+ * val (n, t) = Exp.dest e
+ * val
+ * datatype z = datatype Exp.t
+ * val t' =
+ * case n of
+ * App (e1, e2) =>
+ * let
+ * val t1 = checkExp e1
+ * val t2 = checkExp e2
+ * in
+ * case Type.deArrowOpt t1 of
+ * NONE => error "application of non-function"
+ * | SOME (u1, u2) =>
+ * if Type.equals (u1, t2)
+ * then t2
+ * else error "function/argument mismatch"
+ * end
+ * | Case {rules, test} =>
+ * let
+ * val {pat, exp} = Vector.sub (rules, 0)
+ * in
+ * Vector.foreach (rules, fn {pat, exp} =>
+ * Type.equals
+ * (checkPat pat,
+ * end
+ * in
+ *
+ * end
+ * in
+ * end
+ *)
end
end
1.9 +91 -94 mlton/mlton/core-ml/core-ml.sig
Index: core-ml.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/core-ml.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- core-ml.sig 14 Jan 2003 00:08:16 -0000 1.8
+++ core-ml.sig 9 Oct 2003 18:17:32 -0000 1.9
@@ -11,8 +11,20 @@
signature CORE_ML_STRUCTS =
sig
include ATOMS
- structure Type: TYPE
- sharing Type = Prim.Type
+ structure Type:
+ sig
+ type t
+
+ val arrow: t * t -> t
+ val bool: t
+ val deConOpt: t -> (Tycon.t * t vector) option
+ val deRecord: t -> (Record.Field.t * t) vector
+ val hom: {con: Tycon.t * 'a vector -> 'a,
+ var: Tyvar.t -> 'a} -> t -> 'a
+ val layout: t -> Layout.t
+ val tuple: t vector -> t
+ val unit: t
+ end
end
signature CORE_ML =
@@ -23,133 +35,119 @@
sig
type t
datatype node =
- Con of {
+ Con of {arg: t option,
con: Con.t,
- arg: t option
- }
- | Const of Ast.Const.t
- | Constraint of t * Type.t
+ targs: Type.t vector}
+ | Const of unit -> Const.t
| Layered of Var.t * t
- | Record of {
- flexible: bool,
- record: t Record.t
- }
+ | List of t vector
+ | Record of t Record.t
+ | Tuple of t vector
| Var of Var.t
| Wild
- include WRAPPED sharing type node' = node
- sharing type obj = t
- val foreachVar: t * (Var.t -> unit) -> unit
+ val dest: t -> node * Type.t
+ val falsee: t
(* true if pattern contains a constant, constructor or variable *)
val isRefutable: t -> bool
val isWild: t -> bool
val layout: t -> Layout.t
- val list: t list * Region.t -> t
- val record: {flexible: bool,
- record: t Record.t,
- region: Region.t} -> t
- (* removeOthersReplace(pat, old,new) replaces all variables in pat
- * with Wild, except for old, which it replaces with new
- *)
- val removeOthersReplace: t * Var.t * Var.t -> t
- val removeVars: t -> t (* replace all variables with Wild *)
- val toAst: t -> Ast.Pat.t (* conversion to Ast *)
- val tuple: t vector * Region.t -> t
- val unit: Region.t -> t
- (* a list (without duplicates) of variables occurring in a pattern *)
- val vars: t -> Var.t list
+ val make: node * Type.t -> t
+ val node: t -> node
+ val var: Var.t * Type.t -> t
+ val truee: t
+ val tuple: t vector -> t
+ val ty: t -> Type.t
end
structure Exp:
sig
type dec
- type match
+ type lambda
type t
+ datatype noMatch = Impossible | RaiseAgain | RaiseBind | RaiseMatch
datatype node =
App of t * t
- | Con of Con.t
- | Const of Ast.Const.t
- | Constraint of t * Type.t
- | Fn of {match: match,
- profile: SourceInfo.t option}
- | Handle of t * match
+ | Case of {noMatch: noMatch,
+ region: Region.t,
+ rules: (Pat.t * t) vector,
+ test: t}
+ | Con of Con.t * Type.t vector
+ | Const of unit -> Const.t
+ | EnterLeave of t * SourceInfo.t
+ | Handle of {catch: Var.t * Type.t,
+ handler: t,
+ try: t}
+ | Lambda of lambda
| Let of dec vector * t
- | Prim of Prim.t
+ | List of t vector
+ | PrimApp of {args: t vector,
+ prim: Prim.t,
+ targs: Type.t vector}
| Raise of {exn: t,
- filePos: string}
+ region: Region.t}
| Record of t Record.t
- | Var of Var.t
- include WRAPPED sharing type node' = node
- sharing type obj = t
+ | Seq of t vector
+ | Var of (unit -> Var.t) * (unit -> Type.t vector)
- val andAlso: t * t * Region.t -> t
- val casee: t * match * Region.t -> t
- val force: t * Region.t -> t
- val foreachVar: t * (Var.t -> unit) -> unit
- val iff: t * t * t * Region.t -> t
+ val andAlso: t * t -> t
+ val casee: {noMatch: noMatch,
+ region: Region.t,
+ rules: (Pat.t * t) vector,
+ test: t} -> t
+ val dest: t -> node * Type.t
+ val enterLeave: t * SourceInfo.t -> t
+ val iff: t * t * t -> t
+ val falsee: t
(* true if the expression may side-effect. See p 19 of Definition *)
val isExpansive: t -> bool
- val lambda: Var.t * t * SourceInfo.t option * Region.t -> t
+ val lambda: lambda -> t
val layout: t -> Layout.t
- val list: t list * Region.t -> t
- val orElse: t * t * Region.t -> t
- val selector: Record.Field.t * Region.t -> t
- val seq: t vector * Region.t -> t
- val tuple: t vector * Region.t -> t
- val unit: Region.t -> t
- val whilee: {test: t, expr: t, region: Region.t} -> t
+ val make: node * Type.t -> t
+ val node: t -> node
+ val orElse: t * t -> t
+ val truee: t
+ val tuple: t vector -> t
+ val ty: t -> Type.t
+ val unit: t
+ val var: Var.t * Type.t -> t
+ val whilee: {expr: t, test: t} -> t
end
- structure Match:
+ structure Lambda:
sig
type t
- val filePos: t -> string
- val new: {rules: (Pat.t * Exp.t) vector,
- filePos: string} -> t
- val region: t -> Region.t
- val rules: t -> (Pat.t * Exp.t) vector
+ val dest: t -> {arg: Var.t,
+ argType: Type.t,
+ body: Exp.t}
+ val layout: t -> Layout.t
+ val make: {arg: Var.t,
+ argType: Type.t,
+ body: Exp.t} -> t
end
- where type t = Exp.match
+ sharing type Exp.lambda = Lambda.t
structure Dec:
sig
- type t
- datatype node =
- Datatype of {
- tyvars: Tyvar.t vector,
+ datatype t =
+ Datatype of {cons: {arg: Type.t option,
+ con: Con.t} vector,
tycon: Tycon.t,
- cons: {
- con: Con.t,
- arg: Type.t option
- } vector
- } vector
- | Exception of {
- con: Con.t,
- arg: Type.t option
- }
- | Fun of {
- tyvars: Tyvar.t vector,
- decs: {match: Match.t,
- profile: SourceInfo.t option,
- types: Type.t vector, (* multiple constraints *)
- var: Var.t} vector
- }
- | Overload of {
- var: Var.t,
- scheme: Scheme.t,
- ovlds: Var.t vector
- }
- | Val of {exp: Exp.t,
- filePos: string,
- pat: Pat.t,
- tyvars: Tyvar.t vector}
- include WRAPPED sharing type node' = node
- sharing type obj = t
+ tyvars: Tyvar.t vector} vector
+ | Exception of {arg: Type.t option,
+ con: Con.t}
+ | Fun of {decs: {lambda: Lambda.t,
+ var: Var.t} vector,
+ tyvars: unit -> Tyvar.t vector}
+ | Val of {rvbs: {lambda: Lambda.t,
+ var: Var.t} vector,
+ tyvars: unit -> Tyvar.t vector,
+ vbs: {exp: Exp.t,
+ pat: Pat.t,
+ patRegion: Region.t} vector}
- val isExpansive: t -> bool
val layout: t -> Layout.t
- val toAst: t -> Ast.Dec.t
end
where type t = Exp.dec
@@ -158,6 +156,5 @@
datatype t = T of {decs: Dec.t vector}
val layout: t -> Layout.t
- val layoutStats: t -> Layout.t
end
end
1.4 +3 -7 mlton/mlton/core-ml/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.3
+++ sources.cm 9 Oct 2003 18:17:32 -0000 1.4
@@ -8,10 +8,8 @@
Group
signature CORE_ML
-signature LOOKUP_CONSTANT
functor CoreML
-functor DeadCode
-functor LookupConstant
+(*functor DeadCode *)
is
@@ -20,9 +18,7 @@
../control/sources.cm
../../lib/mlton/sources.cm
+core-ml.fun
core-ml.sig
-lookup-constant.sig
-lookup-constant.fun
+(*dead-code.fun *)
dead-code.sig
-dead-code.fun
-core-ml.fun
1.1 mlton/mlton/defunctorize/defunctorize.fun
Index: defunctorize.fun
===================================================================
functor Defunctorize (S: DEFUNCTORIZE_STRUCTS): DEFUNCTORIZE =
struct
open S
local
open CoreML
in
structure Const = Const
structure Cdec = Dec
structure Cexp = Exp
structure IntSize = IntSize
structure Clambda = Lambda
structure Cpat = Pat
structure Prim = Prim
structure Record = Record
structure Ctype = Type
structure WordSize = WordSize
end
structure IntX = Const.IntX
structure Field = Record.Field
local
open Xml
in
structure Xcases = Cases
structure Con = Con
structure Xdec = Dec
structure Xexp = DirectExp
structure Xlambda = Lambda
structure Xpat = Pat
structure XprimExp = PrimExp
structure Tycon = Tycon
structure Xtype = Type
structure Tyvar = Tyvar
structure Var = Var
structure XvarExp = VarExp
end
structure Region =
struct
open Region
fun toFilePos r = Option.map (left r, SourcePos.toString)
end
structure NestedPat = NestedPat (open Xml)
structure MatchCompile =
MatchCompile (open CoreML
structure Type = Xtype
structure NestedPat = NestedPat
structure Cases =
struct
type exp = Xexp.t
open Xcases
type t = exp t
val int = Int
val word = Word
fun con v =
Con (Vector.map
(v, fn {con, targs, arg, rhs} =>
(Xpat.T {con = con,
targs = targs,
arg = arg},
rhs)))
end
structure Exp =
struct
open Xexp
val lett = let1
val var = monoVar
fun detuple {tuple, body} =
Xexp.detuple
{tuple = tuple,
body = fn xts => body (Vector.map
(xts, fn (x, t) =>
(XvarExp.var x, t)))}
end)
structure Xexp =
struct
open Xexp
local
fun exn (c: Con.t): Xexp.t =
conApp {arg = NONE,
con = c,
targs = Vector.new0 (),
ty = Xtype.exn}
in
val bind = exn Con.bind
val match = exn Con.match
end
end
fun casee {caseType: Xtype.t,
cases: (NestedPat.t * Xexp.t) vector,
conTycon,
noMatch,
region: Region.t,
test = (test: Xexp.t, testType: Xtype.t),
tyconCons}: Xexp.t =
let
fun raiseExn f =
let
val e = Var.newNoname ()
in
Vector.concat
[cases,
Vector.new1 (NestedPat.make (NestedPat.Var e, testType),
Xexp.raisee ({exn = f e,
filePos = Region.toFilePos region},
caseType))]
end
val cases =
let
datatype z = datatype Cexp.noMatch
in
case noMatch of
Impossible => cases
| RaiseAgain => raiseExn (fn e => Xexp.monoVar (e, Xtype.exn))
| RaiseBind => raiseExn (fn _ => Xexp.bind)
| RaiseMatch => raiseExn (fn _ => Xexp.match)
end
fun matchCompile () =
let
val (cases, decs) =
Vector.mapAndFold
(cases, [], fn ((p: NestedPat.t, e: Xexp.t), decs) =>
let
val args = Vector.fromList (NestedPat.varsAndTypes p)
val (vars, tys) = Vector.unzip args
val func = Var.newNoname ()
val arg = Var.newNoname ()
val argType = Xtype.tuple tys
val funcType = Xtype.arrow (argType, caseType)
val dec =
Xdec.MonoVal
{var = func,
ty = funcType,
exp =
XprimExp.Lambda
(Xlambda.make
{arg = arg,
argType = argType,
body =
Xexp.toExp
(Xexp.detupleBind
{tuple = Xexp.monoVar (arg, argType),
components = vars,
body = e})})}
fun finish rename =
Xexp.app
{func = Xexp.monoVar (func, funcType),
arg =
Xexp.tuple {exps = (Vector.map
(args, fn (x, t) =>
Xexp.monoVar (rename x, t))),
ty = argType},
ty = caseType}
in ((p, finish), dec :: decs)
end)
val testVar = Var.newNoname ()
in
Xexp.let1
{var = testVar,
exp = test,
body =
Xexp.lett
{decs = decs,
body = MatchCompile.matchCompile {caseType = caseType,
cases = cases,
conTycon = conTycon,
region = region,
test = testVar,
testType = testType,
tyconCons = tyconCons}}}
end
datatype z = datatype NestedPat.node
fun lett (x, e) = Xexp.let1 {var = x, exp = test, body = e}
fun wild e = lett (Var.newNoname (), e)
fun normal () =
if Vector.isEmpty cases
then Error.bug "case with no patterns"
else
let
val (p, e) = Vector.sub (cases, 0)
in
case NestedPat.node p of
Wild => wild e
| Var x => lett (x, e)
| Tuple ps =>
if Vector.forall (ps, NestedPat.isVar)
then
(* It's a flat tuple pattern.
* Generate the selects.
*)
let
val t = Var.newNoname ()
val tuple = XvarExp.mono t
val tys = Xtype.deTuple testType
val (_, decs) =
Vector.fold2
(ps, tys, (0, []),
fn (p, ty, (i, decs)) =>
case NestedPat.node p of
Var x =>
(i + 1,
Xdec.MonoVal
{var = x,
ty = ty,
exp = (XprimExp.Select
{tuple = tuple,
offset = i})}
:: decs)
| _ => Error.bug "infer flat tuple")
in Xexp.let1 {var = t, exp = test,
body = Xexp.lett {decs = decs,
body = e}}
end
else matchCompile ()
| _ => matchCompile ()
end
fun make (ac, default) =
Xexp.casee {test = test,
default = default,
ty = caseType,
cases = Xcases.Con (Vector.fromList ac)}
fun step (_, (p, e), ac) =
case NestedPat.node p of
NestedPat.Wild =>
Vector.Done
(case ac of
[] => wild e
| _ => make (ac, SOME (e, region)))
| _ => Vector.Done (normal ())
fun done ac = make (ac, NONE)
in
Vector.fold' (cases, 0, [], step, done)
end
val casee =
Trace.trace ("Defunctorize.casee",
Region.layout o #region,
Xml.Exp.layout o Xexp.toExp)
casee
fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector =
Vector.map (QuickSort.sortVector (v, fn ((f, _), (f', _)) =>
Field.<= (f, f')),
#2)
fun valDec (tyvars: Tyvar.t vector,
x: Var.t,
e: Xexp.t,
et: Xtype.t,
e': Xexp.t): Xexp.t =
Xexp.lett {body = e',
decs = [Xdec.PolyVal {exp = Xexp.toExp e,
ty = et,
tyvars = tyvars,
var = x}]}
fun defunctorize (CoreML.Program.T {decs}) =
let
val loopTy = Ctype.hom {con = fn (c, ts) => if Tycon.equals (c, Tycon.char)
then Xtype.word8
else Xtype.con (c, ts),
var = Xtype.var}
val {get = conTycon, set = setConTycon, ...} =
Property.getSetOnce (Con.plist,
Property.initRaise ("conTycon", Con.layout))
val {get = tyconCons: Tycon.t -> Con.t vector,
set = setTyconCons, ...} =
Property.getSetOnce (Tycon.plist,
Property.initRaise ("tyconCons", Tycon.layout))
val setConTycon =
Trace.trace2 ("setConTycon", Con.layout, Tycon.layout, Unit.layout)
setConTycon
val datatypes = ref []
(* Process all the datatypes. *)
fun loopDec (d: Cdec.t) =
let
(* datatype z = datatype Cdec.t *)
open Cdec
in
case d of
Datatype dbs =>
Vector.foreach
(dbs, fn {cons, tycon, tyvars} =>
let
val _ = setTyconCons (tycon, Vector.map (cons, #con))
val cons =
Vector.map
(cons, fn {arg, con} =>
(setConTycon (con, tycon)
; {arg = Option.map (arg, loopTy),
con = con}))
val _ =
if Tycon.equals (tycon, Tycon.reff)
then ()
else
List.push (datatypes, {cons = cons,
tycon = tycon,
tyvars = tyvars})
in
()
end)
| Exception {con, ...} => setConTycon (con, Tycon.exn)
| Fun {decs, ...} => Vector.foreach (decs, loopLambda o #lambda)
| Val {rvbs, vbs, ...} =>
(Vector.foreach (rvbs, loopLambda o #lambda)
; Vector.foreach (vbs, loopExp o #exp))
end
and loopExp (e: Cexp.t): unit =
let
datatype z = datatype Cexp.node
in
case Cexp.node e of
App (e, e') => (loopExp e; loopExp e')
| Case {rules, test, ...} =>
(loopExp test
; Vector.foreach (rules, loopExp o #2))
| Con _ => ()
| Const _ => ()
| EnterLeave (e, _) => loopExp e
| Handle {handler, try, ...} => (loopExp handler; loopExp try)
| Lambda l => loopLambda l
| Let (ds, e) => (Vector.foreach (ds, loopDec); loopExp e)
| List es => Vector.foreach (es, loopExp)
| PrimApp {args, ...} => Vector.foreach (args, loopExp)
| Raise {exn, ...} => loopExp exn
| Record r => Record.foreach (r, loopExp)
| Seq es => Vector.foreach (es, loopExp)
| Var _ => ()
end
and loopLambda (l: Clambda.t): unit =
loopExp (#body (Clambda.dest l))
fun loopPat (p: Cpat.t): NestedPat.t =
let
val (p, t) = Cpat.dest p
val t' = loopTy t
datatype z = datatype Cpat.node
val p =
case p of
Con {arg, con, targs} =>
NestedPat.Con {arg = Option.map (arg, loopPat),
con = con,
targs = Vector.map (targs, loopTy)}
| Const f => NestedPat.Const (f ())
| Layered (x, p) => NestedPat.Layered (x, loopPat p)
| List ps =>
let
val targs = Vector.map (#2 (valOf (Ctype.deConOpt t)),
loopTy)
in
Vector.foldr
(ps,
NestedPat.Con {arg = NONE,
con = Con.nill,
targs = targs},
fn (p, np) =>
NestedPat.Con {arg = SOME (NestedPat.tuple
(Vector.new2
(loopPat p,
NestedPat.make (np, t')))),
con = Con.cons,
targs = targs})
end
| Record r =>
NestedPat.Tuple
(Vector.map
(Ctype.deRecord t, fn (f, t: Ctype.t) =>
case Record.peek (r, f) of
NONE => NestedPat.make (NestedPat.Wild, loopTy t)
| SOME p => loopPat p))
| Tuple ps => NestedPat.Tuple (Vector.map (ps, loopPat))
| Var x => NestedPat.Var x
| Wild => NestedPat.Wild
in
NestedPat.make (p, t')
end
val _ = Vector.foreach (decs, loopDec)
(* Now, do the actual defunctorization. *)
fun loopDec (d: Cdec.t, e: Xexp.t, et: Xtype.t): Xexp.t =
let
fun prefix (d: Xdec.t) =
Xexp.lett {decs = [d], body = e}
fun processLambdas v =
Vector.map
(v, fn {lambda, var} =>
let
val {arg, argType, body, bodyType} = loopLambda lambda
in
{lambda = Xlambda.make {arg = arg,
argType = argType,
body = Xexp.toExp body},
ty = Xtype.arrow (argType, bodyType),
var = var}
end)
(* Use open Cdec instead of the following due to an SML/NJ 110.43 bug *)
(* datatype z = datatype Cdec.t *)
open Cdec
in
case d of
Datatype _ => e
| Exception {arg, con} =>
prefix (Xdec.Exception {arg = Option.map (arg, loopTy),
con = con})
| Fun {decs, tyvars} =>
prefix (Xdec.Fun {decs = processLambdas decs,
tyvars = tyvars ()})
| Val {rvbs, tyvars, vbs} =>
let
val tyvars = tyvars ()
val bodyType = et
fun patDec (p: NestedPat.t,
e: Xexp.t,
r: Region.t,
body: Xexp.t,
bodyType: Xtype.t) =
casee {caseType = bodyType,
cases = Vector.new1 (p, body),
conTycon = conTycon,
noMatch = Cexp.RaiseBind,
region = r,
test = (e, NestedPat.ty p),
tyconCons = tyconCons}
val e =
Vector.foldr
(vbs, e, fn ({exp, pat, patRegion}, e) =>
let
val (exp, expType) = loopExp exp
val pat = loopPat pat
fun vd (x: Var.t) = valDec (tyvars, x, exp, expType, e)
in
if Vector.isEmpty tyvars
then patDec (pat, exp, patRegion, e, bodyType)
else
case NestedPat.node pat of
NestedPat.Wild => vd (Var.newNoname ())
| NestedPat.Var x => vd x
| _ =>
(* Polymorphic pattern.
* val 'a Foo (y1, y2) = e
* Expands to
* val 'a x = e
* val Foo _ = x
* val 'a y1 = case x of Foo (y1', _) => y1'
* val 'a y2 = case x of Foo (_, y2') => y2'
*)
let
val x = Var.newNoname ()
val xt = expType
val targs = Vector.map (tyvars, Xtype.var)
val e =
List.fold
(NestedPat.varsAndTypes pat, e,
fn ((y, yt), e) =>
let
val y' = Var.new y
val pat =
NestedPat.removeOthersReplace
(pat, {old = y, new = y'})
in
valDec
(tyvars,
y,
patDec (pat,
Xexp.var {targs = targs,
ty = xt,
var = x},
patRegion,
Xexp.monoVar (y', yt),
yt),
yt,
e)
end)
fun instantiatePat () =
let
val pat = NestedPat.removeVars pat
fun con (_, c, ts) = Xtype.con (c, ts)
fun var (t, a) =
if (Vector.exists
(tyvars, fn a' =>
Tyvar.equals (a, a')))
then Xtype.unit
else t
val {destroy, hom} =
Xtype.makeHom {con = con,
var = var}
val pat =
NestedPat.replaceTypes
(pat, hom)
val _ = destroy ()
in
pat
end
val e =
if NestedPat.isRefutable pat
then
let
val targs =
Vector.map (tyvars, fn _ =>
Xtype.unit)
val pat = instantiatePat ()
in
patDec
(pat,
Xexp.var
{targs = targs,
ty = NestedPat.ty pat,
var = x},
patRegion,
e,
bodyType)
end
else e
in
valDec (tyvars, x, exp, expType, e)
end
end)
in
if 0 = Vector.length rvbs
then e
else
Xexp.lett {decs = [Xdec.Fun {decs = processLambdas rvbs,
tyvars = tyvars}],
body = e}
end
end
and loopDecs (ds: Cdec.t vector, (e: Xexp.t, t: Xtype.t)): Xexp.t =
Vector.foldr (ds, e, fn (d, e) => loopDec (d, e, t))
and loopExp (e: Cexp.t): Xexp.t * Xtype.t =
let
val (n, ty) = Cexp.dest e
val ty = loopTy ty
fun conApp {arg, con, targs, ty} =
if Con.equals (con, Con.reff)
then Xexp.primApp {args = Vector.new1 arg,
prim = Prim.reff,
targs = targs,
ty = ty}
else Xexp.conApp {arg = SOME arg,
con = con,
targs = targs,
ty = ty}
datatype z = datatype Cexp.node
val exp =
case n of
App (e1, e2) =>
let
val (e2, _) = loopExp e2
in
case Cexp.node e1 of
Con (con, targs) =>
conApp {arg = e2,
con = con,
targs = Vector.map (targs, loopTy),
ty = ty}
| _ =>
Xexp.app {arg = e2,
func = #1 (loopExp e1),
ty = ty}
end
| Case {noMatch, region, rules, test} =>
casee {caseType = ty,
cases = Vector.map (rules, fn (pat, exp) =>
(loopPat pat,
#1 (loopExp exp))),
conTycon = conTycon,
noMatch = noMatch,
region = region,
test = loopExp test,
tyconCons = tyconCons}
| Con (con, targs) =>
let
val targs = Vector.map (targs, loopTy)
in
case Xtype.deArrowOpt ty of
NONE =>
Xexp.conApp {arg = NONE,
con = con,
targs = targs,
ty = ty}
| SOME (argType, bodyType) =>
let
val arg = Var.newNoname ()
in
Xexp.lambda
{arg = arg,
argType = argType,
body = (conApp
{arg = Xexp.monoVar (arg, argType),
con = con,
targs = targs,
ty = bodyType}),
bodyType = bodyType}
end
end
| Const f =>
let
val c = f ()
in
if Xtype.equals (ty, Xtype.bool)
then
(case c of
Const.Int i =>
if 0 = IntX.toInt i
then Xexp.falsee ()
else Xexp.truee ()
| _ => Error.bug "strange boolean constant")
else Xexp.const c
end
| EnterLeave (e, si) =>
let
val (e, t) = loopExp e
in
Xexp.fromExp (Xml.Exp.enterLeave (Xexp.toExp e, t, si),
t)
end
| Handle {catch = (x, t), handler, try} =>
Xexp.handlee {catch = (x, loopTy t),
handler = #1 (loopExp handler),
try = #1 (loopExp try),
ty = ty}
| Lambda l => Xexp.lambda (loopLambda l)
| Let (ds, e) => loopDecs (ds, loopExp e)
| List es =>
let
val targs = #2 (valOf (Xtype.deConOpt ty))
val eltTy = Vector.sub (targs, 0)
in
Vector.foldr
(es,
Xexp.conApp {arg = NONE,
con = Con.nill,
targs = targs,
ty = ty},
fn (e, l) =>
Xexp.conApp
{arg = (SOME
(Xexp.tuple
{exps = Vector.new2 (#1 (loopExp e), l),
ty = Xtype.tuple (Vector.new2 (eltTy, ty))})),
con = Con.cons,
targs = targs,
ty = ty})
end
| PrimApp {args, prim, targs} =>
let
val args = Vector.map (args, #1 o loopExp)
val targs = Vector.map (targs, loopTy)
fun app prim =
Xexp.primApp {args = args,
prim = prim,
targs = targs,
ty = ty}
fun id () = Vector.sub (args, 0)
datatype z = datatype Prim.Name.t
datatype z = datatype WordSize.t
in
case Prim.name prim of
C_CS_charArrayToWord8Array => id ()
| Char_chr =>
app (Prim.intToWord (IntSize.default, W8))
| Char_ge => app (Prim.wordGe W8)
| Char_gt => app (Prim.wordGt W8)
| Char_le => app (Prim.wordLe W8)
| Char_lt => app (Prim.wordLt W8)
| Char_ord =>
app (Prim.wordToInt (W8, IntSize.default))
| Char_toWord8 => id ()
| String_toWord8Vector => id ()
| Word8_toChar => id ()
| Word8Vector_toString => id ()
| _ => app prim
end
| Raise {exn, region} =>
Xexp.raisee ({exn = #1 (loopExp exn),
filePos = Region.toFilePos region},
ty)
| Record r =>
(* The components of the record have to be evaluated left to
* right as they appeared in the source program, but then
* ordered according to sorted field name within the tuple.
*)
let
val fes = Record.toVector r
in
Xexp.seq
(Vector.map (fes, #1 o loopExp o #2), fn es =>
Xexp.tuple {exps = (sortByField
(Vector.map2
(fes, es, fn ((f, _), e) => (f, e)))),
ty = ty})
end
| Seq es => Xexp.sequence (Vector.map (es, #1 o loopExp))
| Var (var, targs) =>
Xexp.var {targs = Vector.map (targs (), loopTy),
ty = ty,
var = var ()}
in
(exp, ty)
end
and loopLambda (l: Clambda.t) =
let
val {arg, argType, body} = Clambda.dest l
val (body, bodyType) = loopExp body
in
{arg = arg,
argType = loopTy argType,
body = body,
bodyType = bodyType}
end
val body = loopDecs (decs, (Xexp.unit (), Xtype.unit))
in
Xml.Program.T {body = Xexp.toExp body,
datatypes = Vector.fromList (!datatypes),
overflow = NONE}
end
end
1.1 mlton/mlton/defunctorize/defunctorize.sig
Index: defunctorize.sig
===================================================================
signature DEFUNCTORIZE_STRUCTS =
sig
structure CoreML: CORE_ML
structure Xml: XML
sharing CoreML.Atoms = Xml.Atoms
end
signature DEFUNCTORIZE =
sig
include DEFUNCTORIZE_STRUCTS
val defunctorize: CoreML.Program.t -> Xml.Program.t
end
1.1 mlton/mlton/defunctorize/sources.cm
Index: sources.cm
===================================================================
Group
functor Defunctorize
is
../../lib/mlton/sources.cm
../control/sources.cm
../core-ml/sources.cm
../match-compile/sources.cm
../xml/sources.cm
defunctorize.fun
defunctorize.sig
1.4 +3 -6 mlton/mlton/elaborate/decs.fun
Index: decs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/decs.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- decs.fun 10 Apr 2002 07:02:20 -0000 1.3
+++ decs.fun 9 Oct 2003 18:17:33 -0000 1.4
@@ -10,6 +10,8 @@
open S
+structure Dec = CoreML.Dec
+
type dec = CoreML.Dec.t
open AppendList
@@ -20,16 +22,11 @@
val fromDec = single
-fun toAsts ds =
- Vector.map (toVector ds, CoreML.Dec.toAst)
-
-fun toAst ds = Ast.Dec.makeRegion (Ast.Dec.SeqDec (toAsts ds), Region.bogus)
-
fun layout ds =
let
open Layout
in
- align (Vector.toListMap (toAsts ds, Ast.Dec.layout))
+ align (Vector.toListMap (toVector ds, Dec.layout))
end
end
1.3 +0 -3 mlton/mlton/elaborate/decs.sig
Index: decs.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/decs.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- decs.sig 10 Apr 2002 07:02:20 -0000 1.2
+++ decs.sig 9 Oct 2003 18:17:33 -0000 1.3
@@ -7,9 +7,7 @@
*)
signature DECS_STRUCTS =
sig
- structure Ast: AST
structure CoreML: CORE_ML
- sharing Ast = CoreML.Ast
end
signature DECS =
@@ -31,7 +29,6 @@
val layout: t -> Layout.t
val map: t * (dec -> dec) -> t
val single: dec -> t
- val toAst: t -> Ast.Dec.t
val toList: t -> dec list
val toVector: t -> dec vector
end
1.28 +1474 -667 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- elaborate-core.fun 27 Aug 2003 21:13:33 -0000 1.27
+++ elaborate-core.fun 9 Oct 2003 18:17:33 -0000 1.28
@@ -10,13 +10,8 @@
open S
-local open Env
-in
- structure TypeStr = TypeStr
- structure Vid = Vid
-end
-
-local open Ast
+local
+ open Ast
in
structure Aconst = Const
structure Adec = Dec
@@ -39,24 +34,47 @@
structure TypBind = TypBind
end
-local open CoreML
+local
+ open Env
+in
+ structure TypeEnv = TypeEnv
+ structure TypeStr = TypeStr
+ structure Vid = Vid
+end
+
+structure Kind = TypeStr.Kind
+
+local
+ open TypeEnv
+in
+ structure Scheme = InferScheme
+ structure Type = Type
+end
+
+local
+ open CoreML
in
structure CFunction = CFunction
structure Convention = CFunction.Convention
structure CType = CType
structure Con = Con
+ structure Const = Const
structure Cdec = Dec
structure Cexp = Exp
- structure Cmatch = Match
- structure Cpat = Pat
- structure Cprim = Prim
- structure Cvar = Var
structure Ffi = Ffi
- structure Scheme = Scheme
+ structure IntSize = IntSize
+ structure IntX = IntX
+ structure Lambda = Lambda
+ structure Cpat = Pat
+ structure Prim = Prim
+ structure RealSize = RealSize
+ structure RealX = RealX
structure SourceInfo = SourceInfo
structure Tycon = Tycon
- structure Type = Type
structure Tyvar = Tyvar
+ structure Var = Var
+ structure WordSize = WordSize
+ structure WordX = WordX
end
local
@@ -70,6 +88,20 @@
structure Scope = Scope (structure Ast = Ast)
+structure Aconst =
+ struct
+ open Aconst
+
+ fun ty (c: t): Type.t =
+ case node c of
+ Bool _ => Type.bool
+ | Char _ => Type.char
+ | Int _ => Type.unresolvedInt ()
+ | Real _ => Type.unresolvedReal ()
+ | String _ => Type.string
+ | Word _ => Type.unresolvedWord ()
+ end
+
structure Apat =
struct
open Apat
@@ -101,8 +133,8 @@
fun plusEnv (lookup: t, E: Env.t): t =
fn longtycon =>
case Env.peekLongtycon (E, longtycon) of
- SOME typeFcn => typeFcn
- | NONE => lookup longtycon
+ NONE => lookup longtycon
+ | SOME typeFcn => typeFcn
fun plusTycons (f: t, v) =
if Vector.isEmpty v
@@ -117,139 +149,277 @@
| _ => f t)
end
-(*
- * Replaces all tyvars that have the same name with a single tyvar.
- *)
-fun elaborateType (ty: Atype.t, lookup: Lookup.t): Scheme.t =
+fun newType () = Type.new {canGeneralize = true,
+ equality = false}
+
+fun elaborateType (ty: Atype.t, lookup: Lookup.t): Type.t =
let
- fun loop (ty: Atype.t, accum: Tyvar.t list): Type.t * Tyvar.t list =
+ fun loop (ty: Atype.t): Type.t =
case Atype.node ty of
Atype.Var a => (* rule 44 *)
- let
- fun loop tyvars =
- case tyvars of
- [] => (* new type variable, add it to the accum *)
- (Type.var a, a :: accum)
- | a' :: tyvars =>
- if Tyvar.sameName (a, a')
- then (Type.var a', accum)
- else loop tyvars
- in loop accum
- end
+ Type.var a
| Atype.Con (c, ts) => (* rules 46, 47 *)
let
- val (ts, accum) = loops (ts, accum)
- fun normal () = TypeStr.apply (lookup c, ts)
- in (case (Ast.Longtycon.split c, Vector.length ts) of
- (([], c), 2) =>
- if Ast.Tycon.equals (c, Ast.Tycon.arrow)
- then Type.arrow (Vector.sub (ts, 0),
- Vector.sub (ts, 1))
- else normal ()
- | _ => normal (),
- accum)
- end
- | Atype.Record r => (* rules 45, 49 *)
- let
- val (fs, ts) = SortedRecord.unzip r
- val (ts, accum) = loops (ts, accum)
+ val ts = Vector.map (ts, loop)
+ fun normal () =
+ let
+ val s = lookup c
+ val kind = TypeStr.kind s
+ val numArgs = Vector.length ts
+ in
+ if (case kind of
+ Kind.Arity n => n = numArgs
+ | Kind.Nary => true)
+ then TypeStr.apply (s, ts)
+ else
+ let
+ open Layout
+ val _ =
+ Control.error
+ (Atype.region ty,
+ seq [str "type constructor ",
+ Ast.Longtycon.layout c,
+ str " given ",
+ Int.layout numArgs,
+ str " arguments but wants ",
+ Kind.layout kind],
+ empty)
+ in
+ newType ()
+ end
+ end
in
- (Type.record (SortedRecord.zip (fs, ts)), accum)
+ case (Ast.Longtycon.split c, Vector.length ts) of
+ (([], c), 2) =>
+ if Ast.Tycon.equals (c, Ast.Tycon.arrow)
+ then Type.arrow (Vector.sub (ts, 0),
+ Vector.sub (ts, 1))
+ else normal ()
+ | _ => normal ()
end
- and loops (ts, ac) = Vector.mapAndFold (ts, ac, loop)
- val (ty, tyvars) = loop (ty, [])
- in Scheme.T {tyvars = Vector.fromList tyvars, ty = ty}
+ | Atype.Record r => (* rules 45, 49 *)
+ Type.record (SortedRecord.map (r, loop))
+ in
+ loop ty
end
-fun elaborateTypeOpt (ty, lookup) =
- Option.map (ty, fn ty => Scheme.ty (elaborateType (ty, lookup)))
+fun elaborateTypeOpt (ty: Ast.Type.t option, lookup): Type.t option =
+ Option.map (ty, fn ty => elaborateType (ty, lookup))
-(* Returns a scheme, plus the type variables that occured in the ty but
- * not in the tyvars.
- *)
-fun elaborateScheme (tyvars, ty: Atype.t, lookup: Lookup.t)
- : Scheme.t * Tyvar.t list =
- let val Scheme.T {tyvars = tyvars', ty} = elaborateType (ty, lookup)
- (* Replace each tyvar with the corresponding tyvar'.
- * Keep track of any tyvars' that are left over.
- *)
- val (tyvars, tyvars') =
- Vector.foldr
- (tyvars, ([], Vector.toList tyvars'), fn (a, (tyvars, tyvars')) =>
- let
- fun loop (tyvars', remaining) =
- case tyvars' of
- [] => (a, remaining)
- | a' :: tyvars' =>
- if Tyvar.sameName (a, a')
- then (a', remaining @ tyvars')
- else loop (tyvars', a' :: remaining)
- val (a, tyvars') = loop (tyvars', [])
- in (a :: tyvars, tyvars')
- end)
- in (Scheme.T {tyvars = Vector.fromList tyvars, ty = ty}, tyvars')
- end
+val overloads: (unit -> unit) list ref = ref []
+val freeTyvarChecks: (unit -> unit) list ref = ref []
-fun elaborateClosedScheme arg: Scheme.t =
+val typeTycon: Type.t -> Tycon.t option =
+ Type.hom {con = fn (c, _) => SOME c,
+ var = fn _ => NONE}
+
+fun resolveConst (c: Aconst.t, ty: Type.t): Const.t =
let
- val (scheme, tyvars) = elaborateScheme arg
- val _ =
- case tyvars of
- [] => ()
- | tyvar :: _ =>
- Control.error
- (Tyvar.region tyvar,
- let open Layout
- in seq [str "unbound type variables: ",
- seq (separate (List.map (tyvars, Tyvar.layout), " "))]
- end,
- Layout.empty)
+ fun error m =
+ Control.error (Aconst.region c,
+ Layout.str (concat [m, ": ", Aconst.toString c]),
+ Layout.empty)
+ val tycon =
+ case typeTycon ty of
+ NONE =>
+ Error.bug (concat ["constant ", Aconst.toString c,
+ " of strange type ",
+ Layout.toString (Type.layoutPretty ty)])
+ | SOME c => c
+ fun choose (all, sizeTycon, name, make) =
+ case List.peek (all, fn s => Tycon.equals (tycon, sizeTycon s)) of
+ NONE => Error.bug (concat ["strange ", name, " type: ",
+ Layout.toString (Type.layout ty)])
+ | SOME s => make s
in
- scheme
+ case Aconst.node c of
+ Aconst.Bool _ => Error.bug "resolveConst can't handle bools"
+ | Aconst.Char c =>
+ Const.Word (WordX.make (LargeWord.fromChar c, WordSize.W8))
+ | Aconst.Int i =>
+ if Tycon.equals (tycon, Tycon.intInf)
+ then Const.IntInf i
+ else
+ choose (IntSize.all, Tycon.int, "int", fn s =>
+ Const.Int
+ (IntX.make (i, s)
+ handle Overflow =>
+ (error (concat [Type.toString ty, " too big"])
+ ; IntX.zero s)))
+ | Aconst.Real r =>
+ choose (RealSize.all, Tycon.real, "real", fn s =>
+ Const.Real (RealX.make (r, s)))
+ | Aconst.String s => Const.string s
+ | Aconst.Word w =>
+ choose (WordSize.all, Tycon.word, "word", fn s =>
+ Const.Word
+ (if w <= LargeWord.toIntInf (WordSize.max s)
+ then WordX.fromLargeInt (w, s)
+ else (error (concat [Type.toString ty, " too big"])
+ ; WordX.zero s)))
end
-fun elaborateTypBind (typBind, lookup: Lookup.t)
- : (Ast.Tycon.t * TypeStr.t) list =
+local
+ open Layout
+in
+ val align = align
+ val empty = empty
+ val seq = seq
+ val str = str
+end
+
+fun unify (t1: Type.t, t2: Type.t,
+ f: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t): unit =
let
- val TypBind.T types = TypBind.node typBind
+ datatype z = datatype Type.unifyResult
in
- List.revMap
- (types, fn {tyvars, tycon, def} =>
- (tycon, TypeStr.def (elaborateClosedScheme (tyvars, def, lookup))))
+ case Type.unify (t1, t2) of
+ NotUnifiable z => Control.error (f z)
+ | Unified => ()
end
+fun unifyList (trs: (Type.t * Region.t) vector): Type.t =
+ if 0 = Vector.length trs
+ then Type.list (newType ())
+ else
+ let
+ val (t, _) = Vector.sub (trs, 0)
+ val _ =
+ Vector.foreach
+ (trs, fn (t', r) =>
+ unify (t, t', fn (l, l') =>
+ (r,
+ str "list elements must be of same type",
+ align [seq [str "element: ", l'],
+ seq [str "previous: ", l]])))
+ in
+ Type.list t
+ end
+
val info = Trace.info "elaboratePat"
-fun elaboratePat (p: Apat.t, E: Env.t): Cpat.t =
+structure Var =
+ struct
+ open Var
+
+ val fromAst = fromString o Avar.toString
+ end
+
+fun elaboratePat (p: Apat.t, E: Env.t, amInRvb: bool)
+ : Cpat.t * (Avar.t * Var.t * Type.t) vector =
let
- fun bind (x: Ast.Var.t): Cvar.t =
+ val xts: (Avar.t * Var.t * Type.t) list ref = ref []
+ fun bindToType (x: Ast.Var.t, t: Type.t): Var.t =
let
- val x' = Cvar.fromAst x
- val _ = Env.extendVar (E, x, x')
- in x'
+ val x' = Var.fromAst x
+ val _ = List.push (xts, (x, x', t))
+ val _ = Env.extendVar (E, x, x', Scheme.fromType t)
+ in
+ x'
+ end
+ fun bind (x: Ast.Var.t): Var.t * Type.t =
+ let
+ val t = newType ()
+ in
+ (bindToType (x, t), t)
end
fun loop arg: Cpat.t =
Trace.traceInfo' (info, Apat.layout, Cpat.layout)
(fn p: Apat.t =>
let
val region = Apat.region p
- fun doit n = Cpat.makeRegion (n, region)
+ fun error (e1, e2) =
+ Control.error (region, e1, e2)
+ fun unifyPatternConstraint (p, c) =
+ unify
+ (p, c, fn (l1, l2) =>
+ (region,
+ str "pattern and constraint don't agree",
+ align [seq [str "pattern: ", l1],
+ seq [str "constraint: ", l2]]))
in
case Apat.node p of
- Apat.Wild => doit Cpat.Wild
- | Apat.Var {name = x, ...} =>
- (case Env.peekLongcon (E, Ast.Longvid.toLongcon x) of
- SOME c => doit (Cpat.Con {con = c, arg = NONE})
- | NONE =>
- (case Ast.Longvid.split x of
- ([], x) =>
- doit (Cpat.Var (bind (Ast.Vid.toVar x)))
- | _ => Error.bug (concat ["longid in var pat: ",
- Ast.Longvid.toString x])))
- | Apat.Const c => doit (Cpat.Const c)
- | Apat.Tuple ps =>
- loopsContV (ps, fn ps => Cpat.tuple (ps, region))
- | Apat.Record {items, flexible} =>
+ Apat.App (c, p) =>
+ let
+ val (con, s) = Env.lookupLongcon (E, c)
+ val {args, instance} = Scheme.instantiate s
+ val args = args ()
+ val p = loop p
+ val res =
+ case Type.deArrowOpt instance of
+ NONE =>
+ let
+ val _ =
+ error
+ (seq [str "constant constructor applied to argument in pattern: ",
+ Ast.Longcon.layout c],
+ empty)
+ in
+ newType ()
+ end
+ | SOME (u1, u2) =>
+ let
+ val _ =
+ unify
+ (Cpat.ty p, u1, fn (l, l') =>
+ (region,
+ str "constructor and argument don't agree in pattern",
+ align
+ [seq [str "constructor expects: ", l],
+ seq [str "but got: ", l']]))
+ in
+ u2
+ end
+ in
+ Cpat.make (Cpat.Con {arg = SOME p,
+ con = con,
+ targs = args},
+ res)
+ end
+ | Apat.Const c =>
+ (case Aconst.node c of
+ Aconst.Bool b => if b then Cpat.truee else Cpat.falsee
+ | _ =>
+ let
+ val ty = Aconst.ty c
+ fun resolve () = resolveConst (c, ty)
+ val _ = List.push (overloads, fn () =>
+ (resolve (); ()))
+ in
+ Cpat.make (Cpat.Const resolve, ty)
+ end)
+ | Apat.Constraint (p, t) =>
+ let
+ val p = loop p
+ val _ =
+ unifyPatternConstraint
+ (Cpat.ty p, elaborateType (t, Lookup.fromEnv E))
+ in
+ p
+ end
+ | Apat.FlatApp items => loop (Parse.parsePat (items, E))
+ | Apat.Layered {var = x, constraint, pat, ...} =>
+ let
+ val t =
+ case constraint of
+ NONE => newType ()
+ | SOME t => elaborateType (t, Lookup.fromEnv E)
+ val x = bindToType (x, t)
+ val pat = loop pat
+ val _ = unifyPatternConstraint (t, Cpat.ty pat)
+ in
+ Cpat.make (Cpat.Layered (x, pat), t)
+ end
+ | Apat.List ps =>
+ let
+ val ps' = Vector.map (ps, loop)
+ in
+ Cpat.make (Cpat.List ps',
+ unifyList
+ (Vector.map2 (ps, ps', fn (p, p') =>
+ (Cpat.ty p', Apat.region p))))
+ end
+ | Apat.Record {flexible, items} =>
(* rules 36, 38, 39 and Appendix A, p.57 *)
let
val (fs, ps) =
@@ -275,48 +445,85 @@
NONE => p
| SOME ty => Apat.constraint (p, ty)
end)))
+ val ps = Vector.map (ps, loop)
+ val r = SortedRecord.zip (fs, Vector.map (ps, Cpat.ty))
+ val ty =
+ if flexible
+ then
+ let
+ val (t, isResolved) = Type.flexRecord r
+ fun resolve () =
+ if isResolved ()
+ then ()
+ else
+ Control.error
+ (region,
+ str "unresolved ... in flexible record pattern",
+ Layout.empty)
+ val _ = List.push (overloads, resolve)
+ in
+ t
+ end
+ else
+ Type.record r
in
- loopsContV
- (ps, fn ps =>
- Cpat.record
- {flexible = flexible,
- record = Record.fromVector (Vector.zip (fs, ps)),
- region = region})
+ Cpat.make
+ (Cpat.Record (Record.fromVector (Vector.zip (fs, ps))),
+ ty)
end
- | Apat.List ps => loopsCont (ps, fn ps => Cpat.list (ps, region))
- | Apat.FlatApp items => loop (Parse.parsePat (items, E))
- | Apat.App (c, p) =>
- doit (Cpat.Con {con = Env.lookupLongcon (E, c),
- arg = SOME (loop p)})
- | Apat.Constraint (p, t) =>
- doit (Cpat.Constraint
- (loop p,
- Scheme.ty (elaborateType (t, Lookup.fromEnv E))))
- | Apat.Layered {var = x, constraint, pat, ...} =>
- doit (Cpat.Layered
- (bind x,
- loop (case constraint of
- NONE => pat
- | SOME t => Apat.constraint (pat, t))))
+ | Apat.Tuple ps =>
+ let
+ val ps = Vector.map (ps, loop)
+ in
+ Cpat.make (Cpat.Tuple ps,
+ Type.tuple (Vector.map (ps, Cpat.ty)))
+ end
+ | Apat.Var {name, ...} =>
+ let
+ val (strids, x) = Ast.Longvid.split name
+ fun var () =
+ let
+ val (x, t) = bind (Ast.Vid.toVar x)
+ in
+ Cpat.make (Cpat.Var x, t)
+ end
+
+ in
+ if amInRvb andalso List.isEmpty strids
+ then var ()
+ else
+ (case Env.peekLongcon (E, Ast.Longvid.toLongcon name) of
+ NONE =>
+ if List.isEmpty strids
+ then var ()
+ else
+ let
+ val _ =
+ Control.error
+ (region,
+ seq [str "longid in var pat: ",
+ Ast.Longvid.layout name],
+ empty)
+ in
+ Cpat.make (Cpat.Wild, newType ())
+ end
+ | SOME (c, s) =>
+ let
+ val {args, instance} = Scheme.instantiate s
+ in
+ Cpat.make
+ (Cpat.Con {arg = NONE, con = c, targs = args ()},
+ instance)
+ end)
+ end
+ | Apat.Wild =>
+ Cpat.make (Cpat.Wild, newType ())
end) arg
- and loopsCont (ps: Apat.t list, cont: Cpat.t list -> Cpat.t): Cpat.t =
- cont (elaboratePats (ps, E))
- and loopsContV (ps: Apat.t vector, cont: Cpat.t vector -> Cpat.t): Cpat.t =
- cont (elaboratePatsV (ps, E))
- in loop p
+ val p = loop p
+ in
+ (p, Vector.fromList (!xts))
end
-and elaboratePats (ps: Apat.t list, E): Cpat.t list =
- List.map (ps, fn p => elaboratePat (p, E))
-
-and elaboratePatsV (ps: Apat.t vector, E): Cpat.t vector =
- Vector.map (ps, fn p => elaboratePat (p, E))
-
-fun constrain (e, tyOpt, r) =
- case tyOpt of
- NONE => e
- | SOME ty => Cexp.makeRegion (Cexp.Constraint (e, ty), r)
-
(*---------------------------------------------------*)
(* Declarations *)
(*---------------------------------------------------*)
@@ -334,55 +541,62 @@
structure CType =
struct
open CoreML.CType
-
+
fun sized (all: 'a list,
toString: 'a -> string,
prefix: string,
make: 'a -> t,
- makeType: 'a -> Type.t) =
+ makeType: 'a -> 'b) =
List.map (all, fn a =>
(make a, concat [prefix, toString a], makeType a))
- val nullary =
- [(bool, "Bool", Type.bool),
- (char, "Char", Type.con (Tycon.char, Vector.new0 ())),
- (pointer, "Pointer", Type.pointer),
- (pointer, "Pointer", Type.preThread),
- (pointer, "Pointer", Type.thread)]
- @ sized (IntSize.all, IntSize.toString, "Int", Int, Type.int)
- @ sized (RealSize.all, RealSize.toString, "Real", Real, Type.real)
- @ sized (WordSize.all, WordSize.toString, "Word", Word, Type.word)
- val unary = [Tycon.array, Tycon.reff, Tycon.vector]
+ val nullary: (t * string * Tycon.t) list =
+ [(bool, "Bool", Tycon.bool),
+ (char, "Char", Tycon.char),
+ (pointer, "Pointer", Tycon.pointer),
+ (pointer, "Pointer", Tycon.preThread),
+ (pointer, "Pointer", Tycon.thread)]
+ @ sized (IntSize.all, IntSize.toString, "Int", Int, Tycon.int)
+ @ sized (RealSize.all, RealSize.toString, "Real", Real, Tycon.real)
+ @ sized (WordSize.all, WordSize.toString, "Word", Word, Tycon.word)
+
+ val unary: Tycon.t list =
+ [Tycon.array, Tycon.reff, Tycon.vector]
fun fromType (t: Type.t): (t * string) option =
- case List.peek (nullary, fn (_, _, t') => Type.equals (t, t')) of
- NONE =>
- (case Type.deconOpt t of
- NONE => NONE
- | SOME (tycon, ts) =>
- if List.exists (unary, fn tycon' =>
- Tycon.equals (tycon, tycon'))
- andalso 1 = Vector.length ts
- andalso isSome (fromType (Vector.sub (ts, 0)))
- then SOME (Pointer, "Pointer")
- else NONE)
- | SOME (t, s, _) => SOME (t, s)
+ case Type.deConOpt t of
+ NONE => NONE
+ | SOME (c, ts) =>
+ case List.peek (nullary, fn (_, _, c') => Tycon.equals (c, c')) of
+ NONE =>
+ if List.exists (unary, fn c' => Tycon.equals (c, c'))
+ andalso 1 = Vector.length ts
+ andalso isSome (fromType (Vector.sub (ts, 0)))
+ then SOME (Pointer, "Pointer")
+ else NONE
+ | SOME (t, s, _) => SOME (t, s)
+
+ val fromType =
+ Trace.trace ("Ctype.fromType",
+ Type.layoutPretty,
+ Option.layout (Layout.tuple2 (layout, String.layout)))
+ fromType
fun parse (ty: Type.t)
: ((t * string) vector * (t * string) option) option =
- case Type.dearrowOpt ty of
+ case Type.deArrowOpt ty of
NONE => NONE
| SOME (t1, t2) =>
let
fun finish (ts: (t * string) vector) =
case fromType t2 of
NONE =>
- if Type.equals (t2, Type.unit)
+ if Type.isUnit t2
then SOME (ts, NONE)
else NONE
| SOME t => SOME (ts, SOME t)
in
- case Type.detupleOpt t1 of
+ case Type.deTupleOpt t1 of
NONE =>
(case fromType t1 of
NONE => NONE
@@ -413,36 +627,34 @@
fun import {attributes: Attribute.t list,
name: string,
ty: Type.t,
- region: Region.t}: Cprim.t =
+ region: Region.t}: Prim.t =
let
fun error l = Control.error (region, l, Layout.empty)
fun invalidAttributes () =
- error (let
- open Layout
- in
- seq [str "invalid attributes for import: ",
- List.layout Attribute.layout attributes]
- end)
+ error (seq [str "invalid attributes for import: ",
+ List.layout Attribute.layout attributes])
in
case CType.parse ty of
NONE =>
(case CType.fromType ty of
NONE =>
- (error (let
- open Layout
- in
- seq [str "invalid type for import: ",
- Type.layout ty]
- end)
- ; Cprim.bogus)
+ let
+ val _ =
+ Control.error
+ (region,
+ str "invalid type for import:",
+ Type.layoutPretty ty)
+ in
+ Prim.bogus
+ end
| SOME (t, _) =>
case attributes of
- [] => Cprim.ffiSymbol {name = name, ty = t}
+ [] => Prim.ffiSymbol {name = name, ty = t}
| _ =>
let
val _ = invalidAttributes ()
in
- Cprim.bogus
+ Prim.bogus
end)
| SOME (args, result) =>
let
@@ -456,14 +668,14 @@
bytesNeeded = NONE,
convention = convention,
ensuresBytesFree = false,
- modifiesFrontier = true (* callsFromC *),
- modifiesStackTop = true (* callsFromC *),
- mayGC = true (* callsFromC *),
+ modifiesFrontier = true,
+ modifiesStackTop = true,
+ mayGC = true,
maySwitchThreads = false,
name = name,
return = Option.map (result, #1)}
in
- Cprim.ffi (func, Scheme.fromType ty)
+ Prim.ffi func
end
end
@@ -471,12 +683,8 @@
let
fun error l = Control.error (region, l, Layout.empty)
fun invalidAttributes () =
- error (let
- open Layout
- in
- seq [str "invalid attributes for export: ",
- List.layout Attribute.layout attributes]
- end)
+ error (seq [str "invalid attributes for export: ",
+ List.layout Attribute.layout attributes])
val convention =
case parseAttributes attributes of
NONE => (invalidAttributes ()
@@ -487,12 +695,8 @@
NONE =>
(Control.error
(region,
- let
- open Layout
- in
- seq [str "invalid type for exported function: ",
- Type.layout ty]
- end,
+ seq [str "invalid type for exported function: ",
+ Type.layout ty],
Layout.empty)
; (0, Vector.new0 (), NONE))
| SOME (us, t) =>
@@ -505,7 +709,6 @@
(id, us, t)
end
open Ast
- val filePos = "<export>"
fun id name =
Aexp.longvid (Longvid.short (Vid.fromString (name, region)))
fun int (i: int): Aexp.t =
@@ -513,306 +716,538 @@
val f = Var.fromString ("f", region)
in
Exp.fnn
- (Match.T
- {filePos = filePos,
- rules =
- Vector.new1
- (Pat.var f,
- Exp.app
- (id "register",
- Exp.tuple
- (Vector.new2
- (int exportId,
- Exp.fnn
- (Match.T
- {filePos = filePos,
- rules =
- Vector.new1
- (Pat.tuple (Vector.new0 ()),
- let
- val map = CType.memo (fn _ => Counter.new 0)
- val varCounter = Counter.new 0
- val (args, decs) =
- Vector.unzip
- (Vector.map
- (args, fn (u, name) =>
- let
- val x =
- Var.fromString
- (concat ["x",
- Int.toString (Counter.next varCounter)],
- region)
- val dec =
- Dec.vall (Vector.new0 (),
- x,
- Exp.app (id (concat ["get", name]),
- int (Counter.next (map u))))
- in
- (x, dec)
- end))
- val resVar = Var.fromString ("res", region)
- fun newVar () = Var.fromString ("none", region)
- in
- Exp.lett
- (Vector.concat
- [decs,
- Vector.map
- (Vector.new4
- ((newVar (), Exp.app (id "atomicEnd", Exp.unit)),
- (resVar, Exp.app (Exp.var f,
- Exp.tuple (Vector.map (args, Exp.var)))),
- (newVar (), Exp.app (id "atomicBegin", Exp.unit)),
- (newVar (),
- (case res of
- NONE => Exp.unit
- | SOME (t, name) =>
- Exp.app (id (concat ["set", name]),
- Exp.var resVar)))),
- fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
- Exp.tuple (Vector.new0 ()))
- end)})))))})
+ (Vector.new1
+ (Pat.var f,
+ Exp.app
+ (id "register",
+ Exp.tuple
+ (Vector.new2
+ (int exportId,
+ Exp.fnn
+ (Vector.new1
+ (Pat.tuple (Vector.new0 ()),
+ let
+ val map = CType.memo (fn _ => Counter.new 0)
+ val varCounter = Counter.new 0
+ val (args, decs) =
+ Vector.unzip
+ (Vector.map
+ (args, fn (u, name) =>
+ let
+ val x =
+ Var.fromString
+ (concat ["x",
+ Int.toString (Counter.next varCounter)],
+ region)
+ val dec =
+ Dec.vall (Vector.new0 (),
+ x,
+ Exp.app (id (concat ["get", name]),
+ int (Counter.next (map u))))
+ in
+ (x, dec)
+ end))
+ val resVar = Var.fromString ("res", region)
+ fun newVar () = Var.fromString ("none", region)
+ in
+ Exp.lett
+ (Vector.concat
+ [decs,
+ Vector.map
+ (Vector.new4
+ ((newVar (), Exp.app (id "atomicEnd", Exp.unit)),
+ (resVar, Exp.app (Exp.var f,
+ Exp.tuple (Vector.map (args, Exp.var)))),
+ (newVar (), Exp.app (id "atomicBegin", Exp.unit)),
+ (newVar (),
+ (case res of
+ NONE => Exp.unit
+ | SOME (t, name) =>
+ Exp.app (id (concat ["set", name]),
+ Exp.var resVar)))),
+ fn (x, e) => Dec.vall (Vector.new0 (), x, e))],
+ Exp.tuple (Vector.new0 ()))
+ end)))))))
end
-
-fun elaborateDec (d, nest, E) =
+
+structure Aexp =
+ struct
+ open Aexp
+
+ fun selector (f: Field.t, r: Region.t): t =
+ let
+ val x = Avar.fromString ("x", r)
+ in
+ fnn (Vector.new1
+ (Apat.makeRegion
+ (Apat.Record {flexible = true,
+ items = (Vector.new1
+ (Apat.Item.Field (f, Apat.var x)))},
+ r),
+ var x))
+ end
+ end
+
+structure Con =
+ struct
+ open Con
+
+ val fromAst = fromString o Ast.Con.toString
+ end
+
+fun elaborateDec (d, {env = E,
+ lookupConstant: string * ConstType.t -> CoreML.Const.t,
+ nest}) =
let
- fun elabType t = elaborateType (t, Lookup.fromEnv E)
+ val {get = recursiveTargs: Var.t -> (unit -> Type.t vector) option ref,
+ ...} =
+ Property.get (Var.plist, Property.initFun (fn _ => ref NONE))
+ fun recursiveFun () =
+ let
+ val boundRef: (unit -> Tyvar.t vector) option ref = ref NONE
+ val targs =
+ Promise.lazy
+ (fn () =>
+ case !boundRef of
+ NONE => Error.bug "boundRef not set"
+ | SOME f => Vector.map (f (), Type.var))
+ fun markFunc func = recursiveTargs func := SOME targs
+ fun unmarkFunc func = recursiveTargs func := NONE
+ fun setBound b = boundRef := SOME b
+ in
+ {markFunc = markFunc,
+ setBound = setBound,
+ unmarkFunc = unmarkFunc}
+ end
+ fun elabType (t: Atype.t): Type.t =
+ elaborateType (t, Lookup.fromEnv E)
fun elabTypeOpt t = elaborateTypeOpt (t, Lookup.fromEnv E)
- fun elabDatBind datBind =
+ fun elabTypBind (typBind: TypBind.t) =
+ let
+ val lookup = Lookup.fromEnv E
+ val TypBind.T types = TypBind.node typBind
+ val strs =
+ List.map
+ (types, fn {def, tyvars, ...} =>
+ TypeStr.def (Scheme.make {canGeneralize = true,
+ ty = elabType def,
+ tyvars = tyvars},
+ Kind.Arity (Vector.length tyvars)))
+ in
+ List.foreach2
+ (types, strs, fn ({tycon, ...}, str) =>
+ Env.extendTycon (E, tycon, str))
+ end
+ fun elabDatBind (datBind: DatBind.t, nest: string list)
+ : Decs.t * {tycon: Ast.Tycon.t,
+ typeStr: TypeStr.t} vector =
(* rules 28, 29, 81, 82 *)
let
val region = DatBind.region datBind
val lookup = Lookup.fromEnv E
val DatBind.T {datatypes, withtypes} = DatBind.node datBind
- (* Build enough of an env so that that the withtypes
- * and the constructor argument types can be evaluated.
+ (* Build enough of an env so that that the withtypes and the
+ * constructor argument types can be elaborated.
*)
- val (tycons, datatypes) =
+ val tycons =
+ Vector.map
+ (datatypes, fn {cons, tycon = name, tyvars} =>
+ let
+ val tycon =
+ Tycon.fromString
+ (concat (List.separate
+ (rev (Ast.Tycon.toString name :: nest),
+ ".")))
+ val _ =
+ Env.extendTycon
+ (E, name,
+ TypeStr.tycon (tycon, Kind.Arity (Vector.length tyvars)))
+ in
+ tycon
+ end)
+ val _ = elabTypBind withtypes
+ val (dbs, strs) =
Vector.unzip
- (Vector.map
- (datatypes, fn {tyvars, tycon = name, cons} =>
+ (Vector.map2
+ (tycons, datatypes,
+ fn (tycon, {cons, tycon = astTycon, tyvars, ...}) =>
let
- val tycon = Tycon.fromAst name
- in
- ((name, TypeStr.tycon tycon),
- {name = name, tycon = tycon, tyvars = tyvars, cons = cons})
- end))
- val lookup = Lookup.plusTycons (lookup, tycons)
- (* Elaborate the withtypes. *)
- val tycons' = Vector.fromList (elaborateTypBind (withtypes, lookup))
- val lookup =
- Lookup.plusTycons (lookup, Vector.concat [tycons', tycons])
- (* Elaborate the datatypes, this time including the constructors. *)
- val (cons, tycons, datatypes) =
- Vector.unzip3
- (Vector.map
- (datatypes, fn {name, tyvars, tycon, cons} =>
- let
- val resultType =
- Atype.con (name, Vector.map (tyvars, Atype.var))
+ val resultType: Type.t =
+ Type.con (tycon, Vector.map (tyvars, Type.var))
val (cons, datatypeCons) =
Vector.unzip
(Vector.map
(cons, fn (name, arg) =>
let
val con = Con.fromAst name
- in ({name = name, con = con},
- {con = con,
- arg = Option.map (arg, fn t =>
- Scheme.ty
- (elaborateType (t, lookup)))})
+ val (arg, ty) =
+ case arg of
+ NONE => (NONE, resultType)
+ | SOME t =>
+ let
+ val t = elabType t
+ in
+ (SOME t, Type.arrow (t, resultType))
+ end
+ val scheme =
+ Scheme.make {canGeneralize = true,
+ ty = ty,
+ tyvars = tyvars}
+ val _ = Env.extendCon (E, name, con, scheme)
+ in
+ ({con = con, name = name, scheme = scheme},
+ {arg = arg, con = con})
end))
- in (cons,
- (name, TypeStr.data (tycon, cons)),
- {tyvars = tyvars,
+ val typeStr =
+ TypeStr.data (tycon,
+ Kind.Arity (Vector.length tyvars),
+ cons)
+ val _ = Env.extendTycon (E, astTycon, typeStr)
+ in
+ ({cons = datatypeCons,
tycon = tycon,
- cons = datatypeCons})
+ tyvars = tyvars},
+ {tycon = astTycon,
+ typeStr = typeStr})
end))
- in {cons = Vector.concatV cons,
- tycons = Vector.concat [tycons, tycons'],
- decs = Decs.single (Cdec.makeRegion (Cdec.Datatype datatypes,
- region))}
+ in
+ (Decs.single (Cdec.Datatype dbs), strs)
end
- fun elabDec arg =
- Trace.traceInfo (info,
- Layout.tuple2 (Ast.Dec.layout, Nest.layout),
- Layout.ignore, Trace.assertTrue)
- (fn (d, nest) =>
+ fun elabDec arg : Decs.t =
+ Trace.traceInfo
+ (info,
+ Layout.tuple3 (Ast.Dec.layout, Nest.layout, Bool.layout),
+ Layout.ignore, Trace.assertTrue)
+ (fn (d, nest, isTop) =>
let
val region = Adec.region d
- fun doit n = Cexp.makeRegion (n, region)
- val elabDec' = elabDec
- fun elabDec (d: Adec.t) = elabDec' (d, nest)
+ fun checkSchemes (v: (Var.t * Scheme.t) vector): unit =
+ if isTop
+ then
+ List.push
+ (freeTyvarChecks,
+ fn () =>
+ Vector.foreach2
+ (v, Scheme.haveFrees (Vector.map (v, #2)),
+ fn ((x, s), b) =>
+ if b
+ then
+ let
+ open Layout
+ in
+ Control.error
+ (region,
+ seq [str "unable to infer type for ",
+ Var.layout x],
+ seq [str "type: ", Scheme.layoutPretty s])
+ end
+ else ()))
+ else ()
+ val elabDec = fn (d, isTop) => elabDec (d, nest, isTop)
in
case Adec.node d of
Adec.Abstype {datBind, body} => (* rule 19 and p.57 *)
let
- val {cons, decs, tycons} = elabDatBind datBind
- val (_, decs') =
+ val ((decs, strs), decs') =
Env.localCore
(E,
- fn () =>
- (Vector.foreach (cons, fn {name, con} =>
- Env.extendCon (E, name, con))
- ; Vector.foreach (tycons, fn (t, s) =>
- Env.extendTycon (E, t, s))),
- fn () => elabDec body)
+ fn () => elabDatBind (datBind, nest),
+ fn z => (z, elabDec (body, isTop)))
val _ =
- Vector.foreach (tycons, fn (t, s) =>
- Env.extendTycon (E, t, TypeStr.abs s))
+ Vector.foreach
+ (strs, fn {tycon, typeStr} =>
+ Env.extendTycon (E, tycon, TypeStr.abs typeStr))
in
Decs.append (decs, decs')
end
| Adec.Datatype rhs =>
+ (case DatatypeRhs.node rhs of
+ DatatypeRhs.DatBind datBind => (* rule 17 *)
+ #1 (elabDatBind (datBind, nest))
+ | DatatypeRhs.Repl {lhs, rhs} => (* rule 18 *)
+ let
+ val tyStr = Env.lookupLongtycon (E, rhs)
+ val _ = Env.extendTycon (E, lhs, tyStr)
+ val _ =
+ Vector.foreach
+ (TypeStr.cons tyStr, fn {con, name, scheme} =>
+ Env.extendCon (E, name, con, scheme))
+ in
+ Decs.empty
+ end)
+ | Adec.Exception ebs =>
let
- val {cons, decs, tycons} =
- case DatatypeRhs.node rhs of
- DatatypeRhs.DatBind datBind => (* rule 17 *)
- elabDatBind datBind
- | DatatypeRhs.Repl {lhs, rhs} => (* rule 18 *)
- let
- val tyStr = Env.lookupLongtycon (E, rhs)
- in
- {cons = TypeStr.cons tyStr,
- decs = Decs.empty,
- tycons = Vector.new1 (lhs, tyStr)}
- end
- val _ = Vector.foreach (cons, fn {name, con} =>
- Env.extendCon (E, name, con))
- val _ = Vector.foreach (tycons, fn (t, s) =>
- Env.extendTycon (E, t, s))
+ val decs =
+ Vector.fold
+ (ebs, Decs.empty, fn ((exn, rhs), decs) =>
+ let
+ val (decs, exn', scheme) =
+ case EbRhs.node rhs of
+ EbRhs.Def c =>
+ let
+ val (c, s) = Env.lookupLongcon (E, c)
+ in
+ (decs, c, s)
+ end
+ | EbRhs.Gen arg =>
+ let
+ val exn' = Con.fromAst exn
+ val (arg, ty) =
+ case arg of
+ NONE => (NONE, Type.exn)
+ | SOME t =>
+ let
+ val t = elabType t
+ in
+ (SOME t,
+ Type.arrow (t, Type.exn))
+ end
+ val scheme = Scheme.fromType ty
+ in
+ (Decs.add (decs,
+ Cdec.Exception {arg = arg,
+ con = exn'}),
+ exn',
+ scheme)
+ end
+ val _ = Env.extendExn (E, exn, exn', scheme)
+ in
+ decs
+ end)
in
decs
end
- | Adec.Exception ebs =>
- Vector.fold
- (ebs, Decs.empty, fn ((exn, rhs), decs) =>
- let
- val (decs, exn') =
- case EbRhs.node rhs of
- EbRhs.Def c => (decs, Env.lookupLongcon (E, c))
- | EbRhs.Gen to =>
- let val exn' = Con.fromAst exn
- in (Decs.add
- (decs,
- Cdec.makeRegion
- (Cdec.Exception {con = exn',
- arg = elabTypeOpt to},
- EbRhs.region rhs)),
- exn')
- end
- val _ = Env.extendExn (E, exn, exn')
- in decs
- end)
| Adec.Fix {ops, fixity} =>
(Vector.foreach (ops, fn op' =>
Env.extendFix (E, op', fixity))
; Decs.empty)
| Adec.Fun (tyvars, fbs) =>
let
- val clausess =
+ val fbs =
Vector.map
- (fbs, fn {clauses, filePos} =>
- {filePos = filePos,
- clauses =
- Vector.map
- (clauses, fn {pats, resultType, body} =>
- let
- val {func, args} = Parse.parseClause (pats, E)
- in
- {func = func,
- args = args,
- resultType = resultType,
- body = body}
- end)})
- val funcs =
- Vector.map (clausess, fn {clauses, ...} =>
- if Vector.isEmpty clauses
- then Error.bug "no clauses in fundec"
- else #func (Vector.sub (clauses, 0)))
- val newFuncs = Vector.map (funcs, Cvar.fromAst)
- val _ =
- Vector.foreach2 (funcs, newFuncs, fn (name, var) =>
- Env.extendVar (E, name, var))
- val decs =
- Vector.map2
- (clausess, newFuncs, fn ({clauses, filePos}, newFunc) =>
+ (fbs, fn clauses =>
+ Vector.map
+ (clauses, fn {body, pats, resultType} =>
+ let
+ val {args, func} = Parse.parseClause (pats, E)
+ in
+ {args = args,
+ body = body,
+ func = func,
+ resultType = resultType}
+ end))
+ val close = TypeEnv.close (tyvars, region)
+ val {markFunc, setBound, unmarkFunc} = recursiveFun ()
+ val fbs =
+ Vector.map
+ (fbs, fn clauses =>
if Vector.isEmpty clauses
- then Error.bug "empty clauses in fundec"
+ then Error.bug "no clauses in fundec"
else
let
- val {func, args, ...} = Vector.sub (clauses, 0)
- val nest = Avar.toString func :: nest
- val profile =
- SourceInfo.function
- {name = nest,
- region = Avar.region func}
- val numVars = Vector.length args
- val match =
- let
- val rs =
- Vector.map
- (clauses,
- fn {args, resultType, body, ...} =>
- let
- val (pats, body) =
- Env.scope
- (E, fn () =>
- (elaboratePatsV (args, E),
- elabExp' (body, nest)))
- in (Cpat.tuple (pats, region),
- constrain (body,
- elabTypeOpt resultType,
- region))
- end)
- fun make (i, xs) =
- if i = 0
- then
- Cexp.casee
- (Cexp.tuple
- (Vector.rev
- (Vector.fromListMap
- (xs, fn x =>
- doit (Cexp.Var x))),
- region),
- Cmatch.new {filePos = filePos,
- rules = rs},
- region)
- else
- let
- val x = Cvar.newNoname ()
- in
- Cexp.lambda
- (x,
- make (i - 1, x :: xs),
- if i = 1
- then SOME profile
- else NONE,
- region)
- end
- in if numVars = 1
- then Cmatch.new {filePos = filePos,
- rules = rs}
- else (case Cexp.node (make (numVars, [])) of
- Cexp.Fn {match = m, ...} => m
- | _ => Error.bug "elabFbs")
- end
+ val {args, func, ...} = Vector.sub (clauses, 0)
+ val numArgs = Vector.length args
+ val _ =
+ Vector.foreach
+ (clauses, fn {args, ...} =>
+ if numArgs = Vector.length args
+ then ()
+ else
+ Control.error
+ (region,
+ seq [str "clauses don't all have the same number of patterns"],
+ empty))
+ val _ =
+ Vector.foreach
+ (clauses, fn {func = func', ...} =>
+ if Ast.Var.equals (func, func')
+ then ()
+ else
+ Control.error
+ (region,
+ seq [str "clauses don't all have same function name"],
+ seq [Avar.layout func,
+ str ", ", Avar.layout func']))
+ val var = Var.fromAst func
+ val ty = newType ()
+ val _ = Env.extendVar (E, func, var,
+ Scheme.fromType ty)
+ val _ = markFunc var
in
- {match = match,
- profile = if numVars = 1
- then SOME profile
- else NONE,
- types = Vector.new0 (),
- var = newFunc}
+ {clauses = clauses,
+ func = func,
+ ty = ty,
+ var = var}
end)
+ val decs =
+ Vector.map
+ (fbs, fn {clauses,
+ func: Avar.t,
+ ty: Type.t,
+ var: Var.t} =>
+ let
+ val nest = Avar.toString func :: nest
+ val sourceInfo =
+ SourceInfo.function {name = nest,
+ region = Avar.region func}
+ val rs =
+ Vector.map
+ (clauses, fn {args: Apat.t vector,
+ body: Aexp.t,
+ resultType: Atype.t option, ...} =>
+ Env.scope
+ (E, fn () =>
+ let
+ val pats =
+ Vector.map
+ (args, fn p =>
+ {pat = #1 (elaboratePat (p, E, false)),
+ region = Apat.region p})
+ val bodyRegion = Aexp.region body
+ val body = elabExp (body, nest)
+ val _ =
+ Option.app
+ (resultType, fn t =>
+ unify
+ (elabType t, Cexp.ty body,
+ fn (l1, l2) =>
+ (Atype.region t,
+ str "function result type does not agree with expression",
+ align
+ [seq [str "result type:", l1],
+ seq [str "expression: ", l2]])))
+ in
+ {body = body,
+ bodyRegion = bodyRegion,
+ pats = pats}
+ end))
+ val numArgs =
+ Vector.length (#pats (Vector.sub (rs, 0)))
+ val argTypes =
+ Vector.tabulate
+ (numArgs, fn i =>
+ let
+ val t =
+ Cpat.ty
+ (#pat (Vector.sub
+ (#pats (Vector.sub (rs, 0)),
+ i)))
+ val _ =
+ Vector.foreach
+ (rs, fn {pats, ...} =>
+ let
+ val {pat, region} =
+ Vector.sub (pats, i)
+ in
+ unify
+ (t, Cpat.ty pat, fn (l1, l2) =>
+ (region,
+ str "function argument patterns must be of same type",
+ align [seq [str "pattern: ", l2],
+ seq [str "previous: ", l1]]))
+ end)
+ in
+ t
+ end)
+ val bodyType =
+ let
+ val t = Cexp.ty (#body (Vector.sub (rs, 0)))
+ val _ =
+ Vector.foreach
+ (rs, fn {body, bodyRegion, ...} =>
+ unify
+ (t, Cexp.ty body, fn (l1, l2) =>
+ (bodyRegion,
+ str "function results must be of same type",
+ align [seq [str "result: ", l2],
+ seq [str "previous: ", l1]])))
+ in
+ t
+ end
+ val xs =
+ Vector.tabulate (numArgs, fn _ =>
+ Var.newNoname ())
+ fun make (i: int): Cexp.t =
+ if i = Vector.length xs
+ then
+ let
+ val e =
+ Cexp.casee
+ {noMatch = Cexp.RaiseMatch,
+ region = Region.bogus,
+ rules =
+ Vector.map
+ (rs, fn {body, pats, ...} =>
+ let
+ val pats =
+ Vector.map (pats, #pat)
+ in
+ (Cpat.make
+ (Cpat.Tuple pats,
+ Type.tuple
+ (Vector.map (pats, Cpat.ty))),
+ body)
+ end),
+ test =
+ Cexp.tuple
+ (Vector.map2
+ (xs, argTypes, Cexp.var))}
+ in
+ Cexp.enterLeave (e, sourceInfo)
+ end
+ else
+ let
+ val body = make (i + 1)
+ val argType = Vector.sub (argTypes, i)
+ in
+ Cexp.make
+ (Cexp.Lambda
+ (Lambda.make
+ {arg = Vector.sub (xs, i),
+ argType = argType,
+ body = body}),
+ Type.arrow (argType, Cexp.ty body))
+ end
+ val lambda = make 0
+ val _ =
+ unify
+ (Cexp.ty lambda, ty, fn (l1, l2) =>
+ (Avar.region func,
+ str "function type does not match recursive uses",
+ align [seq [str "function type: ", l1],
+ seq [str "recursive uses: ", l2]]))
+ val lambda =
+ case Cexp.node lambda of
+ Cexp.Lambda l => l
+ | _ => Error.bug "not a lambda"
+ in
+ {lambda = lambda,
+ ty = ty,
+ var = var}
+ end)
+ val {bound, schemes} = close (Vector.map (decs, #ty))
+ val _ = checkSchemes (Vector.zip
+ (Vector.map (decs, #var),
+ schemes))
+ val _ = setBound bound
+ val _ =
+ Vector.foreach3
+ (fbs, decs, schemes,
+ fn ({func, ...}, {var, ...}, scheme) =>
+ (Env.extendVar (E, func, var, scheme)
+ ; unmarkFunc var))
+ val decs =
+ Vector.map (decs, fn {lambda, var, ...} =>
+ {lambda = lambda, var = var})
in
- Decs.single (Cdec.makeRegion (Cdec.Fun {tyvars = tyvars,
- decs = decs},
- region))
+ Decs.single (Cdec.Fun {decs = decs,
+ tyvars = bound})
end
| Adec.Local (d, d') =>
- Decs.append (Env.localCore (E,
- fn () => elabDec d,
- fn () => elabDec d'))
+ Env.localCore
+ (E,
+ fn () => elabDec (d, false),
+ fn decs => Decs.append (decs, elabDec (d', isTop)))
| Adec.Open paths =>
let
(* The following code is careful to first lookup all of the
@@ -827,265 +1262,637 @@
in
Decs.empty
end
- | Adec.Overload (x, t, xs) =>
+ | Adec.Overload (x, tyvars, ty, xs) =>
let
- val x' = Cvar.fromAst x
- val scheme = elabType t
- (* Elaborate the overloads before extending the var in
- * case x appears in the xs.
+ (* Lookup the overloads before extending the var in case
+ * x appears in the xs.
*)
val ovlds =
Vector.map (xs, fn x => Env.lookupLongvar (E, x))
- val _ = Env.extendVar (E, x, x')
+ val _ =
+ Env.extendOverload
+ (E, x,
+ Vector.map (ovlds, fn (x, s) => (x, Scheme.ty s)),
+ Scheme.make {canGeneralize = false,
+ tyvars = tyvars,
+ ty = elabType ty})
in
- Decs.single (Cdec.makeRegion
- (Cdec.Overload {var = x',
- scheme = scheme,
- ovlds = ovlds},
- region))
+ Decs.empty
end
| Adec.SeqDec ds =>
Vector.fold (ds, Decs.empty, fn (d, decs) =>
- Decs.append (decs, elabDec d))
+ Decs.append (decs, elabDec (d, isTop)))
| Adec.Type typBind =>
- (List.foreach
- (elaborateTypBind (typBind, Lookup.fromEnv E),
- fn (tyc, str) => Env.extendTycon (E, tyc, str))
+ (elabTypBind typBind
; Decs.empty)
- | Adec.Val {tyvars, vbs, rvbs} =>
+ | Adec.Val {tyvars, rvbs, vbs} =>
let
- val hasCon: string option ref = ref NONE
- fun checkName (name: Ast.Longvid.t): unit =
- case !hasCon of
- SOME _ => ()
- | NONE =>
- if isSome (Env.peekLongcon
- (E, Ast.Longvid.toLongcon name))
- then hasCon := SOME (Region.toString
- (Ast.Longvid.region name))
- else ()
- (* Must do all the es and rvbs pefore the ps because of
+ val close = TypeEnv.close (tyvars, region)
+ (* Must do all the es and rvbs before the ps because of
* scoping rules.
*)
- val es =
- Vector.map (vbs, fn {pat, exp, ...} =>
- elabExp'
- (exp,
- case Apat.getName pat of
- NONE => "<anon>" :: nest
- | SOME s => s :: nest))
- fun varsAndTypes (p: Apat.t, vars, types)
- : Avar.t list * Atype.t list =
- let
- fun error () =
- Error.bug
- (concat ["strange rec pattern: ",
- Layout.toString (Apat.layout p)])
- datatype z = datatype Apat.node
- in
- case Apat.node p of
- Wild => (vars, types)
- | Var {name, ...} =>
- (checkName name
- ; (case Ast.Longvid.split name of
- ([], x) =>
- (Ast.Vid.toVar x :: vars, types)
- | _ => Error.bug "longid in val rec pattern"))
- | Constraint (p, t) =>
- varsAndTypes (p, vars, t :: types)
- | FlatApp ps =>
- if 1 = Vector.length ps
- then varsAndTypes (Vector.sub (ps, 0),
- vars, types)
- else error ()
- | Apat.Layered {var, constraint, pat, ...} =>
- varsAndTypes (pat, var :: vars,
- case constraint of
- NONE => types
- | SOME t => t :: types)
- | _ => error ()
- end
- val varsAndTypes =
- Trace.trace ("varsAndTypes",
- Apat.layout o #1,
- Layout.tuple2 (List.layout Avar.layout,
- List.layout Atype.layout))
- varsAndTypes
- val vts =
+ val vbs =
Vector.map
- (rvbs, fn {pat, ...} =>
+ (vbs, fn {exp, pat, ...} =>
+ {exp = elabExp (exp,
+ case Apat.getName pat of
+ NONE => "anon" :: nest
+ | SOME s => s :: nest),
+ expRegion = Aexp.region exp,
+ pat = pat,
+ patRegion = Apat.region pat})
+ val close =
+ case Vector.peek (vbs, Cexp.isExpansive o #exp) of
+ NONE => close
+ | SOME {expRegion, ...} =>
+ let
+ val _ =
+ if Vector.isEmpty tyvars
+ then ()
+ else
+ Control.error
+ (expRegion,
+ str "value restriction prevents generalization",
+ empty)
+ in
+ fn tys => {bound = fn () => Vector.new0 (),
+ schemes =
+ Vector.map (tys, Scheme.fromType)}
+ end
+ val {markFunc, setBound, unmarkFunc} = recursiveFun ()
+ val rvbs =
+ Vector.map
+ (rvbs, fn {pat, match} =>
let
- val (vars, types) = varsAndTypes (pat, [], [])
- val (nest, var) =
- case vars of
- [] => ("<anon>" :: nest, Cvar.newNoname ())
- | x :: _ =>
- let
- val x' = Cvar.fromAst x
- val _ =
- List.foreach
- (vars, fn y =>
- Env.extendVar (E, y, x'))
- in
- (Avar.toString x :: nest, x')
- end
+ val region = Apat.region pat
+ val (pat, bound) = elaboratePat (pat, E, true)
+ val (nest, var, ty) =
+ if 0 = Vector.length bound
+ then ("<anon>" :: nest,
+ Var.newNoname (),
+ newType ())
+ else
+ let
+ val (x, x', t) = Vector.sub (bound, 0)
+ in
+ (Avar.toString x :: nest, x', t)
+ end
+ val _ = markFunc var
+ val scheme = Scheme.fromType ty
+ val bound =
+ Vector.map
+ (bound, fn (x, _, _) =>
+ (Env.extendVar (E, x, var, scheme)
+ ; (x, var, ty)))
in
- {nest = nest,
- types = (Vector.fromListMap
- (types, Scheme.ty o elabType)),
+ {bound = bound,
+ match = match,
+ nest = nest,
+ pat = pat,
+ region = region,
var = var}
end)
+ val boundVars =
+ Vector.concatV (Vector.map (rvbs, #bound))
val rvbs =
- Vector.map2
- (rvbs, vts,
- fn ({pat, match, ...}, {nest, types, var}) =>
- {match = elabMatch (match, nest),
- profile = SOME (SourceInfo.function
- {name = nest,
- region = Apat.region pat}),
- types = types,
- var = var})
- val ps = Vector.map (vbs, fn {pat, filePos, ...} =>
- {pat = elaboratePat (pat, E),
- filePos = filePos,
- region = Apat.region pat})
+ Vector.map
+ (rvbs, fn {bound, match, nest, pat, region, var, ...} =>
+ let
+ val {argType, region, resultType, rules} =
+ elabMatch (match, nest)
+ val _ =
+ unify
+ (Cpat.ty pat,
+ Type.arrow (argType, resultType),
+ fn (l1, l2) =>
+ (region,
+ str "pattern does not match function type",
+ align [seq [str "pattern: ", l1],
+ seq [str "function type: ", l2]]))
+ val arg = Var.newNoname ()
+ val body =
+ Cexp.enterLeave
+ (Cexp.casee {noMatch = Cexp.RaiseMatch,
+ region = region,
+ rules = rules,
+ test = Cexp.var (arg, argType)},
+ SourceInfo.function {name = nest,
+ region = region})
+ val lambda =
+ Lambda.make {arg = arg,
+ argType = argType,
+ body = body}
+ in
+ {bound = bound,
+ lambda = lambda,
+ var = var}
+ end)
+ val rvbs =
+ Vector.map
+ (rvbs, fn {bound, lambda, var} =>
+ (Vector.foreach (bound, unmarkFunc o #2)
+ ; {lambda = lambda,
+ var = var}))
+ val vbs =
+ Vector.map
+ (vbs, fn {exp = e, expRegion, pat, patRegion, ...} =>
+ let
+ val (p, bound) = elaboratePat (pat, E, false)
+ val _ =
+ unify
+ (Cpat.ty p, Cexp.ty e, fn (p, e) =>
+ (Apat.region pat,
+ str "pattern and expression don't agree",
+ align [seq [str "pattern: ", p],
+ seq [str "expression: ", e]]))
+ in
+ {bound = bound,
+ exp = e,
+ expRegion = expRegion,
+ pat = p,
+ patRegion = patRegion}
+ end)
+ val boundVars =
+ Vector.concat
+ [boundVars, Vector.concatV (Vector.map (vbs, #bound))]
+ val {bound, schemes} =
+ close (Vector.map (boundVars, #3))
+ val _ = checkSchemes (Vector.zip
+ (Vector.map (boundVars, #2),
+ schemes))
+ val _ = setBound bound
+ val _ =
+ Vector.foreach2
+ (boundVars, schemes, fn ((x, x', _), scheme) =>
+ Env.extendVar (E, x, x', scheme))
val vbs =
- Vector.map2 (ps, es, fn ({pat, filePos, region}, e) =>
- Cdec.makeRegion
- (Cdec.Val {pat = pat,
- filePos = filePos,
- tyvars = tyvars,
- exp = e},
- region))
- in Decs.appends
- [Decs.fromVector vbs,
- Decs.single (Cdec.makeRegion
- (Cdec.Fun {tyvars = tyvars,
- decs = rvbs},
- region)),
- (* Hack to implement rule 126, which requires Bind to be
- * raised if any of the rvbs contains a constructor in a
- * pattern. This, despite the fact that rule 26 allows
- * identifier status to be overridden for the purposes of
- * type checking.
- *)
- case !hasCon of
- NONE => Decs.empty
- | SOME filePos =>
- Decs.single
- (Cdec.makeRegion
- (Cdec.Val
- {exp = doit (Cexp.Raise
- {exn = doit (Cexp.Con Con.bind),
- filePos = filePos}),
- filePos = "",
- pat = Cpat.makeRegion (Cpat.Wild, region),
- tyvars = Vector.new0 ()},
- region))]
+ Vector.map (vbs, fn {exp, pat, patRegion, ...} =>
+ {exp = exp,
+ pat = pat,
+ patRegion = patRegion})
+ in
+ Decs.single (Cdec.Val {rvbs = rvbs,
+ tyvars = bound,
+ vbs = vbs})
end
end) arg
- and elabExp' (arg: Aexp.t * Nest.t): Cexp.t =
+ and elabExp (arg: Aexp.t * Nest.t): Cexp.t =
Trace.traceInfo (elabExpInfo,
Layout.tuple2 (Aexp.layout, Nest.layout),
- Cexp.layout,
+ Layout.ignore,
Trace.assertTrue)
(fn (e: Aexp.t, nest) =>
let
val region = Aexp.region e
- fun doit n = Cexp.makeRegion (n, region)
- fun elabExp e = elabExp' (e, nest)
+ fun constant (c: Aconst.t) =
+ case Aconst.node c of
+ Aconst.Bool b => if b then Cexp.truee else Cexp.falsee
+ | _ =>
+ let
+ val ty = Aconst.ty c
+ fun resolve () = resolveConst (c, ty)
+ val _ = List.push (overloads, fn () => (resolve (); ()))
+ in
+ Cexp.make (Cexp.Const resolve, ty)
+ end
+ fun elab e = elabExp (e, nest)
in
case Aexp.node e of
Aexp.Andalso (e, e') =>
- Cexp.andAlso (elabExp e, elabExp e', region)
+ let
+ val ce = elab e
+ val ce' = elab e'
+ fun doit (ce, br) =
+ unify
+ (Cexp.ty ce, Type.bool,
+ fn (l, _) =>
+ (Aexp.region e,
+ str (concat
+ [br, " branch of andalso must be of type bool"]),
+ seq [str (concat [br, " branch: "]), l]))
+ val _ = doit (ce, "left")
+ val _ = doit (ce', "right")
+ in
+ Cexp.andAlso (ce, ce')
+ end
| Aexp.App (e1, e2) =>
- doit (Cexp.App (elabExp e1, elabExp e2))
+ let
+ val e1 = elab e1
+ val e2 = elab e2
+ val argType = newType ()
+ val resultType = newType ()
+ val _ =
+ unify (Cexp.ty e1, Type.arrow (argType, resultType),
+ fn (l, _) =>
+ (region,
+ str "attempt to apply non-function",
+ seq [str "function: ", l]))
+ val _ =
+ unify
+ (argType, Cexp.ty e2, fn (l1, l2) =>
+ (region,
+ str "function applied to incorrect arguments",
+ align [seq [str "expects: ", l2],
+ seq [str "but got: ", l1]]))
+ in
+ Cexp.make (Cexp.App (e1, e2), resultType)
+ end
| Aexp.Case (e, m) =>
- Cexp.casee (elabExp e, elabMatch (m, nest), region)
- | Aexp.Const c => doit (Cexp.Const c)
- | Aexp.Constraint (e, t) =>
- doit (Cexp.Constraint (elabExp e,
- Scheme.ty (elabType t)))
- | Aexp.FlatApp items => elabExp (Parse.parseExp (items, E))
+ let
+ val e = elab e
+ val {argType, region, resultType, rules} =
+ elabMatch (m, nest)
+ val _ =
+ unify
+ (Cexp.ty e, argType, fn (l1, l2) =>
+ (region,
+ str "case object and rules disagree",
+ align [seq [str "object: ", l1],
+ seq [str "rules: ", l2]]))
+ in
+ Cexp.casee {noMatch = Cexp.RaiseMatch,
+ region = region,
+ rules = rules,
+ test = e}
+ end
+ | Aexp.Const c => constant c
+ | Aexp.Constraint (e, t') =>
+ let
+ val e = elab e
+ val _ =
+ unify
+ (Cexp.ty e, elabType t', fn (l1, l2) =>
+ (region,
+ str "expression and constraint mismatch",
+ align [seq [str "expression: ", l1],
+ seq [str "constraint: ", l2]]))
+ in
+ e
+ end
+ | Aexp.FlatApp items => elab (Parse.parseExp (items, E))
| Aexp.Fn m =>
- doit
- (Cexp.Fn
- {match = elabMatch (m, nest),
- profile = SOME (SourceInfo.function {name = nest,
- region = region})})
+ let
+ val {arg, argType, body} =
+ elabMatchFn (m, nest, Cexp.RaiseMatch)
+ val body =
+ Cexp.enterLeave
+ (body, SourceInfo.function {name = nest,
+ region = region})
+ in
+ Cexp.make (Cexp.Lambda (Lambda.make {arg = arg,
+ argType = argType,
+ body = body}),
+ Type.arrow (argType, Cexp.ty body))
+ end
| Aexp.Handle (try, match) =>
- doit (Cexp.Handle (elabExp try, elabMatch (match, nest)))
+ let
+ val try = elab try
+ val {arg, argType, body} =
+ elabMatchFn (match, nest, Cexp.RaiseAgain)
+ val _ =
+ unify
+ (Cexp.ty try, Cexp.ty body, fn (l1, l2) =>
+ (region,
+ str "expression and handler don't agree",
+ align [seq [str "expression: ", l1],
+ seq [str "handler: ", l2]]))
+ val _ =
+ unify
+ (argType, Type.exn, fn (l1, _) =>
+ (Amatch.region match,
+ seq [str "handler must handle exn: ", l1],
+ empty))
+ in
+ Cexp.make (Cexp.Handle {catch = (arg, Type.exn),
+ handler = body,
+ try = try},
+ Cexp.ty try)
+ end
| Aexp.If (a, b, c) =>
- Cexp.iff (elabExp a, elabExp b, elabExp c, region)
+ let
+ val a' = elab a
+ val b' = elab b
+ val c' = elab c
+ val _ =
+ unify
+ (Cexp.ty a', Type.bool, fn (l1, _) =>
+ (Aexp.region a,
+ str "if test must be of type bool",
+ seq [str "test: ", l1]))
+ val _ =
+ unify
+ (Cexp.ty b', Cexp.ty c', fn (l1, l2) =>
+ (region,
+ str "then and else branches disagree",
+ align [seq [str "then: ", l1],
+ seq [str "else: ", l2]]))
+ in
+ Cexp.iff (a', b', c')
+ end
| Aexp.Let (d, e) =>
Env.scope
(E, fn () =>
- doit (Cexp.Let (Decs.toVector (elabDec (d, nest)),
- elabExp e)))
- | Aexp.List es => Cexp.list (List.map (es, elabExp), region)
+ let
+ val d = Decs.toVector (elabDec (d, nest, false))
+ val e = elab e
+ in
+ Cexp.make (Cexp.Let (d, e), Cexp.ty e)
+ end)
+ | Aexp.List es =>
+ let
+ val es' = Vector.map (es, elab)
+ in
+ Cexp.make (Cexp.List es',
+ unifyList
+ (Vector.map2 (es, es', fn (e, e') =>
+ (Cexp.ty e', Aexp.region e))))
+ end
| Aexp.Orelse (e, e') =>
- Cexp.orElse (elabExp e, elabExp e', region)
+ let
+ val ce = elab e
+ val ce' = elab e'
+ fun doit (ce, br) =
+ unify
+ (Cexp.ty ce, Type.bool,
+ fn (l, _) =>
+ (Aexp.region e,
+ str (concat
+ [br, " branch of orelse must be of type bool"]),
+ seq [str (concat [br, " branch: "]), l]))
+ val _ = doit (ce, "left")
+ val _ = doit (ce', "right")
+ in
+ Cexp.orElse (ce, ce')
+ end
| Aexp.Prim {kind, name, ty} =>
let
val ty = elabType ty
+ fun primApp {args, prim, result: Type.t} =
+ let
+ val targs =
+ Prim.extractTargs
+ {args = Vector.map (args, Cexp.ty),
+ deArray = Type.deArray,
+ deArrow = Type.deArrow,
+ deRef = Type.deRef,
+ deVector = Type.deVector,
+ deWeak = Type.deWeak,
+ prim = prim,
+ result = result}
+ in
+ Cexp.make (Cexp.PrimApp {args = args,
+ prim = prim,
+ targs = targs},
+ result)
+ end
+ fun eta (p: Prim.t): Cexp.t =
+ case Type.deArrowOpt ty of
+ NONE => primApp {args = Vector.new0 (),
+ prim = p,
+ result = ty}
+ | SOME (argType, bodyType) =>
+ let
+ val arg = Var.newNoname ()
+ fun app args =
+ primApp {args = args,
+ prim = p,
+ result = bodyType}
+ val body =
+ case Type.deTupleOpt argType of
+ NONE =>
+ app (Vector.new1
+ (Cexp.var (arg, argType)))
+ | SOME ts =>
+ let
+ val vars =
+ Vector.map
+ (ts, fn t =>
+ (Var.newNoname (), t))
+ in
+ Cexp.casee
+ {noMatch = Cexp.Impossible,
+ region = Region.bogus,
+ rules =
+ Vector.new1
+ (Cpat.tuple
+ (Vector.map (vars, Cpat.var)),
+ app (Vector.map
+ (vars, Cexp.var))),
+ test = Cexp.var (arg, argType)}
+ end
+ in
+ Cexp.lambda (Lambda.make {arg = arg,
+ argType = argType,
+ body = body})
+ end
+ fun lookConst (name: string) =
+ case Type.deConOpt ty of
+ NONE => Error.bug "strange constant"
+ | SOME (c, ts) =>
+ let
+ val ct =
+ if Tycon.equals (c, Tycon.bool)
+ then ConstType.Bool
+ else if Tycon.isIntX c
+ then ConstType.Int
+ else if Tycon.isRealX c
+ then ConstType.Real
+ else if Tycon.isWordX c
+ then ConstType.Word
+ else if Tycon.equals (c, Tycon.vector)
+ andalso 1 = Vector.length ts
+ andalso
+ (case (Type.deConOpt
+ (Vector.sub (ts, 0))) of
+ NONE => false
+ | SOME (c, _) =>
+ Tycon.equals
+ (c, Tycon.char))
+ then ConstType.String
+ else Error.bug "strange const type"
+ fun finish () = lookupConstant (name, ct)
+ in
+ Cexp.make (Cexp.Const finish, ty)
+ end
datatype z = datatype Ast.PrimKind.t
- val simple = doit o Cexp.Prim
in
case kind of
- BuildConst => simple (Cprim.buildConstant (name, ty))
- | Const => simple (Cprim.constant (name, ty))
+ BuildConst => lookConst name
+ | Const => lookConst name
| Export attributes =>
- let
- val ty = Scheme.ty ty
- in
- doit
- (Cexp.Constraint
- (Env.scope
- (E, fn () =>
- (Env.openStructure (E,
- valOf (!Env.Structure.ffi))
- ; elabExp' (export {attributes = attributes,
- name = name,
- region = region,
- ty = ty},
- nest))),
- Type.arrow (ty, Type.unit)))
- end
+ Env.scope
+ (E, fn () =>
+ (Env.openStructure (E,
+ valOf (!Env.Structure.ffi))
+ ; elabExp (export {attributes = attributes,
+ name = name,
+ region = region,
+ ty = ty},
+ nest)))
| Import attributes =>
- simple (import {attributes = attributes,
- name = name,
- region = region,
- ty = Scheme.ty ty})
- | Prim => simple (Cprim.new (name, ty))
+ eta (import {attributes = attributes,
+ name = name,
+ region = region,
+ ty = ty})
+ | Prim => eta (Prim.new name)
+ end
+ | Aexp.Raise exn =>
+ let
+ val region = Aexp.region exn
+ val exn = elab exn
+ val _ =
+ unify
+ (Cexp.ty exn, Type.exn, fn (l1, _) =>
+ (region,
+ str "raise must get an exception",
+ seq [str "expression: ", l1]))
+ val resultType = newType ()
+ in
+ Cexp.make (Cexp.Raise {exn = exn, region = region},
+ resultType)
end
- | Aexp.Raise {exn, filePos} =>
- doit (Cexp.Raise {exn = elabExp exn, filePos = filePos})
| Aexp.Record r =>
- doit (Cexp.Record (Record.map (r, elabExp)))
- | Aexp.Selector f =>
- Cexp.selector (f, region)
+ let
+ val r = Record.map (r, elab)
+ val ty =
+ Type.record
+ (SortedRecord.fromVector
+ (Record.toVector (Record.map (r, Cexp.ty))))
+ in
+ Cexp.make (Cexp.Record r, ty)
+ end
+ | Aexp.Selector f => elab (Aexp.selector (f, region))
| Aexp.Seq es =>
- Cexp.seq (Vector.map (es, elabExp), region)
+ let
+ val es = Vector.map (es, elab)
+ (* Could put warning here for expressions before a ; that
+ * don't return unit.
+ *)
+ in
+ Cexp.make (Cexp.Seq es, Cexp.ty (Vector.last es))
+ end
| Aexp.Var {name = id, ...} =>
- doit (case Env.lookupLongvid (E, id) of
- Vid.Var x => Cexp.Var x
- | Vid.ConAsVar c => Cexp.Con c
- | Vid.Con c => Cexp.Con c
- | Vid.Exn c => Cexp.Con c
- | Vid.Prim p => Cexp.Prim p)
- | Aexp.While {test, expr} =>
- Cexp.whilee {test = elabExp test,
- expr = elabExp expr,
- region = region}
+ let
+ val (vid, scheme) = Env.lookupLongvid (E, id)
+ val {args, instance} = Scheme.instantiate scheme
+ fun con c = Cexp.Con (c, args ())
+ val e =
+ case vid of
+ Vid.ConAsVar c => con c
+ | Vid.Con c => con c
+ | Vid.Exn c => con c
+ | Vid.Overload yts =>
+ let
+ val resolve =
+ Promise.lazy
+ (fn () =>
+ case (Vector.peek
+ (yts, fn (_, t) =>
+ Type.canUnify (instance, t))) of
+ NONE =>
+ let
+ val _ =
+ Control.error
+ (region,
+ seq [str "impossible use of overloaded var: ",
+ str (Longvid.toString id)],
+ Type.layoutPretty instance)
+ in
+ Var.newNoname ()
+ end
+ | SOME (y, t) =>
+ (unify (instance, t, fn _ =>
+ Error.bug "overload unify")
+ ; y))
+ val _ =
+ List.push (overloads, fn () =>
+ (resolve (); ()))
+ in
+ Cexp.Var (resolve, fn () => Vector.new0 ())
+ end
+ | Vid.Var x =>
+ Cexp.Var (fn () => x,
+ case ! (recursiveTargs x) of
+ NONE => args
+ | SOME f => f)
+ in
+ Cexp.make (e, instance)
+ end
+ | Aexp.While {expr, test} =>
+ let
+ val test' = elab test
+ val _ =
+ unify
+ (Cexp.ty test', Type.bool, fn (l1, _) =>
+ (Aexp.region test,
+ str "while-test must be of type bool",
+ seq [str "test: ", l1]))
+ (* Could put warning here if the expr is not of type unit.
+ *)
+ val expr = elab expr
+ in
+ Cexp.whilee {expr = expr, test = test'}
+ end
end) arg
- and elabMatch (Amatch.T {filePos, rules}, nest: Nest.t) =
- Cmatch.new {filePos = filePos,
- rules =
- Vector.map (rules, fn (pat, exp) =>
- Env.scope (E, fn () => (elaboratePat (pat, E),
- elabExp' (exp, nest))))}
+ and elabMatchFn (m: Amatch.t, nest, noMatch) =
+ let
+ val arg = Var.newNoname ()
+ val {argType, region, resultType, rules} = elabMatch (m, nest)
+ val body =
+ Cexp.casee {noMatch = noMatch,
+ region = region,
+ rules = rules,
+ test = Cexp.var (arg, argType)}
+ in
+ {arg = arg,
+ argType = argType,
+ body = body}
+ end
+ and elabMatch (m: Amatch.t, nest: Nest.t) =
+ let
+ val region = Amatch.region m
+ val Amatch.T rules = Amatch.node m
+ val argType = newType ()
+ val resultType = newType ()
+ val rules =
+ Vector.map
+ (rules, fn (pat, exp) =>
+ Env.scope
+ (E, fn () =>
+ let
+ val (p, xts) = elaboratePat (pat, E, false)
+ val _ =
+ unify
+ (Cpat.ty p, argType, fn (l1, l2) =>
+ (Apat.region pat,
+ str "rule patterns not of same type",
+ align [seq [str "this rule: ", l1],
+ seq [str "previous: ", l2]]))
+ val e = elabExp (exp, nest)
+ val _ =
+ unify
+ (Cexp.ty e, resultType, fn (l1, l2) =>
+ (Aexp.region exp,
+ str "cases not of same type",
+ align [seq [str "this case: ", l1],
+ seq [str "previous cases: ", l2]]))
+ in
+ (p, e)
+ end))
+ in
+ {argType = argType,
+ region = region,
+ resultType = resultType,
+ rules = rules}
+ end
+ val ds = elabDec (Scope.scope d, nest, true)
+ val _ = List.foreach (!overloads, fn p => (p (); ()))
+ val _ = overloads := []
+ val _ = List.foreach (!freeTyvarChecks, fn p => p ())
+ val _ = freeTyvarChecks := []
+ val _ = TypeEnv.closeTop (Adec.region d)
in
- elabDec (Scope.scope d, nest)
+ ds
end
end
1.5 +8 -2 mlton/mlton/elaborate/elaborate-core.sig
Index: elaborate-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- elaborate-core.sig 24 Jun 2003 20:14:22 -0000 1.4
+++ elaborate-core.sig 9 Oct 2003 18:17:33 -0000 1.5
@@ -11,10 +11,12 @@
signature ELABORATE_CORE_STRUCTS =
sig
structure Ast: AST
+ structure ConstType: CONST_TYPE
structure CoreML: CORE_ML
structure Decs: DECS
structure Env: ELABORATE_ENV
- sharing Ast = CoreML.Ast
+ sharing Ast = Env.Ast
+ sharing Ast.Tyvar = CoreML.Tyvar
sharing CoreML = Decs.CoreML = Env.CoreML
end
@@ -23,5 +25,9 @@
include ELABORATE_CORE_STRUCTS
(* Elaborate dec in env, returning Core ML decs. *)
- val elaborateDec: Ast.Dec.t * string list * Env.t -> Decs.t
+ val elaborateDec:
+ Ast.Dec.t * {env: Env.t,
+ lookupConstant: string * ConstType.t -> CoreML.Const.t,
+ nest: string list}
+ -> Decs.t
end
1.12 +154 -101 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- elaborate-env.fun 26 Jun 2003 19:17:30 -0000 1.11
+++ elaborate-env.fun 9 Oct 2003 18:17:33 -0000 1.12
@@ -10,8 +10,10 @@
open S
-local open Ast
-in structure Fixity = Fixity
+local
+ open Ast
+in
+ structure Fixity = Fixity
structure Strid = Strid
structure Longcon = Longcon
structure Longvid = Longvid
@@ -19,104 +21,145 @@
structure Longtycon = Longtycon
end
-local open CoreML
-in structure Con = Con
+local
+ open CoreML
+in
+ structure Con = Con
structure Var = Var
structure Prim = Prim
structure Record = Record
- structure Scheme = Scheme
structure Srecord = SortedRecord
structure Tycon = Tycon
- structure Type = Type
structure Tyvar = Tyvar
structure Var = Var
end
-structure Scope = UniqueId ()
+local
+ open TypeEnv
+in
+ structure Scheme = InferScheme
+ structure Type = Type
+end
+
+structure Decs = Decs (structure CoreML = CoreML)
+structure Scheme =
+ struct
+ open Scheme
+
+ val bogus = fromType (Type.var (Tyvar.newNoname {equality = false}))
+ end
+
+structure TypeScheme = Scheme
+
+structure Scope = UniqueId ()
+
structure TypeStr =
struct
- datatype t =
- Datatype of {cons: {name: Ast.Con.t,
- con: Con.t} vector,
+ structure Kind = CoreML.Tycon.Kind
+
+ datatype node =
+ Datatype of {cons: {con: Con.t,
+ name: Ast.Con.t,
+ scheme: Scheme.t} vector,
tycon: Tycon.t}
| Scheme of Scheme.t
| Tycon of Tycon.t
+ datatype t = T of {kind: Kind.t,
+ node: node}
+
+ local
+ fun make f (T r) = f r
+ in
+ val kind = make #kind
+ val node = make #node
+ end
+
val bogus =
- Scheme (Scheme.T
- {tyvars = Vector.new0 (),
- ty = Type.Var (Ast.Tyvar.newNoname {equality = false})})
+ T {kind = Kind.Arity 0,
+ node = Scheme Scheme.bogus}
fun abs t =
- case t of
- Datatype {tycon, ...} => Tycon tycon
+ case node t of
+ Datatype {tycon, ...} => T {kind = kind t,
+ node = Tycon tycon}
| _ => t
- fun apply (t, tys) =
- case t of
+ fun apply (t: t, tys: Type.t vector): Type.t =
+ case node t of
Datatype {tycon, ...} => Type.con (tycon, tys)
| Scheme s => Scheme.apply (s, tys)
| Tycon t => Type.con (t, tys)
fun cons t =
- case t of
+ case node t of
Datatype {cons, ...} => cons
| _ => Vector.new0 ()
- fun data (tycon, cons) = Datatype {tycon = tycon, cons = cons}
+ fun data (tycon, kind, cons) =
+ T {kind = kind,
+ node = Datatype {tycon = tycon, cons = cons}}
- val def = Scheme
+ fun def (s, kind) = T {kind = kind,
+ node = Scheme s}
- val tycon = Tycon
+ fun tycon (c, kind) = T {kind = kind,
+ node = Tycon c}
fun layout t =
- let open Layout
- in case t of
- Datatype {tycon, cons} =>
- seq [str "Datatype ",
- record [("tycon", Tycon.layout tycon),
- ("cons", (Vector.layout (fn {name, con} =>
- tuple [Ast.Con.layout name,
- Con.layout con])
- cons))]]
- | Scheme s => Scheme.layout s
- | Tycon t => seq [str "Tycon ", Tycon.layout t]
+ let
+ open Layout
+ in
+ case node t of
+ Datatype {tycon, cons} =>
+ seq [str "Datatype ",
+ record [("tycon", Tycon.layout tycon),
+ ("cons", (Vector.layout
+ (fn {con, name, scheme} =>
+ tuple [Ast.Con.layout name,
+ Con.layout con,
+ str ": ",
+ Scheme.layout scheme])
+ cons))]]
+ | Scheme s => Scheme.layout s
+ | Tycon t => seq [str "Tycon ", Tycon.layout t]
end
end
structure Vid =
struct
- open CoreML
-
datatype t =
- Var of Var.t
- | Con of Con.t
- | ConAsVar of CoreML.Con.t
+ Con of Con.t
+ | ConAsVar of Con.t
| Exn of Con.t
- | Prim of Prim.t
+ | Overload of (Var.t * Type.t) vector
+ | Var of Var.t
val statusString =
- fn Var _ => "var"
- | Prim _ => "var"
+ fn Con _ => "con"
| ConAsVar _ => "var"
- | Con _ => "con"
| Exn _ => "exn"
+ | Overload _ => "var"
+ | Var _ => "var"
val bogus = Var Var.bogus
fun layout vid =
- let open Layout
+ let
+ open Layout
val (name, l) =
case vid of
- Var v => ("Var", Var.layout v)
- | Con c => ("Con", Con.layout c)
+ Con c => ("Con", Con.layout c)
| ConAsVar c => ("ConAsVar", Con.layout c)
| Exn c => ("Exn", Con.layout c)
- | Prim p => ("Prim", Prim.layout p)
- in if false
- then l
- else paren (seq [str name, str " ", l])
+ | Overload xts =>
+ ("Overload",
+ Vector.layout (Layout.tuple2 (Var.layout, Type.layout))
+ xts)
+ | Var v => ("Var", Var.layout v)
+ in
+ paren (seq [str name, str " ", l])
end
val deVar =
@@ -127,10 +170,6 @@
fn Con c => SOME c
| Exn c => SOME c
| _ => NONE
-
- val dePrim =
- fn Prim p => SOME p
- | _ => NONE
fun output (r, out) = Layout.output (layout r, out)
end
@@ -307,7 +346,7 @@
datatype t = T of {shapeId: ShapeId.t option,
strs: (Ast.Strid.t, t) Info.t,
types: (Ast.Tycon.t, TypeStr.t) Info.t,
- vals: (Ast.Vid.t, Vid.t) Info.t}
+ vals: (Ast.Vid.t, Vid.t * Scheme.t) Info.t}
fun layoutUsed (T {strs, types, vals, ...}) =
let
@@ -327,25 +366,26 @@
align [seq [str "structure ", Ast.Strid.layout d],
indent (layoutUsed r, 3)])]
end
+
fun layout (T {strs, vals, types, ...}) =
Layout.record
[("types", Info.layout (Ast.Tycon.layout, TypeStr.layout) types),
- ("vals", Info.layout (Ast.Vid.layout, Vid.layout) vals),
+ ("vals",
+ Info.layout (Ast.Vid.layout,
+ Layout.tuple2 (Vid.layout, Scheme.layout))
+ vals),
("strs", Info.layout (Ast.Strid.layout, layout) strs)]
local
open Layout
in
fun layoutTypeSpec (d, _) = seq [str "type ", Ast.Tycon.layout d]
- fun layoutValSpec (d, r) =
- seq [str (case r of
- Vid.Var _ => "val"
- | Vid.Con _ => "con"
- | Vid.ConAsVar _ => "val"
- | Vid.Exn _ => "exn"
- | Vid.Prim _ => "val"),
+ fun layoutValSpec (d, (vid, scheme)) =
+ seq [str (Vid.statusString vid),
str " ",
- Ast.Vid.layout d]
+ Ast.Vid.layout d,
+ str ": ",
+ Scheme.layoutPretty scheme]
fun layoutStrSpec (d, r) =
seq [str "structure ", Ast.Strid.layout d, str ": ",
layoutPretty r]
@@ -385,16 +425,11 @@
fun peekTycon z = Option.map (peekTycon' z, #range)
fun peekVid z = Option.map (peekVid' z, #range)
- val peekVid =
- Trace.trace2 ("peekVid",
- layout, Ast.Vid.layout, Option.layout Vid.layout)
- peekVid
-
local
fun make (from, de) (S, x) =
case peekVid (S, from x) of
NONE => NONE
- | SOME vid => de vid
+ | SOME (vid, s) => Option.map (de vid, fn z => (z, s))
in
val peekCon = make (Ast.Vid.fromCon, Vid.deCon)
val peekVar = make (Ast.Vid.fromVar, Vid.deVar)
@@ -470,11 +505,11 @@
(Longtycon.long (rev strids, name)))
| SOME {range = typeStr', values, ...} =>
let
- datatype z = datatype TypeStr.t
+ datatype z = datatype TypeStr.node
val typeStr'' =
case typeStr of
Interface.TypeStr.Datatype {cons} =>
- (case typeStr' of
+ (case TypeStr.node typeStr' of
Datatype _ => typeStr'
| _ =>
(Control.error
@@ -487,9 +522,11 @@
| Interface.TypeStr.Tycon =>
let
datatype z = datatype TypeStr.t
- in case typeStr' of
+ in case TypeStr.node typeStr' of
Datatype {tycon, ...} =>
- Tycon tycon
+ TypeStr.T
+ {kind = TypeStr.kind typeStr',
+ node = Tycon tycon}
| _ => typeStr'
end
in List.push (types,
@@ -503,7 +540,7 @@
error (Longvid.className,
Longvid.layout (Longvid.long
(rev strids, name)))
- | SOME {range = vid, values, ...} =>
+ | SOME {range = (vid, s), values, ...} =>
let
val vid =
case (vid, status) of
@@ -531,9 +568,10 @@
" in signature "]),
Layout.empty)
; vid)
- in List.push (vals,
+ in
+ List.push (vals,
{isUsed = ref false,
- range = vid,
+ range = (vid, s),
values = values})
end
val _ =
@@ -699,7 +737,7 @@
sigs: (Ast.Sigid.t, Interface.t) NameSpace.t,
strs: (Ast.Strid.t, Structure.t) NameSpace.t,
types: (Ast.Tycon.t, TypeStr.t) NameSpace.t,
- vals: (Ast.Vid.t, Vid.t) NameSpace.t}
+ vals: (Ast.Vid.t, Vid.t * Scheme.t) NameSpace.t}
fun clean (T {fcts, fixs, sigs, strs, types, vals, ...}): unit =
let
@@ -738,7 +776,8 @@
fun layout (T {strs, types, vals, ...}) =
Layout.tuple
[NameSpace.layout (Ast.Tycon.layout, TypeStr.layout) types,
- NameSpace.layout (Ast.Vid.layout, Vid.layout) vals,
+ NameSpace.layout (Ast.Vid.layout,
+ Layout.tuple2 (Vid.layout, Scheme.layout)) vals,
NameSpace.layout (Ast.Strid.layout, Structure.layout) strs]
fun layoutPretty (T {fcts, sigs, strs, types, vals, ...}) =
@@ -855,7 +894,8 @@
val strs = doit (strs, Ast.Strid.layout)
val types = doit (types, Ast.Tycon.layout)
val vals = doit (vals, Ast.Vid.layout)
- in fn th =>
+ in
+ fn th =>
let
val s0 = Scope.new ()
val fcts = fcts s0
@@ -869,7 +909,8 @@
val res = th ()
val _ = currentScope := s1
val _ = (fcts (); fixs (); sigs (); strs (); types (); vals ())
- in res
+ in
+ res
end
end
@@ -891,14 +932,13 @@
val apply =
Trace.trace ("functorApply",
Structure.layout o #1,
- Layout.tuple2 (Decs.layout, Structure.layout))
+ Layout.tuple2 (Layout.ignore, Structure.layout))
apply
fun sizeMessage () = layoutSize apply
in
FunctorClosure.T {apply = apply,
sizeMessage = sizeMessage}
end
-
(* ------------------------------------------------- *)
(* peek *)
@@ -920,13 +960,13 @@
fun peekVar (E, x) =
case peekVid (E, Ast.Vid.fromVar x) of
NONE => NONE
- | SOME vid => Vid.deVar vid
+ | SOME (vid, s) => Option.map (Vid.deVar vid, fn x => (x, s))
end
-fun peekCon (E: t, c: Ast.Con.t): CoreML.Con.t option =
+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 => Vid.deCon vid
+ | SOME (vid, s) => Option.map (Vid.deCon vid, fn c => (c, s))
local
fun make (split, peek, strPeek) (E, x) =
@@ -944,13 +984,20 @@
| SOME S => strPeek (S, x)
end
in
- val peekLongstrid = make (Ast.Longstrid.split, peekStrid, Structure.peekStrid)
- val peekLongtycon = make (Ast.Longtycon.split, peekTycon, Structure.peekTycon)
+ 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,
+ Option.layout (Layout.tuple2
+ (CoreML.Con.layout, TypeScheme.layout)))
+ peekLongcon
(* ------------------------------------------------- *)
(* lookup *)
(* ------------------------------------------------- *)
@@ -964,13 +1011,16 @@
| NONE => (unbound x; bogus)
in
val lookupFctid = make (peekFctid, FunctorClosure.bogus, Ast.Fctid.unbound)
- val lookupLongcon = make (peekLongcon, Con.bogus, Ast.Longcon.unbound)
+ val lookupLongcon =
+ make (peekLongcon, (Con.bogus, Scheme.bogus), Ast.Longcon.unbound)
val lookupLongstrid =
make (peekLongstrid, Structure.bogus, Ast.Longstrid.unbound)
val lookupLongtycon =
make (peekLongtycon, TypeStr.bogus, Ast.Longtycon.unbound)
- val lookupLongvid = make (peekLongvid, Vid.bogus, Ast.Longvid.unbound)
- val lookupLongvar = make (peekLongvar, Var.bogus, Ast.Longvar.unbound)
+ val lookupLongvid =
+ make (peekLongvid, (Vid.bogus, Scheme.bogus), Ast.Longvid.unbound)
+ val lookupLongvar =
+ make (peekLongvar, (Var.bogus, Scheme.bogus), Ast.Longvar.unbound)
val lookupSigid = make (peekSigid, Interface.bogus, Ast.Sigid.unbound)
end
@@ -1008,17 +1058,22 @@
Unit.layout)
extendTycon
-fun extendCon (E, c, c') =
- extendVals (E, Ast.Vid.fromCon c, Vid.Con c')
+fun extendCon (E, c, c', s) =
+ extendVals (E, Ast.Vid.fromCon c, (Vid.Con c', s))
-fun extendExn (E, c, c') =
- extendVals (E, Ast.Vid.fromCon c, Vid.Exn c')
+fun extendExn (E, c, c', s) =
+ extendVals (E, Ast.Vid.fromCon c, (Vid.Exn c', s))
-fun extendVar (E, x, x') =
- extendVals (E, Ast.Vid.fromVar x, Vid.Var x')
+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.trace3 ("extendVar", layout, Ast.Var.layout, Var.layout, Unit.layout)
+ Trace.trace4
+ ("extendVar", Layout.ignore, Ast.Var.layout, Var.layout, Scheme.layoutPretty,
+ Unit.layout)
extendVar
(* ------------------------------------------------- *)
@@ -1098,10 +1153,11 @@
val types = types ()
val vals = vals ()
val _ = currentScope := Scope.new ()
- val a2 = f2 ()
+ val a2 = f2 a1
val _ = (fixs (); strs (); types (); vals ())
val _ = currentScope := s0
- in (a1, a2)
+ in
+ a2
end
(* Can't eliminate the use of strs in localCore, because openn still modifies
@@ -1337,7 +1393,4 @@
types = NameSpace.new let open Ast.Tycon in (equals, hash) end,
vals = NameSpace.new let open Ast.Vid in (equals, hash) end}
-fun addEquals E =
- extendVals (E, Ast.Vid.fromString ("=", Region.bogus), Vid.Prim Prim.equal)
-
end
1.7 +48 -30 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- elaborate-env.sig 26 Jun 2003 19:17:30 -0000 1.6
+++ elaborate-env.sig 9 Oct 2003 18:17:33 -0000 1.7
@@ -12,45 +12,62 @@
sig
structure Ast: AST
structure CoreML: CORE_ML
- structure Decs: DECS
- sharing Ast = CoreML.Ast = Decs.Ast
- sharing CoreML = Decs.CoreML
+ structure TypeEnv: TYPE_ENV
+ sharing Ast.Record = CoreML.Record
+ sharing Ast.SortedRecord = CoreML.SortedRecord
+ sharing CoreML.Atoms = TypeEnv.Atoms
+ sharing CoreML.Type = TypeEnv.Type
end
signature ELABORATE_ENV =
sig
include ELABORATE_ENV_STRUCTS
+ structure Decs: DECS
+ sharing CoreML = Decs.CoreML
+
+ structure Type:
+ sig
+ type t
+ end
+ sharing type Type.t = TypeEnv.Type.t
+ structure TypeScheme:
+ sig
+ type t
+ end
+ sharing type TypeScheme.t = TypeEnv.InferScheme.t
(* The value of a vid. This is used to distinguish between vids whose
* status cannot be determined at parse time.
*)
structure Vid:
sig
datatype t =
- Var of CoreML.Var.t
- | ConAsVar of CoreML.Con.t (* a constructor, but it has status
- * of a variable.
- *)
- | Con of CoreML.Con.t
+ Con of CoreML.Con.t
+ | ConAsVar of CoreML.Con.t
| Exn of CoreML.Con.t
- | Prim of CoreML.Prim.t
+ | Overload of (CoreML.Var.t * TypeEnv.Type.t) vector
+ | Var of CoreML.Var.t
- val deVar: t -> CoreML.Var.t option
- val deCon: t -> CoreML.Con.t option
val layout: t -> Layout.t
end
structure TypeStr:
sig
+ structure Kind: TYCON_KIND
type t
val abs: t -> t
- val apply: t * CoreML.Type.t vector -> CoreML.Type.t
- val cons: t -> {name: Ast.Con.t,
- con: CoreML.Con.t} vector
- val data: CoreML.Tycon.t * {name: Ast.Con.t,
- con: CoreML.Con.t} vector -> t
- val def: CoreML.Scheme.t -> t
- val tycon: CoreML.Tycon.t -> t
+ val apply: t * TypeEnv.Type.t vector -> TypeEnv.Type.t
+ val cons: t -> {con: CoreML.Con.t,
+ name: Ast.Con.t,
+ scheme: TypeScheme.t} vector
+ val data:
+ CoreML.Tycon.t * Kind.t
+ * {con: CoreML.Con.t,
+ name: Ast.Con.t,
+ scheme: TypeScheme.t} vector -> t
+ val def: TypeScheme.t * Kind.t -> t
+ val kind: t -> Kind.t
+ val tycon: CoreML.Tycon.t * Kind.t -> t
end
structure Interface:
sig
@@ -89,46 +106,47 @@
type t
val apply:
- t * Structure.t * string list * Region.t
- -> Decs.t * Structure.t
+ t * Structure.t * string list * Region.t -> Decs.t * Structure.t
end
type t
- val addEquals: t -> unit
(* Remove unnecessary entries. *)
val clean: t -> unit
val empty: unit -> t
- val extendCon: t * Ast.Con.t * CoreML.Con.t -> unit
- val extendExn: t * Ast.Con.t * CoreML.Con.t -> unit
+ val extendCon: t * Ast.Con.t * CoreML.Con.t * TypeScheme.t -> unit
+ val extendExn: t * Ast.Con.t * CoreML.Con.t * TypeScheme.t -> unit
val extendFctid: t * Ast.Fctid.t * FunctorClosure.t -> unit
val extendFix: t * Ast.Vid.t * Ast.Fixity.t -> unit
val extendSigid: t * Ast.Sigid.t * Interface.t -> unit
val extendStrid: t * Ast.Strid.t * Structure.t -> unit
val extendTycon: t * Ast.Tycon.t * TypeStr.t -> unit
- val extendVar: t * Ast.Var.t * CoreML.Var.t -> unit
+ val extendVar: t * Ast.Var.t * CoreML.Var.t * TypeScheme.t -> unit
+ val extendOverload:
+ t * Ast.Var.t * (CoreML.Var.t * TypeEnv.Type.t) vector * TypeScheme.t
+ -> unit
val functorClosure:
t * Interface.t * (Structure.t * string list -> Decs.t * Structure.t)
-> FunctorClosure.t
val layout: t -> Layout.t
val layoutPretty: t -> Layout.t
val layoutUsed: t -> Layout.t
- val localCore: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
- val localModule: t * (unit -> 'a) * (unit -> 'b) -> 'a * 'b
+ val localCore: t * (unit -> 'a) * ('a -> 'b) -> 'b
+ val localModule: t * (unit -> 'a) * ('a -> 'b) -> '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 lookupLongcon: t * Ast.Longcon.t -> CoreML.Con.t * TypeScheme.t
val lookupLongstrid: t * Ast.Longstrid.t -> Structure.t
val lookupLongtycon: t * Ast.Longtycon.t -> TypeStr.t
- val lookupLongvar: t * Ast.Longvar.t -> CoreML.Var.t
- val lookupLongvid: t * Ast.Longvid.t -> Vid.t
+ val lookupLongvar: t * Ast.Longvar.t -> CoreML.Var.t * TypeScheme.t
+ val lookupLongvid: t * Ast.Longvid.t -> Vid.t * TypeScheme.t
val lookupSigid: t * Ast.Sigid.t -> Interface.t
val makeInterfaceMaker: t -> InterfaceMaker.t
val makeStructure: t * (unit -> 'a) -> 'a * Structure.t
(* openStructure (E, S) opens S in the environment E. *)
val openStructure: t * Structure.t -> unit
val peekFix: t * Ast.Vid.t -> Ast.Fixity.t option
- val peekLongcon: t * Ast.Longcon.t -> CoreML.Con.t option
+ val peekLongcon: t * Ast.Longcon.t -> (CoreML.Con.t * TypeScheme.t) option
val peekLongtycon: t * Ast.Longtycon.t -> TypeStr.t option
(* scope f evaluates f () in a new scope so that extensions that occur
* during f () are forgotten afterwards.
1.6 +35 -13 mlton/mlton/elaborate/elaborate.fun
Index: elaborate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- elaborate.fun 26 Feb 2003 00:17:36 -0000 1.5
+++ elaborate.fun 9 Oct 2003 18:17:33 -0000 1.6
@@ -10,10 +10,13 @@
open S
-local open Ast
-in structure FctArg = FctArg
+local
+ open Ast
+in
+ structure FctArg = FctArg
structure Longstrid = Longstrid
structure Topdec = Topdec
+
structure SigConst = SigConst
structure Sigexp = Sigexp
structure Strdec = Strdec
@@ -21,19 +24,18 @@
structure Strexp = Strexp
end
-local open CoreML
-in structure Con = Con
+local
+ open CoreML
+in
+ structure Con = Con
structure Prim = Prim
- structure Scheme = Scheme
structure Tycon = Tycon
structure Type = Type
end
-structure Decs = Decs (structure Ast = Ast
- structure CoreML = CoreML)
structure Env = ElaborateEnv (structure Ast = Ast
structure CoreML = CoreML
- structure Decs = Decs)
+ structure TypeEnv = TypeEnv)
local
open Env
@@ -49,7 +51,20 @@
structure Env = Env
structure Interface = Interface)
+structure ConstType =
+ struct
+ datatype t = Bool | Int | Real | String | Word
+
+ val toString =
+ fn Bool => "Bool"
+ | Int => "Int"
+ | Real => "Real"
+ | String => "String"
+ | Word => "Word"
+ end
+
structure ElaborateCore = ElaborateCore (structure Ast = Ast
+ structure ConstType = ConstType
structure CoreML = CoreML
structure Decs = Decs
structure Env = Env)
@@ -57,8 +72,11 @@
val info = Trace.info "elaborateStrdec"
val info' = Trace.info "elaborateTopdec"
-fun elaborateProgram (Ast.Program.T decs, E: Env.t) =
+fun elaborateProgram (program,
+ E: Env.t,
+ lookupConstant) =
let
+ val Ast.Program.T decs = Ast.Program.coalesce program
fun elabSigexp s = ElaborateSigexp.elaborateSigexp (s, E)
fun elabSigexpConstraint (cons: SigConst.t, S: Structure.t): Structure.t =
let
@@ -81,15 +99,19 @@
Layout.ignore)
(fn (d: Strdec.t, nest: string list) =>
let
+ val d = Strdec.coalesce d
val elabStrdec = fn d => elabStrdec (d, nest)
in
case Strdec.node d of
Strdec.Core d => (* rule 56 *)
- ElaborateCore.elaborateDec (d, nest, E)
+ ElaborateCore.elaborateDec
+ (d, {env = E,
+ lookupConstant = lookupConstant,
+ nest = nest})
| Strdec.Local (d, d') => (* rule 58 *)
- Decs.append (Env.localModule (E,
- fn () => elabStrdec d,
- fn () => elabStrdec d'))
+ Env.localModule (E,
+ fn () => elabStrdec d,
+ fn d => Decs.append (d, elabStrdec d'))
| Strdec.Seq ds => (* rule 60 *)
List.fold
(ds, Decs.empty, fn (d, decs) =>
1.3 +12 -3 mlton/mlton/elaborate/elaborate.sig
Index: elaborate.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- elaborate.sig 10 Apr 2002 07:02:20 -0000 1.2
+++ elaborate.sig 9 Oct 2003 18:17:33 -0000 1.3
@@ -12,14 +12,23 @@
sig
structure Ast: AST
structure CoreML: CORE_ML
- sharing Ast = CoreML.Ast
+ structure TypeEnv: TYPE_ENV
+ sharing Ast.Record = CoreML.Record
+ sharing Ast.SortedRecord = CoreML.SortedRecord
+ sharing Ast.Tyvar = CoreML.Tyvar
+ sharing CoreML.Atoms = TypeEnv.Atoms
+ sharing CoreML.Type = TypeEnv.Type
end
signature ELABORATE =
sig
include ELABORATE_STRUCTS
+
+ structure ConstType: CONST_TYPE
structure Decs: DECS
structure Env: ELABORATE_ENV
-
- val elaborateProgram: Ast.Program.t * Env.t -> Decs.t
+
+ val elaborateProgram:
+ Ast.Program.t * Env.t * (string * ConstType.t -> CoreML.Const.t)
+ -> Decs.t
end
1.2 +18 -22 mlton/mlton/elaborate/scope.fun
Index: scope.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/scope.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- scope.fun 21 Jul 2003 21:53:50 -0000 1.1
+++ scope.fun 9 Oct 2003 18:17:33 -0000 1.2
@@ -177,8 +177,7 @@
fixop = fixop,
pat = pat,
var = var})
- | List ps => do1 (loops (Vector.fromList ps, loop),
- fn ps => List (Vector.toList ps))
+ | List ps => do1 (loops (ps, loop), List)
| Record {flexible, items} =>
let
val (items, u) =
@@ -298,7 +297,7 @@
let
val (down, finish) = bind' (down, tyvars)
val (decs, u) =
- loops (decs, fn {clauses, filePos} =>
+ loops (decs, fn clauses =>
let
val (clauses, u) =
loops
@@ -317,9 +316,7 @@
combineUp (u, combineUp (u', u'')))
end)
in
- ({clauses = clauses,
- filePos = filePos},
- u)
+ (clauses, u)
end)
val (tyvars, u) = finish u
in
@@ -328,7 +325,14 @@
| Local (d, d') =>
do2 (loopDec (d, down), loopDec (d', down), Local)
| Open _ => empty ()
- | Overload _ => empty ()
+ | Overload (x, tyvars, ty, ys) =>
+ let
+ val (down, finish) = bind' (down, tyvars)
+ val (ty, up) = loopTy (ty, down)
+ val (tyvars, up) = finish up
+ in
+ (doit (Overload (x, tyvars, ty, ys)), up)
+ end
| SeqDec ds => doVec (ds, SeqDec)
| Type tb => do1 (loopTypBind (tb, down), Type)
| Val {rvbs, tyvars, vbs} =>
@@ -345,13 +349,12 @@
combineUp (u, u'))
end)
val (vbs, u') =
- loops (vbs, fn {exp, filePos, pat} =>
+ loops (vbs, fn {exp, pat} =>
let
val (exp, u) = loopExp (exp, down)
val (pat, u') = loopPat (pat, down)
in
({exp = exp,
- filePos = filePos,
pat = pat},
combineUp (u, u'))
end)
@@ -385,13 +388,6 @@
in
(doit (f es), u)
end
- fun doList (es: Exp.t list, f: Exp.t list -> Exp.node)
- : Exp.t * 'up =
- let
- val (es, u) = loops (Vector.fromList es, loop)
- in
- (doit (f (Vector.toList es)), u)
- end
in
case Exp.node e of
Andalso (e1, e2) => do2 (loop e1, loop e2, Andalso)
@@ -404,16 +400,14 @@
| Handle (e, m) => do2 (loop e, loopMatch m, Handle)
| If (e1, e2, e3) => do3 (loop e1, loop e2, loop e3, If)
| Let (dec, e) => do2 (loopDec (dec, d), loop e, Let)
- | List ts => doList (ts, List)
+ | List ts => doVec (ts, List)
| Orelse (e1, e2) => do2 (loop e1, loop e2, Orelse)
| Prim {kind, name, ty} =>
do1 (loopTy (ty, d), fn ty =>
Prim {kind = kind,
name = name,
ty = ty})
- | Raise {exn, filePos} =>
- do1 (loop exn,
- fn exn => Raise {exn = exn, filePos = filePos})
+ | Raise exn => do1 (loop exn, Raise)
| Record r =>
let
val (r, u) = Record.change (r, fn es =>
@@ -431,8 +425,9 @@
in
loop e
end
- and loopMatch (Match.T {filePos, rules}, d) =
+ and loopMatch (m, d) =
let
+ val (Match.T rules, region) = Match.dest m
val (rules, u) =
loops (rules, fn (p, e) =>
let
@@ -442,7 +437,8 @@
((p, e), combineUp (u, u'))
end)
in
- (Match.T {filePos = filePos, rules = rules}, u)
+ (Match.makeRegion (Match.T rules, region),
+ u)
end
in
loopDec (d, initDown)
1.4 +6 -2 mlton/mlton/elaborate/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm 21 Jul 2003 21:53:50 -0000 1.3
+++ sources.cm 9 Oct 2003 18:17:33 -0000 1.4
@@ -7,9 +7,11 @@
*)
Group
+signature CONST_TYPE
signature ELABORATE
functor Elaborate
-
+functor TypeEnv
+
is
../ast/sources.cm
@@ -18,7 +20,7 @@
../core-ml/sources.cm
../../lib/mlton/sources.cm
-
+const-type.sig
decs.fun
decs.sig
elaborate-core.fun
@@ -33,3 +35,5 @@
precedence-parse.sig
scope.fun
scope.sig
+type-env.fun
+type-env.sig
1.1 mlton/mlton/elaborate/const-type.sig
Index: const-type.sig
===================================================================
signature CONST_TYPE =
sig
datatype t = Bool | Int | Real | String | Word
val toString: t -> string
end
1.1 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor TypeEnv (S: TYPE_ENV_STRUCTS): TYPE_ENV =
struct
open S
structure Field = Record.Field
structure Srecord = SortedRecord
structure Set = DisjointSet
(*
* Keep a clock so that when we need to generalize a type we can tell which
* unknowns were created in the expression being generalized.
*
* Keep track of all unknowns and the time allocated.
*
* Unify should always keep the older unknown.
*
* If they are unknowns since the clock, they may be generalized.
*
* For type variables, keep track of the time that they need to be generalized
* at. If they are ever unified with an unknown of an earlier time, then
* they can't be generalized.
*)
structure Time:>
sig
type t
val <= : t * t -> bool
val equals: t * t -> bool
val min: t * t -> t
val layout: t -> Layout.t
val now: unit -> t
val tick: unit -> t
end =
struct
type t = int
val equals = op =
val min = Int.min
val op <= = Int.<=
val layout = Int.layout
val clock: t ref = ref 0
fun now () = !clock
fun tick () = (clock := 1 + !clock
; !clock)
end
structure Unknown =
struct
datatype t = T of {canGeneralize: bool,
equality: bool,
id: int,
time: Time.t ref}
local
fun make f (T r) = f r
in
val time = ! o (make #time)
end
fun layout (T {canGeneralize, id, time, ...}) =
let
open Layout
in
seq [str "Unknown ",
record [("canGeneralize", Bool.layout canGeneralize),
("id", Int.layout id),
("time", Time.layout (!time))]]
end
fun minTime (u as T {time, ...}, t) =
if Time.<= (!time, t)
then ()
else time := t
fun layoutPretty (T {id, ...}) =
let
open Layout
in
seq [str "'a", Int.layout id]
end
val toString = Layout.toString o layoutPretty
local
val r: int ref = ref 0
in
fun newId () = (Int.inc r; !r)
end
fun new {canGeneralize, equality} =
T {canGeneralize = canGeneralize,
equality = equality,
id = newId (),
time = ref (Time.now ())}
fun join (T r, T r'): t =
T {canGeneralize = #canGeneralize r andalso #canGeneralize r',
equality = #equality r andalso #equality r',
id = newId (),
time = ref (Time.min (! (#time r), ! (#time r')))}
end
(* Flexible record spine, i.e. a possibly extensible list of fields. *)
structure Spine:
sig
type t
val canAddFields: t -> bool
val empty: unit -> t
val equals: t * t -> bool
val fields: t -> Field.t list
(* ensureField checks if field is there. If it is not, then ensureField
* will add it unless no more fields are allowed in the spine.
* It returns true iff it succeeds.
*)
val ensureField: t * Field.t -> bool
val foldOverNew: t * (Field.t * 'a) list * 'b * (Field.t * 'b -> 'b) -> 'b
val layout: t -> Layout.t
val new: Field.t list -> t
val noMoreFields: t -> unit
(* Unify returns the fields that are in each spine but not in the other.
*)
val unify: t * t -> unit
end =
struct
datatype t = T of {fields: Field.t list ref,
more: bool ref} Set.t
fun new fields = T (Set.singleton {fields = ref fields,
more = ref true})
fun equals (T s, T s') = Set.equals (s, s')
fun empty () = new []
fun layout (T s) =
let
val {fields, more} = Set.value s
in
Layout.record [("fields", List.layout Field.layout (!fields)),
("more", Bool.layout (!more))]
end
fun canAddFields (T s) = ! (#more (Set.value s))
fun fields (T s) = ! (#fields (Set.value s))
fun ensureFieldValue ({fields, more}, f) =
List.contains (!fields, f, Field.equals)
orelse (!more andalso (List.push (fields, f); true))
fun ensureField (T s, f) = ensureFieldValue (Set.value s, f)
fun noMoreFields (T s) = #more (Set.value s) := false
fun unify (T s, T s') =
let
val {fields = fs, more = m} = Set.value s
val {more = m', ...} = Set.value s'
val _ = Set.union (s, s')
val _ = Set.setValue (s, {fields = fs, more = ref (!m andalso !m')})
in
()
end
fun foldOverNew (spine: t, fs, ac, g) =
List.fold
(fields spine, ac, fn (f, ac) =>
if List.exists (fs, fn (f', _) => Field.equals (f, f'))
then ac
else g (f, ac))
end
val {get = tyvarTime: Tyvar.t -> Time.t ref, ...} =
Property.get (Tyvar.plist, Property.initFun (fn _ => ref (Time.now ())))
structure Type =
struct
(* Tuples of length <> 1 are always represented as records.
* There will never be tuples of length one.
*)
datatype t = T of {ty: ty,
plist: PropertyList.t} Set.t
and ty =
Con of Tycon.t * t vector
| FlexRecord of {fields: fields,
spine: Spine.t,
time: Time.t ref}
(* GenFlexRecord only appears in type schemes.
* It will never be unified.
* The fields that are filled in after generalization are stored in
* extra.
*)
| GenFlexRecord of genFlexRecord
| Int (* an unresolved int type *)
| Real (* an unresolved real type *)
| Record of t Srecord.t
| Unknown of Unknown.t
| Var of Tyvar.t
| Word (* an unresolved word type *)
withtype fields = (Field.t * t) list
and genFlexRecord =
{extra: unit -> {field: Field.t,
tyvar: Tyvar.t} list,
fields: (Field.t * t) list,
spine: Spine.t}
val freeFlexes: t list ref = ref []
val freeUnknowns: t list ref = ref []
local
fun make f (T s) = f (Set.value s)
in
val toType: t -> ty = make #ty
val plist: t -> PropertyList.t = make #plist
end
local
open Layout
in
fun layoutFields fs =
List.layout (Layout.tuple2 (Field.layout, layout)) fs
and layout ty =
case toType ty of
Con (c, ts) =>
paren (align [seq [str "Con ", Tycon.layout c],
Vector.layout layout ts])
| FlexRecord {fields, spine, time} =>
seq [str "Flex ",
record [("fields", layoutFields fields),
("spine", Spine.layout spine),
("time", Time.layout (!time))]]
| GenFlexRecord {fields, spine, ...} =>
seq [str "GenFlex ",
record [("fields", layoutFields fields),
("spine", Spine.layout spine)]]
| Int => str "Int"
| Real => str "Real"
| Record r => Srecord.layout {record = r,
separator = ": ",
extra = "",
layoutTuple = Vector.layout layout,
layoutElt = layout}
| Unknown u => Unknown.layout u
| Var a => paren (seq [str "Var ", Tyvar.layout a])
| Word => str "Word"
end
val toString = Layout.toString o layout
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,
record, recursive, unknown, var, word} =
let
datatype status = Processing | Seen | Unseen
val {destroy = destroyStatus, get = status, ...} =
Property.destGet (plist, Property.initFun (fn _ => ref Unseen))
val {get, destroy = destroyProp} =
Property.destGet
(plist,
Property.initRec
(fn (t, get) =>
let
val r = status t
in
case !r of
Seen => Error.bug "impossible"
| Processing => recursive t
| Unseen =>
let
val _ = r := Processing
fun loopFields fields =
List.revMap (fields, fn (f, t) => (f, get t))
val res =
case toType t of
Con (c, ts) =>
con (t, c, Vector.map (ts, get))
| Int => int t
| FlexRecord {fields, spine, time} =>
flexRecord (t, {fields = loopFields fields,
spine = spine,
time = time})
| GenFlexRecord {extra, fields, spine} =>
genFlexRecord
(t, {extra = extra,
fields = loopFields fields,
spine = spine})
| Real => real t
| Record r => record (t, Srecord.map (r, get))
| Unknown u => unknown (t, u)
| Var a => var (t, a)
| Word => word t
val _ = r := Seen
in
res
end
end))
fun destroy () =
(destroyStatus ()
; destroyProp ())
in
{hom = get, destroy = destroy}
end
fun hom (ty, z) =
let
val {hom, destroy} = makeHom z
in
hom ty before destroy ()
end
fun layoutPretty (t: t): Layout.t =
let
open Layout
fun recordType (l: (Layout.t * (bool * Layout.t)) list)
: bool * Layout.t =
(false,
seq [str "{",
mayAlign (separateRight
(List.map (l, fn (f, (_, t)) =>
seq [f, str ": ", t]),
",")),
str "}"])
fun maybeParen (b, t) = if b then paren t else t
fun con (_, c, ts) =
let
val c' = str (Tycon.originalName c)
fun t n = maybeParen (Vector.sub (ts, n))
in
case Vector.length ts of
0 => (false, c')
| 1 => (false, seq [t 0, str " ", c'])
| _ =>
if Tycon.equals (c, Tycon.arrow)
then (true, mayAlign [t 0, seq [str "-> ", t 1]])
else (true, seq [Vector.layout #2 ts,
str " ", c'])
end
fun int _ = (false, str "int")
fun flexRecord (_, {fields, spine, time}) =
recordType
(List.fold
(fields,
Spine.foldOverNew (spine, fields, [], fn (f, ac) =>
(Field.layout f, (false, str "unit"))
:: ac),
fn ((f, t), ac) => (Field.layout f, t) :: ac))
fun genFlexRecord (_, {extra, fields, spine}) =
recordType
(List.fold
(fields,
List.revMap (extra (), fn {field, tyvar} =>
(Field.layout field, (false, Tyvar.layout tyvar))),
fn ((f, t), ac) =>
(Field.layout f, t) :: ac))
fun real _ = (false, str "real")
fun record (_, r) =
(false,
Srecord.layout
{record = r,
separator = ": ",
extra = "",
layoutTuple = (fn ts =>
if 0 = Vector.length ts
then str "unit"
else
paren (seq (separate (Vector.toListMap
(ts, maybeParen),
" * ")))),
layoutElt = #2})
fun recursive _ = (false, str "<recur>")
fun unknown (_, u) = (false, str "???")
fun var (_, a) = (false, Tyvar.layout a)
fun word _ = (false, str "word")
in
#2 (hom (t, {con = con,
flexRecord = flexRecord,
genFlexRecord = genFlexRecord,
int = int,
real = real,
record = record,
recursive = recursive,
unknown = unknown,
var = var,
word = word}))
end
fun deConOpt t =
case toType t of
Con x => SOME x
| _ => NONE
fun newTy (ty: ty): t =
T (Set.singleton {ty = ty,
plist = PropertyList.new ()})
fun new z =
let
val t = newTy (Unknown (Unknown.new z))
val _ = List.push (freeUnknowns, t)
in
t
end
fun flexRecord record =
let
val v = Srecord.toVector record
val spine = Spine.new (Vector.toListMap (v, #1))
fun isResolved (): bool = not (Spine.canAddFields spine)
val t =
newTy (FlexRecord {fields = Vector.toList v,
spine = spine,
time = ref (Time.now ())})
val _ = List.push (freeFlexes, t)
in
(t, isResolved)
end
val record = newTy o Record
fun tuple ts =
if 1 = Vector.length ts
then Vector.sub (ts, 0)
else newTy (Record (Srecord.tuple ts))
fun con (tycon, ts) =
if Tycon.equals (tycon, Tycon.tuple) then tuple ts
else newTy (Con (tycon, ts))
val char = con (Tycon.char, Vector.new0 ())
val string = con (Tycon.vector, Vector.new1 char)
val var = newTy o Var
end
structure Ops = TypeOps (structure IntSize = IntSize
structure Tycon = Tycon
structure WordSize = WordSize
open Type)
local
open Layout
in
val unusual =
[(Tycon.arrow, "(_ -> _)")]
fun layoutTycon (c: Tycon.t, arity: int): Layout.t =
case List.peek (unusual, fn (c', _) => Tycon.equals (c, c')) of
NONE => if arity = 0
then Tycon.layout c
else seq [str "_ ", Tycon.layout c]
| SOME (_, s) => str s
val dontCare = str "_"
fun layoutRecord (ds: (Field.t * Layout.t) list) =
seq [str "{",
seq (separate
(List.map
(QuickSort.sortList (ds, fn ((f, _), (f', _)) =>
Field.<= (f, f')),
fn (f, l) => seq [Field.layout f, str " = ", l]),
", ")),
str ", ...}"]
fun layoutTuple (ls: Layout.t vector) =
paren (seq (separate (Vector.toList ls, " * ")))
fun layoutTopLevel t =
let
datatype z = datatype Type.ty
in
case t of
Con (c, ts) => layoutTycon (c, Vector.length ts)
| FlexRecord _ => str "{_}"
| GenFlexRecord _ => str "{_}"
| Int => str "int"
| Real => str "real"
| Record r =>
(case Srecord.detupleOpt r of
NONE => str "{_}"
| SOME ts => layoutTuple (Vector.map (ts, fn _ => dontCare)))
| Unknown _ => Error.bug "layoutTopLevel Unknown"
| Var a => Tyvar.layout a
| Word => str "word"
end
end
structure Type =
struct
(* Order is important, since want specialized definitions in Type to
* override general definitions in Ops.
*)
open Ops Type
val char = con (Tycon.char, Vector.new0 ())
val unit = tuple (Vector.new0 ())
fun isUnit t =
case toType t of
Record r =>
(case Srecord.detupleOpt r of
NONE => false
| SOME v => 0 = Vector.length v)
| _ => false
val equals: t * t -> bool = fn (T s, T s') => Set.equals (s, s')
local
fun make ty () = newTy ty
in
val unresolvedInt = make Int
val unresolvedReal = make Real
val unresolvedWord = make Word
end
val traceCanUnify =
Trace.trace2 ("canUnify", layout, layout, Bool.layout)
fun canUnify arg =
traceCanUnify
(fn (t, t') =>
case (toType t, toType t') of
(Unknown _, _) => true
| (_, Unknown _) => true
| (Con (c, ts), t') => conAnd (c, ts, t')
| (t', Con (c, ts)) => conAnd (c, ts, t')
| (Int, Int) => true
| (Real, Real) => true
| (Record r, Record r') =>
let
val fs = Srecord.toVector r
val fs' = Srecord.toVector r'
in Vector.length fs = Vector.length fs'
andalso Vector.forall2 (fs, fs', fn ((f, t), (f', t')) =>
Field.equals (f, f')
andalso canUnify (t, t'))
end
| (Var a, Var a') => Tyvar.equals (a, a')
| (Word, Word) => true
| _ => false) arg
and conAnd (c, ts, t') =
case t' of
Con (c', ts') =>
Tycon.equals (c, c')
andalso Vector.forall2 (ts, ts', canUnify)
| Int => 0 = Vector.length ts andalso Tycon.isIntX c
| Real => 0 = Vector.length ts andalso Tycon.isRealX c
| Word => 0 = Vector.length ts andalso Tycon.isWordX c
| _ => false
fun minTime (t, time) =
let
fun doit r = r := Time.min (!r, time)
fun var (_, a) = doit (tyvarTime a)
val {destroy, hom} =
makeHom
{con = fn _ => (),
flexRecord = fn (_, {time = r, ...}) => doit r,
genFlexRecord = fn _ => (),
int = fn _ => (),
real = fn _ => (),
record = fn _ => (),
recursive = fn _ => (),
unknown = fn (_, u) => Unknown.minTime (u, time),
var = var,
word = fn _ => ()}
val _ = hom t
val _ = destroy ()
in
()
end
structure UnifyResult =
struct
datatype t =
NotUnifiable of Layout.t * Layout.t
| Unified
val layout =
let
open Layout
in
fn NotUnifiable _ => str "NotUnifiable"
| Unified => str "Unified"
end
end
datatype unifyResult = datatype UnifyResult.t
val traceUnify = Trace.trace2 ("unify", layout, layout, UnifyResult.layout)
fun unify (t, t'): unifyResult =
let
fun unify arg =
traceUnify
(fn (outer as T s, outer' as T s') =>
if Set.equals (s, s')
then Unified
else
let
fun notUnifiable (l, l') =
(NotUnifiable (l, l'),
Unknown (Unknown.new {canGeneralize = true,
equality = true}))
fun oneFlex ({fields, spine, time}, r, outer) =
let
val _ = minTime (outer, !time)
val differences =
List.fold
(fields, ([], []), fn ((f, t), (ac, ac')) =>
case Srecord.peek (r, f) of
NONE => ((f, dontCare) :: ac, ac')
| SOME t' =>
case unify (t, t') of
NotUnifiable (l, l') =>
((f, l) :: ac, (f, l') :: ac')
| Unified => (ac, ac'))
val differences =
List.fold
(Spine.fields spine, differences,
fn (f, (ac, ac')) =>
case Srecord.peek (r, f) of
NONE => ((f, dontCare) :: ac, ac')
| SOME _ => (ac, ac'))
val differences =
Srecord.foldi
(r, differences, fn (f, t, (ac, ac')) =>
let
val ac' =
if Spine.ensureField (spine, f)
then ac'
else (f, dontCare) :: ac'
in
case List.peek (fields, fn (f', _) =>
Field.equals (f, f')) of
NONE => (ac, ac')
| SOME (_, t') =>
case unify (t, t') of
NotUnifiable (l, l') =>
((f, l') :: ac, (f, l) :: ac')
| Unified => (ac, ac')
end)
val _ = Spine.noMoreFields spine
in
case differences of
([], []) => (Unified, Record r)
| (ds, ds') =>
notUnifiable (layoutRecord ds,
layoutRecord ds')
end
fun genFlexError () =
Error.bug "GenFlexRecord seen in unify"
val {ty = t, plist} = Set.value s
val {ty = t', ...} = Set.value s'
fun not () =
notUnifiable (layoutTopLevel t, layoutTopLevel t')
fun conAnd (c, ts, t, t') =
let
fun lay () = layoutTycon (c, Vector.length ts)
in
case t of
Con (c', ts') =>
if Tycon.equals (c, c')
then
if Vector.length ts <> Vector.length ts'
then
let
fun lay ts =
Layout.seq
[Layout.str
(concat ["<",
Int.toString
(Vector.length ts),
" args> "]),
Tycon.layout c]
in
notUnifiable (lay ts, lay ts')
end
else
let
val us =
Vector.map2 (ts, ts', unify)
in
if Vector.forall
(us,
fn Unified => true
| _ => false)
then (Unified, t)
else
let
val (ls, ls') =
Vector.unzip
(Vector.map
(us,
fn Unified =>
(dontCare,
dontCare)
| NotUnifiable (l, l') =>
(l, l')))
fun lay ls =
let
open Layout
in
if Tycon.equals (c, Tycon.arrow)
then
paren
(seq [Vector.sub (ls, 0),
str " -> ",
Vector.sub (ls, 1)])
else
seq
[tuple
(Vector.toList ls),
str " ",
Tycon.layout c]
end
in
notUnifiable (lay ls,
lay ls')
end
end
else not ()
| Int =>
if Tycon.isIntX c andalso Vector.isEmpty ts
then (Unified, t')
else not ()
| Real =>
if Tycon.isRealX c andalso Vector.isEmpty ts
then (Unified, t')
else not ()
| Word =>
if Tycon.isWordX c andalso Vector.isEmpty ts
then (Unified, t')
else not ()
| _ => not ()
end
fun oneUnknown (u, t, outer) =
let
val _ = minTime (outer, Unknown.time u)
in
(Unified, t)
end
fun swap (res, t) =
case res of
NotUnifiable (l, l') => (NotUnifiable (l', l), t)
| Unified => (Unified, t)
val (res, t) =
case (t, t') of
(Unknown r, Unknown r') =>
(Unified, Unknown (Unknown.join (r, r')))
| (_, Unknown u) => oneUnknown (u, t, outer)
| (Unknown u, _) => oneUnknown (u, t', outer')
| (Con (c, ts), _) => conAnd (c, ts, t', t)
| (_, Con (c, ts)) => swap (conAnd (c, ts, t, t'))
| (FlexRecord f, Record r) => oneFlex (f, r, outer')
| (Record r, FlexRecord f) =>
swap (oneFlex (f, r, outer))
| (FlexRecord {fields = fields, spine = s, time = t},
FlexRecord {fields = fields', spine = s',
time = t', ...}) =>
let
fun subsetSpine (fields, spine, spine') =
List.fold
(Spine.fields spine, [], fn (f, ac) =>
if List.exists (fields, fn (f', _) =>
Field.equals (f, f'))
orelse Spine.ensureField (spine', f)
then ac
else (f, dontCare) :: ac)
val ac = subsetSpine (fields, s, s')
val ac' = subsetSpine (fields', s', s)
fun subset (fields, fields', spine', ac, ac') =
List.fold
(fields, (ac, ac'),
fn ((f, t), (ac, ac')) =>
case List.peek (fields', fn (f', _) =>
Field.equals (f, f')) of
NONE =>
if Spine.ensureField (spine', f)
then (ac, ac')
else ((f, dontCare) :: ac, ac')
| SOME (_, t') =>
case unify (t, t') of
NotUnifiable (l, l') =>
((f, l) :: ac, (f, l) :: ac')
| Unified => (ac, ac'))
val (ac, ac') =
subset (fields, fields', s', ac, ac')
val (ac, ac') =
subset (fields', fields, s, [], [])
val _ = Spine.unify (s, s')
val fields =
List.fold
(fields, fields', fn ((f, t), ac) =>
if List.exists (fields', fn (f', _) =>
Field.equals (f, f'))
then ac
else (f, t) :: ac)
in
case (ac, ac') of
([], []) =>
(Unified,
FlexRecord
{fields = fields,
spine = s,
time = ref (Time.min (!t, !t'))})
| _ =>
notUnifiable (layoutRecord ac,
layoutRecord ac')
end
| (GenFlexRecord _, _) => genFlexError ()
| (_, GenFlexRecord _) => genFlexError ()
| (Int, Int) => (Unified, Int)
| (Real, Real) => (Unified, Real)
| (Record r, Record r') =>
(case (Srecord.detupleOpt r,
Srecord.detupleOpt r') of
(NONE, NONE) =>
let
fun diffs (r, r', ac, ac') =
Vector.fold
(Srecord.toVector r, (ac, ac'),
fn ((f, t), (ac, ac')) =>
case Srecord.peek (r', f) of
NONE =>
((f, dontCare) :: ac, ac')
| SOME t' =>
case unify (t, t') of
NotUnifiable (l, l') =>
((f, l) :: ac,
(f, l') :: ac')
| Unified => (ac, ac'))
val (ac, ac') = diffs (r, r', [], [])
val (ac', ac) = diffs (r', r, ac', ac)
in
case (ac, ac') of
([], []) =>
(Unified, Record r)
| _ =>
notUnifiable (layoutRecord ac,
layoutRecord ac')
end
| (SOME ts, SOME ts') =>
if Vector.length ts = Vector.length ts'
then
let
val us =
Vector.map2 (ts, ts', unify)
in
if Vector.forall
(us,
fn Unified => true
| _ => false)
then (Unified, Record r)
else
let
val (ls, ls') =
Vector.unzip
(Vector.map
(us,
fn Unified =>
(dontCare,
dontCare)
| NotUnifiable (l, l') =>
(l, l')))
in
notUnifiable
(layoutTuple ls,
layoutTuple ls')
end
end
else not ()
| _ => not ())
| (Var a, Var a') =>
if Tyvar.equals (a, a')
then (Unified, t)
else not ()
| (Word, Word) => (Unified, Word)
| _ => not ()
val _ = Set.union (s, s')
val _ = Set.setValue (s, {ty = t, plist = plist})
in
res
end) arg
in
unify (t, t')
end
val word8 = word WordSize.W8
fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
record: t * (Field.t * 'a) vector -> 'a,
var: t * Tyvar.t -> 'a} =
let
val con =
fn (t, c, ts) =>
if 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 ())
val unknown = unit
fun sortFields (fields: (Field.t * 'a) list) =
Array.toVector
(QuickSort.sortArray
(Array.fromList fields, fn ((f, _), (f', _)) =>
Field.<= (f, f')))
fun unsorted (t, fields: (Field.t * 'a) list) =
let
val v = sortFields fields
in
record (t, v)
end
fun genFlexRecord (t, {extra, fields, spine}) =
unsorted (t,
List.fold
(extra (), fields, fn ({field, tyvar}, ac) =>
(field, var (Type.var tyvar, tyvar)) :: ac))
fun flexRecord (t, {fields, spine, time}) =
if Spine.canAddFields spine
then Error.bug "Type.hom flexRecord"
else unsorted (t,
Spine.foldOverNew
(spine, fields, fields, fn (f, ac) =>
(f, unit) :: ac))
fun recursive t = Error.bug "Type.hom recursive"
val int =
con (int IntSize.default, Tycon.defaultInt, Vector.new0 ())
val real =
con (real RealSize.default, Tycon.defaultReal, Vector.new0 ())
val word =
con (word WordSize.default, Tycon.defaultWord, Vector.new0 ())
val {hom: t -> 'a, ...} =
makeHom {con = con,
int = fn _ => int,
flexRecord = flexRecord,
genFlexRecord = genFlexRecord,
real = fn _ => real,
record = fn (t, r) => record (t, Srecord.toVector r),
recursive = recursive,
unknown = fn _ => unknown,
var = var,
word = fn _ => word}
in
hom
end
end
structure InferScheme =
struct
datatype t =
General of {bound: unit -> Tyvar.t vector,
canGeneralize: bool,
flexes: Type.genFlexRecord list,
tyvars: Tyvar.t vector,
ty: Type.t}
| Type of Type.t
fun layout s =
case s of
Type t => Type.layout t
| General {canGeneralize, tyvars, ty, ...} =>
Layout.record [("canGeneralize", Bool.layout canGeneralize),
("tyvars", Vector.layout Tyvar.layout tyvars),
("ty", Type.layout ty)]
fun layoutPretty s =
case s of
Type t => Type.layoutPretty t
| General {ty, ...} => Type.layoutPretty ty
val tyvars =
fn General {tyvars, ...} => tyvars
| Type _ => Vector.new0 ()
val bound =
fn General {bound, ...} => bound ()
| Type _ => Vector.new0 ()
val bound =
Trace.trace ("Scheme.bound", layout, Vector.layout Tyvar.layout)
bound
val ty =
fn General {ty, ...} => ty
| Type ty => ty
fun make {canGeneralize, tyvars, ty} =
if 0 = Vector.length tyvars
then Type ty
else General {bound = fn () => tyvars,
canGeneralize = canGeneralize,
flexes = [],
tyvars = tyvars,
ty = ty}
val fromType = Type
fun instantiate (t: t, subst) =
case t of
Type ty => {args = fn () => Vector.new0 (),
instance = ty}
| General {canGeneralize, flexes, tyvars, ty, ...} =>
let
open Type
val {destroy = destroyTyvarInst,
get = tyvarInst: Tyvar.t -> Type.t option,
set = setTyvarInst} =
Property.destGetSetOnce (Tyvar.plist,
Property.initConst NONE)
val types =
Vector.mapi
(tyvars, fn (i, a) =>
let
val t = subst {canGeneralize = canGeneralize,
equality = Tyvar.isEquality a,
index = i}
val _ = setTyvarInst (a, SOME t)
in
t
end)
type z = {isNew: bool, ty: Type.t}
fun isNew {isNew = b, ty} = b
fun keep ty = {isNew = false, ty = ty}
fun con (ty, c, zs) =
if Vector.exists (zs, isNew)
then {isNew = true,
ty = newTy (Con (c, Vector.map (zs, #ty)))}
else keep ty
val flexInsts = ref []
fun genFlexRecord (t, {extra, fields, spine}) =
let
val fields = List.revMap (fields, fn (f, t: z) =>
(f, #ty t))
val flex = newTy (FlexRecord {fields = fields,
spine = spine,
time = ref (Time.now ())})
val _ = List.push (flexInsts, {spine = spine,
flex = flex})
in
{isNew = true,
ty = flex}
end
fun record (t, r) =
if Srecord.exists (r, isNew)
then {isNew = true,
ty = newTy (Record (Srecord.map (r, #ty)))}
else keep t
fun recursive t =
if true
then Error.bug "instantiating recursive type"
else
{isNew = true,
ty = new {canGeneralize = true,
equality = true}}
fun var (ty, a) =
case tyvarInst a of
NONE => {isNew = false, ty = ty}
| SOME ty => {isNew = true, ty = ty}
val {ty: Type.t, ...} =
Type.hom (ty, {con = con,
int = keep,
flexRecord = keep o #1,
genFlexRecord = genFlexRecord,
real = keep,
record = record,
recursive = recursive,
unknown = keep o #1,
var = var,
word = keep})
val _ = destroyTyvarInst ()
val flexInsts = !flexInsts
fun args (): Type.t vector =
Vector.fromList
(List.fold
(flexes, Vector.toList types,
fn ({fields, spine, ...}, ac) =>
let
val flex =
case List.peek (flexInsts,
fn {spine = spine', ...} =>
Spine.equals (spine, spine')) of
NONE => Error.bug "missing flexInst"
| SOME {flex, ...} => flex
fun peekFields (fields, f) =
Option.map
(List.peek (fields, fn (f', _) =>
Field.equals (f, f')),
#2)
val peek =
case Type.toType flex of
FlexRecord {fields, ...} =>
(fn f => peekFields (fields, f))
| GenFlexRecord {extra, fields, ...} =>
(fn f =>
case peekFields (fields, f) of
NONE =>
Option.map
(List.peek
(extra (), fn {field, ...} =>
Field.equals (f, field)),
Type.var o #tyvar)
| SOME t => SOME t)
| Record r => (fn f => Srecord.peek (r, f))
| _ => Error.bug "strange flexInst"
in
Spine.foldOverNew
(spine, fields, ac, fn (f, ac) =>
(case peek f of
NONE => Type.unit
| SOME t => t) :: ac)
end))
in
{args = args,
instance = ty}
end
fun apply (s, ts) =
#instance (instantiate (s, fn {index, ...} => Vector.sub (ts, index)))
val instantiate =
fn s =>
instantiate (s, fn {canGeneralize, equality, ...} =>
Type.new {canGeneralize = canGeneralize,
equality = equality})
val instantiate =
Trace.trace ("Scheme.instantiate", layout, Type.layout o #instance)
instantiate
fun haveFrees (v: t vector): bool vector =
let
exception Yes
val {destroy, hom} =
Type.makeHom {con = fn _ => (),
flexRecord = fn _ => (),
genFlexRecord = fn _ => (),
int = fn _ => (),
real = fn _ => (),
record = fn _ => (),
recursive = fn _ => (),
unknown = fn _ => raise Yes,
var = fn _ => (),
word = fn _ => ()}
val res =
Vector.map (v, fn s =>
let
val _ =
case s of
General {ty, ...} => hom ty
| Type ty => hom ty
in
false
end handle Yes => true)
val _ = destroy ()
in
res
end
end
fun close (ensure: Tyvar.t vector, region)
: Type.t vector -> {bound: unit -> Tyvar.t vector,
schemes: InferScheme.t vector} =
let
val genTime = Time.tick ()
val _ = Vector.foreach (ensure, fn a => (tyvarTime a; ()))
in
fn tys =>
let
val unable =
Vector.keepAll (ensure, fn a =>
not (Time.<= (genTime, !(tyvarTime a))))
val _ =
if Vector.length unable > 0
then
let
open Layout
in
Control.error
(region,
seq [str "unable to generalize ",
seq (List.separate (Vector.toListMap (unable,
Tyvar.layout),
str ", "))],
empty)
end
else ()
(* Convert all the unknown types bound at this level into tyvars. *)
val (tyvars, ac) =
List.fold
(!Type.freeUnknowns, (Vector.toList ensure, []),
fn (t, (tyvars, ac)) =>
case Type.toType t of
Type.Unknown (Unknown.T {canGeneralize, equality, time, ...}) =>
if canGeneralize andalso Time.<= (genTime, !time)
then
let
val a = Tyvar.newNoname {equality = equality}
val _ = Type.set (t, {ty = Type.Var a,
plist = PropertyList.new ()})
in
(a :: tyvars, ac)
end
else (tyvars, t :: ac)
| _ => (tyvars, ac))
val _ = Type.freeUnknowns := ac
(* Convert all the FlexRecords bound at this level into GenFlexRecords.
*)
val (flexes, ac) =
List.fold
(!Type.freeFlexes, ([], []), fn (t as Type.T s, (flexes, ac)) =>
let
val {ty, plist} = Set.value s
in
case ty of
Type.FlexRecord {fields, spine, time, ...} =>
if Time.<= (genTime, !time)
then
let
val extra =
Promise.lazy
(fn () =>
Spine.foldOverNew
(spine, fields, [], fn (f, ac) =>
{field = f,
tyvar = Tyvar.newNoname {equality = false}}
:: ac))
val gfr = {extra = extra,
fields = fields,
spine = spine}
val _ =
Set.setValue
(s, {plist = plist,
ty = Type.GenFlexRecord gfr})
in
(gfr :: flexes, ac)
end
else (flexes, t :: ac)
| _ => (flexes, ac)
end)
val _ = Type.freeFlexes := ac
(* For all fields that were added to the generalized flex records, add
* a type variable.
*)
fun bound () =
Vector.fromList
(List.fold
(flexes, tyvars, fn ({extra, fields, spine}, ac) =>
let
val extra = extra ()
in
Spine.foldOverNew
(spine, fields, ac, fn (f, ac) =>
case List.peek (extra, fn {field, ...} =>
Field.equals (f, field)) of
NONE => Error.bug "GenFlex missing field"
| SOME {tyvar, ...} => tyvar :: ac)
end))
val schemes =
Vector.map
(tys, fn ty =>
InferScheme.General {bound = bound,
canGeneralize = true,
flexes = flexes,
tyvars = Vector.fromList tyvars,
ty = ty})
in
{bound = bound,
schemes = schemes}
end
end
fun closeTop (r: Region.t): unit =
let
val _ =
List.foreach
(!Type.freeUnknowns, fn t =>
case Type.toType t of
Type.Unknown _ => (Type.unify (t, Type.unit)
; ())
| _ => ())
val _ = Type.freeUnknowns := []
val _ = List.foreach (!Type.freeFlexes, fn t =>
case Type.toType t of
Type.FlexRecord _ => Error.bug "free flex\n"
| _ => ())
val _ = Type.freeFlexes := []
in
()
end
structure Type =
struct
open Type
fun homConVar {con, var} =
let
fun tuple (t, ts) =
if 1 = Vector.length ts
then Vector.sub (ts, 0)
else con (t, Tycon.tuple, ts)
in
simpleHom {con = con,
record = fn (t, fs) => tuple (t, Vector.map (fs, #2)),
var = var}
end
fun hom {con, var} =
homConVar {con = fn (_, c, ts) => con (c, ts),
var = fn (_, a) => var a}
fun deRecord t =
let
val hom =
simpleHom
{con = fn (t, _, _) => (t, NONE),
record = fn (t, fs) => (t,
SOME (Vector.map (fs, fn (f, (t, _)) =>
(f, t)))),
var = fn (t, _) => (t, NONE)}
in
case #2 (hom t) of
NONE => Error.bug "Type.deRecord"
| SOME fs => fs
end
fun deTupleOpt t =
let
val hom =
homConVar
{con = fn (t, c, ts) => (t,
if Tycon.equals (c, Tycon.tuple)
then SOME (Vector.map (ts, #1))
else NONE),
var = fn (t, _) => (t, NONE)}
in
#2 (hom t)
end
val deTupleOpt =
Trace.trace ("Type.deTupleOpt", layout,
Option.layout (Vector.layout layout))
deTupleOpt
val deTuple = valOf o deTupleOpt
end
end
1.1 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
type int = Int.t
signature TYPE_ENV_STRUCTS =
sig
include ATOMS
end
signature TYPE_ENV =
sig
include TYPE_ENV_STRUCTS
structure Type:
sig
include TYPE_OPS
(* can two types be unified? not side-effecting. *)
val canUnify: t * t -> bool
val char: t
val deRecord: t -> (Record.Field.t * t) vector
val flexRecord: t SortedRecord.t -> t * (unit -> bool)
val hom: {con: Tycon.t * 'a vector -> 'a,
var: Tyvar.t -> 'a} -> t -> 'a
val isUnit: t -> bool
val layout: t -> Layout.t
val layoutPretty: t -> Layout.t
val new: {canGeneralize: bool, equality: bool} -> t
val record: t SortedRecord.t -> t
val string: t
val toString: t -> string
(* make two types identical (recursively). side-effecting. *)
datatype unifyResult =
NotUnifiable of Layout.t * Layout.t
| Unified
val unify: t * t -> unifyResult
val unresolvedInt: unit -> t
val unresolvedReal: unit -> t
val unresolvedWord: unit -> t
val var: Tyvar.t -> t
end
sharing type Type.intSize = IntSize.t
sharing type Type.realSize = RealSize.t
sharing type Type.wordSize = WordSize.t
sharing type Type.tycon = Tycon.t
structure InferScheme:
sig
type t
val apply: t * Type.t vector -> Type.t
val fromType: Type.t -> t
val haveFrees: t vector -> bool vector
val instantiate: t -> {args: unit -> Type.t vector,
instance: Type.t}
val layout: t -> Layout.t
val layoutPretty: t -> Layout.t
val make: {canGeneralize: bool,
ty: Type.t,
tyvars: Tyvar.t vector} -> t
val ty: t -> Type.t
end
(* close (e, t, ts, r) = {bound, scheme} close type
* t with respect to environment e, including all the tyvars in ts
* and ensuring than no tyvar in ts occurs free in e. bound returns
* the vector of type variables in t that do not occur in e, which
* isn't known until all flexible record fields are determined,
* after unification is complete.
*)
val close:
Tyvar.t vector * Region.t
-> Type.t vector
-> {bound: unit -> Tyvar.t vector,
schemes: InferScheme.t vector}
val closeTop: Region.t -> unit
end
signature INFER_TYPE_ENV = TYPE_ENV
1.13 +25 -23 mlton/mlton/front-end/ml.grm
Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- ml.grm 12 Sep 2003 01:22:56 -0000 1.12
+++ ml.grm 9 Oct 2003 18:17:33 -0000 1.13
@@ -1,4 +1,4 @@
-(* Heavily modified from SML/NJ sources by sweeks@research.nj.nec.com *)
+(* Heavily modified from SML/NJ sources by sweeks@sweeks.com *)
(* ml.grm
*
@@ -136,8 +136,7 @@
type clause = {pats : Pat.t vector,
resultType : Type.t option,
body : Exp.t}
-type clauses = {clauses: clause vector,
- filePos: string}
+type clauses = clause vector
type eb = Con.t * EbRhs.t
type db = {tyvars: Tyvar.t vector,
tycon: Tycon.t,
@@ -172,8 +171,7 @@
body : Strexp.t}
type vb = {pat: Pat.t,
- exp: Exp.t,
- filePos: string}
+ exp: Exp.t}
type rvb = {pat: Pat.t,
match: Match.t}
@@ -701,18 +699,23 @@
| fixity vids (Dec.Fix {fixity = fixity,
ops = Vector.fromList vids})
| OVERLOAD var COLON ty AS longvarands
- (Dec.Overload (var, ty,
+ (Dec.Overload (var,
+ Vector.new0 (),
+ ty,
Vector.fromList longvarands))
-valbindTop : valbind (let val (vbs, rvbs) = valbind
- in (Vector.fromList vbs,
+valbindTop : valbind (let
+ val (vbs, rvbs) = valbind
+ in
+ (Vector.fromList vbs,
Vector.fromList rvbs)
end)
valbind : pat EQUALOP exp valbindRest
- (let val (vbs, rvbs) = valbindRest
- in ({pat = pat, exp = exp, filePos = SourcePos.toString pat1left}
- :: vbs,
+ (let
+ val (vbs, rvbs) = valbindRest
+ in
+ ({pat = pat, exp = exp} :: vbs,
rvbs)
end)
| REC rvalbind (([], rvalbind))
@@ -734,8 +737,7 @@
funs : clausesTop ([clausesTop])
| clausesTop AND funs (clausesTop :: funs)
-clausesTop: clauses ({clauses = Vector.fromList clauses,
- filePos = SourcePos.toString clauses1left})
+clausesTop: clauses (Vector.fromList clauses)
clauses : clause ([clause])
| clause BAR clauses (clause :: clauses)
@@ -849,8 +851,8 @@
longvarands : longvar ([longvar])
| longvar AND longvarands (longvar :: longvarands)
-match : rules (Match.T {rules = Vector.fromList rules,
- filePos = SourcePos.toString rules1left})
+match : rules (Match.makeRegion' (Match.T (Vector.fromList rules),
+ rulesleft, rulesright))
rules : rule ([rule])
| rule BAR rules (rule :: rules)
@@ -862,7 +864,7 @@
elabels : elabel COMMA elabels (elabel :: elabels)
| elabel ([elabel])
-exp_ps : exp ([exp])
+exp_ps : exp SEMICOLON exp ([exp1, exp2])
| exp SEMICOLON exp_ps (exp :: exp_ps)
exp : expnode (Exp.makeRegion' (expnode, expnodeleft, expnoderight))
@@ -876,9 +878,7 @@
| CASE exp OF match (Exp.Case (exp, match))
| WHILE exp DO exp (Exp.While {test = exp1, expr = exp2})
| IF exp THEN exp ELSE exp (Exp.If (exp1, exp2, exp3))
- | RAISE exp (Exp.Raise
- {exn = exp,
- filePos = SourcePos.toString exp1left})
+ | RAISE exp (Exp.Raise exp)
app_exp : aexp app_exp1 (Exp.makeRegion' (aexp, aexpleft, aexpright)
:: app_exp1)
@@ -898,10 +898,12 @@
(Exp.Record (Record.fromVector (Vector.fromList elabels)))
| LBRACE RBRACE (Exp.unit)
| LPAREN RPAREN (Exp.unit)
+ | LPAREN expnode RPAREN (expnode)
| LPAREN exp_ps RPAREN (Exp.Seq (Vector.fromList exp_ps))
| LPAREN exp_2c RPAREN (Exp.tuple (Vector.fromList exp_2c))
- | LBRACKET exp_list RBRACKET (Exp.List exp_list)
- | LBRACKET RBRACKET (Exp.List nil)
+ | LBRACKET exp_list RBRACKET (Exp.List (Vector.fromList exp_list))
+ | LBRACKET RBRACKET (Exp.List (Vector.new0 ()))
+ | LET decs IN exp END (Exp.Let (decs, exp))
| LET decs IN exp_ps END
(Exp.Let (decs, Exp.makeRegion' (Exp.Seq (Vector.fromList exp_ps),
exp_psleft,
@@ -956,12 +958,12 @@
apatnode : longvidNoEqual (Pat.Var {name = longvidNoEqual,
fixop = Fixop.None})
- | OP vidNoEqual (Pat.Var {name = Longvid.short vidNoEqual,
+ | OP vid (Pat.Var {name = Longvid.short vid,
fixop = Fixop.Op})
| const (Pat.Const const)
| WILD (Pat.Wild)
| LPAREN pats RPAREN (Pat.tuple (Vector.fromList pats))
- | LBRACKET pats RBRACKET (Pat.List pats)
+ | LBRACKET pats RBRACKET (Pat.List (Vector.fromList pats))
| LBRACE RBRACE (Pat.unit)
| LBRACE patitems RBRACE (let val (items, f) = patitems
in Pat.Record {items = Vector.fromList items,
1.9 +8 -0 mlton/mlton/main/compile.sig
Index: compile.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- compile.sig 16 Aug 2003 21:29:18 -0000 1.8
+++ compile.sig 9 Oct 2003 18:17:33 -0000 1.9
@@ -5,8 +5,16 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+type int = Int.t
+
+signature COMPILE_STRUCTS =
+ sig
+ end
+
signature COMPILE =
sig
+ include COMPILE_STRUCTS
+
val compile: {input: File.t list,
outputC: unit -> {file: File.t,
print: string -> unit,
1.4 +11 -0 mlton/mlton/main/main.sig
Index: main.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- main.sig 10 Apr 2002 07:02:20 -0000 1.3
+++ main.sig 9 Oct 2003 18:17:33 -0000 1.4
@@ -5,9 +5,20 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+
+type int = Int.t
+
+signature MAIN_STRUCTS =
+ sig
+ end
+
signature MAIN =
sig
+ include MAIN_STRUCTS
+
val commandLine: string list -> OS.Process.status
val exportMLton: unit -> unit
val exportNJ: Dir.t * File.t -> unit
+
+ val doit: unit -> unit
end
1.157 +1 -780 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.156
retrieving revision 1.157
diff -u -r1.156 -r1.157
--- main.sml 29 Aug 2003 00:25:21 -0000 1.156
+++ main.sml 9 Oct 2003 18:17:33 -0000 1.157
@@ -1,780 +1 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-1999 NEC Research Institute.
- *
- * MLton is released under the GNU General Public License (GPL).
- * Please see the file MLton-LICENSE for license information.
- *)
-structure Main: MAIN =
-struct
-
-type int = Int.t
-
-structure Place =
- struct
- datatype t = CM | Files | Generated | O | OUT | SML
-
- val toInt: t -> int =
- fn CM => 0
- | Files => 1
- | SML => 2
- | Generated => 3
- | O => 4
- | OUT => 5
-
- val toString =
- fn CM => "cm"
- | Files => "files"
- | SML => "sml"
- | Generated => "g"
- | O => "o"
- | OUT => "out"
-
- val layout = Layout.str o toString
-
- fun compare (p, p') = Int.compare (toInt p, toInt p')
- end
-
-structure OptPred =
- struct
- datatype t =
- Target of string
- | Yes
- end
-
-val buildConstants: bool ref = ref false
-val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
-val coalesce: int option ref = ref NONE
-val expert: bool ref = ref false
-val gcc: string ref = ref "<unset>"
-val keepGenerated = ref false
-val keepO = ref false
-val keepSML = ref false
-val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
-val output: string option ref = ref NONE
-val profileSet: bool ref = ref false
-val runtimeArgs: string list ref = ref ["@MLton"]
-val showBasis: bool ref = ref false
-val stop = ref Place.OUT
-
-val targetMap: unit -> {arch: MLton.Platform.Arch.t,
- os: MLton.Platform.OS.t,
- target: string} list =
- Promise.lazy
- (fn () =>
- List.map
- (File.lines (concat [!Control.libDir, "/target-map"]), fn line =>
- case String.tokens (line, Char.isSpace) of
- [target, arch, os] =>
- let
- val arch =
- case MLton.Platform.Arch.fromString arch of
- NONE => Error.bug (concat ["strange arch: ", arch])
- | SOME a => a
- val os =
- case MLton.Platform.OS.fromString os of
- NONE => Error.bug (concat ["strange os: ", os])
- | SOME os => os
- in
- {arch = arch, os = os, target = target}
- end
- | _ => Error.bug (concat ["strange target mapping: ", line])))
-
-fun setTargetType (target: string, usage): unit =
- case List.peek (targetMap (), fn {target = t, ...} => t = target) of
- NONE => usage (concat ["invalid target ", target])
- | SOME {arch, os, ...} =>
- let
- datatype z = datatype MLton.Platform.Arch.t
- open Control
- in
- targetArch := arch
- ; targetOS := os
- ; (case arch of
- Sparc =>
- (align := Align8
- ; Native.native := false)
- | _ => ())
- end
-
-fun makeOptions {usage} =
- let
- val usage = fn s => (usage s; raise Fail "unreachable")
- open Control Popt
- fun push r = SpaceString (fn s => List.push (r, s))
- datatype z = datatype MLton.Platform.Arch.t
- in
- List.map
- (
- [
- (Normal, "align",
- case !targetArch of
- Sparc => " {8|4}"
- | X86 => " {4|8}",
- "object alignment",
- (SpaceString (fn s =>
- align
- := (case s of
- "4" => Align4
- | "8" => Align8
- | _ => usage (concat ["invalid -align flag: ",
- s]))))),
- (Normal, "basis", " {2002|1997|...}",
- "select basis library to prefix to the program",
- SpaceString (fn s =>
- let
- val s' = concat ["basis-", s]
- in
- if List.contains (basisLibs, s', String.equals)
- then basisLibrary := s'
- else usage (concat ["invalid -basis flag: ", s])
- end)),
- (Expert, "build-constants", " {false|true}",
- "output C file that prints basis constants",
- boolRef buildConstants),
- (Expert, "card-size-log2", " <n>",
- "log (base 2) of card size used by GC",
- intRef cardSizeLog2),
- (Expert, "cc", " <gcc>", "path to gcc executable",
- SpaceString (fn s => gcc := s)),
- (Normal, "cc-opt", " <opt>", "pass option to C compiler",
- SpaceString (fn s =>
- List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
- (Expert, "coalesce", " <n>", "coalesce chunk size for C codegen",
- Int (fn n => coalesce := SOME n)),
- (Expert, "debug", " {false|true}", "produce executable with debug info",
- boolRef debug),
- (Normal, "detect-overflow", " {true|false}",
- "overflow checking on integer arithmetic",
- boolRef detectOverflow),
- (Expert, "diag-pass", " <pass>", "keep diagnostic info for pass",
- SpaceString (fn s =>
- (case Regexp.fromString s of
- SOME (re,_) => let val re = Regexp.compileDFA re
- in
- List.push (keepDiagnostics, re)
- ; List.push (keepPasses, re)
- end
- | NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
- (Expert, "drop-pass", " <pass>", "omit optimization pass",
- SpaceString
- (fn s => (case Regexp.fromString s of
- SOME (re,_) => let val re = Regexp.compileDFA re
- in List.push (dropPasses, re)
- end
- | NONE => usage (concat ["invalid -drop-pass flag: ", s])))),
- (Expert, "eliminate-overflow", " {true|false}",
- "eliminate useless overflow tests",
- boolRef eliminateOverflow),
- (Normal, "exn-history", " {false|true}",
- "enable Exn.history",
- boolRef exnHistory),
- (Expert, "expert", " {false|true}",
- "enable expert status",
- boolRef expert),
- (Normal, "export-header", " {false|true}",
- "output header file for _export's",
- boolRef exportHeader),
- (Expert, "gc-check", " {limit|first|every}", "force GCs",
- SpaceString (fn s =>
- gcCheck :=
- (case s of
- "limit" => Limit
- | "first" => First
- | "every" => Every
- | _ => usage (concat ["invalid -gc-check flag: ", s])))),
- (Expert, "handlers", " {flow|pushpop|simple}",
- "how to implement handlers",
- SpaceString (fn s =>
- case s of
- "flow" => handlers := Flow
- | "simple" => handlers := Simple
- | _ => usage (concat ["invalid -handlers flag: ", s]))),
- (Normal, "ieee-fp", " {false|true}", "use strict IEEE floating-point",
- boolRef Native.IEEEFP),
- (Expert, "indentation", " <n>", "indentation level in ILs",
- intRef indentation),
- (Normal, "inline", " <n>", "inlining threshold", Int setInlineSize),
- (Normal, "keep", " {g|o|sml}", "save intermediate files",
- SpaceString (fn s =>
- case s of
- "dot" => keepDot := true
- | "g" => keepGenerated := true
- | "machine" => keepMachine := true
- | "o" => keepO := true
- | "sml" => keepSML := true
- | "rssa" => keepRSSA := true
- | "ssa" => keepSSA := true
- | _ => usage (concat ["invalid -keep flag: ", s]))),
- (Expert, "keep-pass", " <pass>", "keep the results of pass",
- SpaceString
- (fn s => (case Regexp.fromString s of
- SOME (re,_) => let val re = Regexp.compileDFA re
- in List.push (keepPasses, re)
- end
- | NONE => usage (concat ["invalid -keep-pass flag: ", s])))),
- (Expert, "limit-check", " {lhle|pb|ebb|lh|lhf|lhfle}",
- "limit check insertion algorithm",
- SpaceString (fn s =>
- case s of
- "pb" => limitCheck := PerBlock
- | "ebb" => limitCheck := ExtBasicBlocks
- | "lh" => limitCheck := LoopHeaders {fullCFG = false,
- loopExits = false}
- | "lhf" => limitCheck := LoopHeaders {fullCFG = true,
- loopExits = false}
- | "lhle" => limitCheck := LoopHeaders {fullCFG = false,
- loopExits = true}
- | "lhfle" => limitCheck := LoopHeaders {fullCFG = true,
- loopExits = true}
- | _ => usage (concat ["invalid -limit-check flag: ", s]))),
- (Expert, "limit-check-counts", " {false|true}",
- "compute dynamic counts of limit checks",
- boolRef limitCheckCounts),
- (Normal, "link-opt", " <opt>", "pass option to linker",
- SpaceString (fn s =>
- List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
- (Expert, "loop-passes", " <n>", "loop optimization passes (1)",
- Int
- (fn i =>
- if i >= 1
- then loopPasses := i
- else usage (concat ["invalid -loop-passes arg: ", Int.toString i]))),
- (Expert, "mark-cards", " {true|false}", "mutator marks cards",
- boolRef markCards),
- (Normal, "native",
- if !targetArch = Sparc then " {false}" else " {true|false}",
- "use native code generator",
- boolRef Native.native),
- (Expert, "native-commented", " <n>", "level of comments (0)",
- intRef Native.commented),
- (Expert, "native-copy-prop", " {true|false}",
- "use copy propagation",
- boolRef Native.copyProp),
- (Expert, "native-cutoff", " <n>",
- "live transfer cutoff distance",
- intRef Native.cutoff),
- (Expert, "native-live-transfer", " {0,...,8}",
- "use live transfer",
- intRef Native.liveTransfer),
- (Expert, "native-live-stack", " {false|true}",
- "track liveness of stack slots",
- boolRef Native.liveStack),
- (Expert, "native-move-hoist", " {true|false}",
- "use move hoisting",
- boolRef Native.moveHoist),
- (Expert, "native-optimize", " <n>", "level of optimizations",
- intRef Native.optimize),
- (Expert, "native-split", " <n>", "split assembly files at ~n lines",
- Int (fn i => Native.split := SOME i)),
- (Expert, "native-shuffle", " {true|false}",
- "shuffle registers at C-calls",
- Bool (fn b => Native.shuffle := b)),
- (Expert, "new-return", " {false|true}", "non-tail call return convention",
- boolRef newReturn),
- (Expert, "polyvariance", " {true|false}", "use polyvariance",
- Bool (fn b => if b then () else polyvariance := NONE)),
- (Normal, "output", " <file>", "name of output file",
- SpaceString (fn s => output := SOME s)),
- (Normal, "profile", " {no|alloc|time}",
- "produce executable suitable for profiling",
- SpaceString
- (fn s =>
- if !profileSet
- then usage "can't have multiple -profile switches"
- else
- (profileSet := true
- ; profile := (case s of
- "no" => ProfileNone
- | "alloc" => ProfileAlloc
- | "time" => ProfileTime
- | _ => usage (concat
- ["invalid -profile arg: ", s]))))),
- (Expert, "profile-basis", " {false|true}",
- "profile the basis implementation",
- boolRef profileBasis),
- (Expert, "profile-il", " {source}", "where to insert profile exps",
- SpaceString
- (fn s =>
- case s of
- "source" => profileIL := ProfileSource
- | _ => usage (concat ["invalid -profile-il arg: ", s]))),
- (Normal, "profile-stack", " {false|true}", "profile the stack",
- boolRef profileStack),
- (Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
- push runtimeArgs),
- (Normal, "safe", " {true|false}", "bounds checking and other checks",
- boolRef safe),
- (Normal, "show-basis", " {false|true}", "display the basis library",
- boolRef showBasis),
- (Normal, "show-basis-used", " {false|true}",
- "display the basis library used by the program",
- boolRef showBasisUsed),
- (Expert, "show-types", " {false|true}", "print types in ILs",
- boolRef showTypes),
- (Expert, "stack-cont", " {false|true}",
- "force continuation formals to stack",
- boolRef stackCont),
- (Normal, "static", " {false|true}",
- "produce a statically linked executable",
- boolRef static),
- (Normal, "stop", " {f|g|o|sml}", "where to stop",
- SpaceString
- (fn s =>
- stop := (case s of
- "f" => Place.Files
- | "g" => Place.Generated
- | "o" => Place.O
- | "sml" => Place.SML
- | _ => usage (concat ["invalid -stop arg: ", s])))),
- (Normal, "target",
- concat [" {",
- concat (List.separate (List.map (targetMap (), #target), "|")),
- "}"],
- "platform that executable will run on",
- SpaceString (fn s =>
- (setTargetType (s, usage)
- ; target := (if s = "self" then Self else Cross s)))),
- (Expert, "target-cc-opt", " <target> <opt>", "target-dependent CC option",
- (SpaceString2
- (fn (target, opt) =>
- List.push (ccOpts, {opt = opt, pred = OptPred.Target target})))),
- (Expert, "target-link-opt", " <target> <opt>",
- "target-dependent link option",
- (SpaceString2
- (fn (target, opt) =>
- List.push (linkOpts, {opt = opt, pred = OptPred.Target target})))),
- (Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
- (Expert, "text-io-buf-size", " <n>", "TextIO buffer size",
- intRef textIOBufSize),
- (Expert, "type-check", " {false|true}", "type check ILs",
- boolRef typeCheck),
- (Normal, "verbose", " {0|1|2|3}", "how verbose to be",
- SpaceString
- (fn s =>
- verbosity := (case s of
- "0" => Silent
- | "1" => Top
- | "2" => Pass
- | "3" => Detail
- | _ => usage (concat ["invalid -verbose arg: ", s])))),
- (Expert, "variant", " {header|first-word}",
- "how to represent variant tags",
- SpaceString
- (fn s =>
- variant := (case s of
- "first-word" => FirstWord
- | "header" => Header
- | _ => usage (concat ["invalid -variant arg: ", s]))))
- ],
- fn (style, name, arg, desc, opt) =>
- {arg = arg, desc = desc, name = name, opt = opt, style = style})
- end
-
-val mainUsage =
- "mlton [option ...] file.{cm|sml|c|o} [file.{c|S|o} ...]"
-
-val {parse, usage} =
- Popt.makeUsage {mainUsage = mainUsage,
- makeOptions = makeOptions,
- showExpert = fn () => !expert}
-
-val usage = fn s => (usage s; raise Fail "unreachable")
-
-fun commandLine (args: string list): unit =
- let
- open Control
- val args =
- case args of
- lib :: args => (libDir := lib; args)
- | _ => Error.bug "incorrect args from shell script"
- val _ = setTargetType ("self", usage)
- val result = parse args
- val gcc = !gcc
- val target = !target
- val targetStr =
- case target of
- Cross s => s
- | Self => "self"
- val _ = libTargetDir := concat [!libDir, "/", targetStr]
- val targetArch = !targetArch
- val archStr = MLton.Platform.Arch.toString targetArch
- val targetOS = !targetOS
- val OSStr = MLton.Platform.OS.toString targetOS
- fun tokenize l =
- String.tokens (concat (List.separate (l, " ")), Char.isSpace)
- fun addTargetOpts opts =
- tokenize
- (List.fold
- (!opts, [], fn ({opt, pred}, ac) =>
- if (case pred of
- OptPred.Target s => s = archStr orelse s = OSStr
- | OptPred.Yes => true)
- then opt :: ac
- else ac))
- val ccOpts = addTargetOpts ccOpts
- val linkOpts = addTargetOpts linkOpts
- datatype z = datatype MLton.Platform.OS.t
- val linkWithGmp =
- case targetOS of
- Cygwin => ["-lgmp"]
- | FreeBSD => ["-L/usr/local/lib/", "-lgmp"]
- | Linux =>
- (* This mess is necessary because the linker on linux
- * adds a dependency to a shared library even if there are
- * no references to it. So, on linux, we explicitly link
- * with libgmp.a instead of using -lgmp.
- *)
- let
- val conf = "/etc/ld.so.conf"
- val dirs = if File.canRead conf then File.lines conf else []
- val dirs = "/lib\n" :: "/usr/lib\n" :: dirs
- in
- case (List.peekMap
- (dirs, fn d =>
- let
- val lib =
- concat [String.dropSuffix (d, 1), "/libgmp.a"]
- in
- if File.canRead lib
- then SOME lib
- else NONE
- end)) of
- NONE => ["-lgmp"]
- | SOME lib => [lib]
- end
- | NetBSD => ["-Wl,-R/usr/pkg/lib", "-L/usr/pkg/lib", "-lgmp"]
- | Sun => ["-lgmp"]
- val linkOpts =
- List.concat [[concat ["-L", !libTargetDir],
- if !debug then "-lmlton-gdb" else "-lmlton"],
- linkWithGmp,
- linkOpts]
- val _ =
- if !Native.native andalso targetArch = Sparc
- then usage "can't use -native true on Sparc"
- else ()
- val _ =
- chunk := (if !Native.native
- then
- if isSome (!coalesce)
- then usage "can't use -coalesce and -native true"
- else ChunkPerFunc
- else Coalesce {limit = (case !coalesce of
- NONE => 4096
- | SOME n => n)})
- val _ = if not (!Native.native) andalso !Native.IEEEFP
- then usage "can't use -native false and -ieee-fp true"
- else ()
- val _ =
- if !keepDot andalso List.isEmpty (!keepPasses)
- then keepSSA := true
- else ()
- val _ =
- if targetOS = Cygwin andalso !profile = ProfileTime
- then usage "can't use -profile time on Cygwin"
- else ()
- fun printVersion (out: Out.t): unit =
- Out.output (out, concat [version, " ", build, "\n"])
- in
- case result of
- Result.No msg => usage msg
- | Result.Yes [] =>
- (case !verbosity of
- Silent =>
- if !showBasis
- then Layout.outputl (Compile.layoutBasisLibrary (),
- Out.standard)
- else if !buildConstants
- then Compile.outputBasisConstants Out.standard
- else printVersion Out.standard
- | Top => printVersion Out.standard
- | _ => (inputFile := ""
- ; outputHeader' (No, Out.standard)))
- | Result.Yes (input :: rest) =>
- let
- val _ = inputFile := File.base (File.fileOf input)
- val (start, base) =
- let
- val rec loop =
- fn [] => usage (concat ["invalid file suffix on ", input])
- | (suf, start, hasNum) :: sufs =>
- if String.isSuffix {string = input, suffix = suf}
- then (start,
- let
- val f = File.base input
- in
- if hasNum
- then File.base f
- else f
- end)
- else loop sufs
- datatype z = datatype Place.t
- in
- loop [(".cm", CM, false),
- (".sml", SML, false),
- (".c", Generated, true),
- (".o", O, true)]
- end
- val _ =
- List.foreach
- (rest, fn f =>
- if List.exists ([".c", ".o", ".s", ".S"], fn suffix =>
- String.isSuffix {string = f, suffix = suffix})
- andalso File.canRead f
- then ()
- else usage (concat ["invalid file: ", f]))
- val csoFiles = rest
- val stop = !stop
- in
- case Place.compare (start, stop) of
- GREATER => usage (concat ["cannot go from ", Place.toString start,
- " to ", Place.toString stop])
- | EQUAL => usage "nothing to do"
- | LESS =>
- let
- val _ =
- if !verbosity = Top
- then printVersion Out.error
- else ()
- val tempFiles: File.t list ref = ref []
- val tmpDir =
- case Process.getEnv "TMPDIR" of
- NONE => "/tmp"
- | SOME d => d
- fun temp (suf: string): File.t =
- let
- val (f, out) =
- File.temp {prefix = concat [tmpDir, "/file"],
- suffix = suf}
- val _ = Out.close out
- val _ = List.push (tempFiles, f)
- in
- f
- end
- fun suffix s = concat [base, s]
- fun maybeOut suf =
- case !output of
- NONE => suffix suf
- | SOME f => f
- val _ =
- atMLtons :=
- Vector.fromList
- (maybeOut "" :: tokenize (rev ("--" :: (!runtimeArgs))))
- datatype debugFormat =
- Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus
- (* The -Wa,--gstabs says to pass the --gstabs option to the
- * assembler. This tells the assembler to generate stabs
- * debugging information for each assembler line.
- *)
- val debugFormat = StabsPlus
- val (gccDebug, asDebug) =
- case debugFormat of
- Dwarf => (["-gdwarf", "-g2"], "-Wa,--gdwarf2")
- | DwarfPlus => (["-gdwarf+", "-g2"], "-Wa,--gdwarf2")
- | Dwarf2 => (["-gdwarf-2", "-g2"], "-Wa,--gdwarf2")
- | Stabs => (["-gstabs", "-g2"], "-Wa,--gstabs")
- | StabsPlus => (["-gstabs+", "-g2"], "-Wa,--gstabs")
- fun compileO (inputs: File.t list): unit =
- let
- val output = maybeOut ""
- val _ =
- trace (Top, "Link")
- (fn () =>
- System.system
- (gcc,
- List.concat
- [["-o", output],
- (case target of
- Cross s => ["-b", s]
- | Self => []),
- if !debug then gccDebug else [],
- if !static then ["-static"] else [],
- inputs,
- linkOpts]))
- ()
- (* gcc on Cygwin appends .exe, which I don't want, so
- * move the output file to it's rightful place.
- * Notice that we do not use targetOS here, since we
- * care about the platform we're running on, not the
- * platform we're generating for.
- *)
- val _ =
- if MLton.Platform.OS.host = Cygwin
- then
- if String.contains (output, #".")
- then ()
- else
- File.move {from = concat [output, ".exe"],
- to = output}
- else ()
- in
- ()
- end
- fun compileCSO (inputs: File.t list): unit =
- if List.forall (inputs, fn f =>
- SOME "o" = File.extension f)
- then compileO inputs
- else
- let
- val c = Counter.new 0
- val oFiles =
- trace (Top, "Compile C and Assemble")
- (fn () =>
- List.fold
- (inputs, [], fn (input, ac) =>
- let
- val extension = File.extension input
- in
- if SOME "o" = extension
- then input :: ac
- else
- let
- val (debugSwitches, switches) =
- if SOME "c" = extension
- then
- (gccDebug @ ["-DASSERT=1"],
- ccOpts)
- else ([asDebug], [])
- val switches =
- if !debug
- then debugSwitches @ switches
- else switches
- val switches =
- case target of
- Cross s => "-b" :: s :: switches
- | Self => switches
- val switches = "-c" :: switches
- val output =
- if stop = Place.O orelse !keepO
- then
- if !keepGenerated
- orelse start = Place.Generated
- then
- concat [String.dropSuffix
- (input, 1),
- "o"]
- else
- suffix
- (concat [".",
- Int.toString
- (Counter.next c),
- ".o"])
- else temp ".o"
- val _ =
- System.system
- (gcc,
- List.concat [switches,
- ["-o", output, input]])
-
- in
- output :: ac
- end
- end))
- ()
- in
- case stop of
- Place.O => ()
- | _ => compileO (rev oFiles)
- end
- fun compileSml (files: File.t list) =
- let
- val outputs: File.t list ref = ref []
- val r = ref 0
- fun make (style: style, suf: string) () =
- let
- val suf = concat [".", Int.toString (!r), suf]
- val _ = Int.inc r
- val file = (if !keepGenerated
- orelse stop = Place.Generated
- then suffix
- else temp) suf
- val _ = List.push (outputs, file)
- val out = Out.openOut file
- fun print s = Out.output (out, s)
- val _ = outputHeader' (style, out)
- fun done () = Out.close out
- in
- {file = file,
- print = print,
- done = done}
- end
- val _ =
- case !verbosity of
- Silent => ()
- | Top => ()
- | _ =>
- outputHeader
- (Control.No, fn l =>
- let val out = Out.error
- in Layout.output (l, out)
- ; Out.newline out
- end)
- val _ =
- trace (Top, "Compile SML")
- Compile.compile
- {input = files,
- outputC = make (Control.C, ".c"),
- outputS = make (Control.Assembly,
- if !debug then ".s" else ".S")}
- (* Shrink the heap before calling gcc. *)
- val _ = MLton.GC.pack ()
- in
- case stop of
- Place.Generated => ()
- | _ => compileCSO (List.concat [!outputs, csoFiles])
- end
- fun compileCM input =
- let
- val files = CM.cm {cmfile = input}
- fun saveSML smlFile =
- File.withOut
- (smlFile, fn out =>
- (outputHeader' (ML, out)
- ; (List.foreach
- (files, fn f =>
- (Out.output
- (out, concat ["(*#line 0.0 \"", f, "\"*)\n"])
- ; File.outputContents (f, out))))))
- in
- case stop of
- Place.Files =>
- List.foreach
- (files, fn f => print (concat [f, "\n"]))
- | Place.SML => saveSML (maybeOut ".sml")
- | _ =>
- (if !keepSML
- then saveSML (suffix ".sml")
- else ()
- ; compileSml files)
- end
- fun compile () =
- case start of
- Place.CM => compileCM input
- | Place.SML => compileSml [input]
- | Place.Generated => compileCSO (input :: csoFiles)
- | Place.O => compileCSO (input :: csoFiles)
- | _ => Error.bug "invalid start"
- val doit
- = trace (Top, "MLton")
- (fn () =>
- DynamicWind.wind
- (compile, fn () =>
- List.foreach (!tempFiles, File.remove)))
- in doit ()
- end
- end
- end
-
-val commandLine = Process.makeCommandLine commandLine
-
-fun exportNJ (root: Dir.t, file: File.t): unit =
- (Compile.forceBasisLibrary root
- ; SMLofNJ.exportFn (file, fn (_, args) => commandLine args))
-
-fun exportMLton (): unit =
- case CommandLine.arguments () of
- [root, file] => exportNJ (root, file)
- | _ => Error.bug "usage: exportMLton root file"
-
-end
+structure Main = Main ()
1.5 +5 -3 mlton/mlton/main/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/sources.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.4
+++ sources.cm 9 Oct 2003 18:17:33 -0000 1.5
@@ -8,7 +8,6 @@
Group
structure Char
-structure Compile
structure Control
structure Date
structure Dir
@@ -38,13 +37,16 @@
../codegen/sources.cm
../control/sources.cm
../core-ml/sources.cm
+../defunctorize/sources.cm
../elaborate/sources.cm
../front-end/sources.cm
../ssa/sources.cm
-../type-inference/sources.cm
../xml/sources.cm
+compile.fun
compile.sig
-compile.sml
+lookup-constant.sig
+lookup-constant.fun
+main.fun
main.sig
main.sml
1.1 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor Compile (S: COMPILE_STRUCTS): COMPILE =
struct
(*---------------------------------------------------*)
(* Intermediate Languages *)
(*---------------------------------------------------*)
structure Field = Field ()
structure Record = Record (val isSorted = false
structure Field = Field)
structure SortedRecord = Record (val isSorted = true
structure Field = Field)
structure Tyvar = Tyvar ()
structure Ast = Ast (structure Record = Record
structure SortedRecord = SortedRecord
structure Tyvar = Tyvar)
local
open Ast.Tycon
in
structure IntSize = IntSize
structure RealSize = RealSize
structure WordSize = WordSize
end
structure Atoms = Atoms (structure Ast = Ast
structure Field = Field
structure IntSize = IntSize
structure RealSize = RealSize
structure Record = Record
structure SortedRecord = SortedRecord
structure Tyvar = Tyvar
structure WordSize = WordSize)
local
open Atoms
in
structure Const = Const
structure Ffi = Ffi
structure IntX = IntX
end
structure TypeEnv = TypeEnv (Atoms)
structure CoreML = CoreML (open Atoms
structure Type =
struct
open TypeEnv.Type
val layout = layoutPretty
end)
structure Xml = Xml (open Atoms)
structure Sxml = Sxml (open Xml)
structure Ssa = Ssa (open Atoms)
structure Machine = Machine (open Atoms
structure Label = Ssa.Label)
local
open Machine
in
structure Runtime = Runtime
end
(*---------------------------------------------------*)
(* Compiler Passes *)
(*---------------------------------------------------*)
structure FrontEnd = FrontEnd (structure Ast = Ast)
(* structure DeadCode = DeadCode (structure CoreML = CoreML) *)
structure Defunctorize = Defunctorize (structure CoreML = CoreML
structure Xml = Xml)
structure Elaborate = Elaborate (structure Ast = Ast
structure CoreML = CoreML
structure TypeEnv = TypeEnv)
local
open Elaborate
in
structure ConstType = ConstType
structure Decs = Decs
structure Env = Env
end
structure LookupConstant = LookupConstant (structure Const = Const
structure ConstType = ConstType
structure Ffi = Ffi)
structure Monomorphise = Monomorphise (structure Xml = Xml
structure Sxml = Sxml)
structure ClosureConvert = ClosureConvert (structure Ssa = Ssa
structure Sxml = Sxml)
structure Backend = Backend (structure Ssa = Ssa
structure Machine = Machine
fun funcToLabel f = f)
structure CCodegen = CCodegen (structure Ffi = Ffi
structure Machine = Machine)
structure x86Codegen = x86Codegen (structure CCodegen = CCodegen
structure Machine = Machine)
local
open Elaborate
in
structure Decs = Decs
end
(* ------------------------------------------------- *)
(* parseAndElaborate *)
(* ------------------------------------------------- *)
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 elaborateProg z: Decs.t =
let
val decs = elaborate z
val _ = Control.checkForErrors "elaborate"
in
decs
end
val displayDecs =
Control.Layout
(fn ds => CoreML.Program.layout (CoreML.Program.T
{decs = Decs.toVector ds}))
fun parseAndElaborateFiles (fs: File.t list, E: Env.t, lookupConstant): Decs.t =
Control.pass
{name = "parseAndElaborate",
suffix = "core-ml",
style = Control.ML,
thunk = fn () => (List.fold
(fs, Decs.empty, fn (f, ds) =>
Decs.append
(ds, elaborateProg (lexAndParseFile f,
E,
lookupConstant)))),
display = displayDecs}
(* ------------------------------------------------- *)
(* Primitive Env *)
(* ------------------------------------------------- *)
local
structure Con = TypeEnv.Con
structure Scheme = TypeEnv.InferScheme
structure Tycon = TypeEnv.Tycon
structure Type = TypeEnv.Type
structure Tyvar = TypeEnv.Tyvar
in
val primitiveDatatypes =
Vector.new3
({tycon = Tycon.bool,
tyvars = Vector.new0 (),
cons = Vector.new2 ({con = Con.falsee, arg = NONE},
{con = Con.truee, arg = NONE})},
let
val a = Tyvar.newNoname {equality = false}
in
{tycon = Tycon.list,
tyvars = Vector.new1 a,
cons = Vector.new2 ({con = Con.nill, arg = NONE},
{con = Con.cons,
arg = SOME (Type.tuple
(Vector.new2
(Type.var a,
Type.list (Type.var a))))})}
end,
let
val a = Tyvar.newNoname {equality = false}
in
{tycon = Tycon.reff,
tyvars = Vector.new1 a,
cons = Vector.new1 {con = Con.reff, arg = SOME (Type.var a)}}
end)
val primitiveExcons =
let
open CoreML.Con
in
[bind, match, overflow]
end
structure Con =
struct
open Con
fun toAst c = Ast.Con.fromString (Con.toString c, Region.bogus)
end
structure Tycon =
struct
open Tycon
fun toAst c = Ast.Tycon.fromString (Tycon.toString c, Region.bogus)
end
structure Env =
struct
open Env
structure Type = TypeEnv.Type
structure Scheme = TypeEnv.InferScheme
fun addPrim (E: t): unit =
let
val _ =
List.foreach
(Tycon.prims, fn (tycon, kind) =>
extendTycon
(E, Ast.Tycon.fromString (Tycon.originalName tycon,
Region.bogus),
TypeStr.tycon (tycon, kind)))
val _ =
Vector.foreach
(primitiveDatatypes, fn {tyvars, tycon, cons} =>
let
val cs =
Vector.map
(cons, fn {arg, con} =>
let
val resultType =
Type.con (tycon, Vector.map (tyvars, Type.var))
val scheme =
Scheme.make
{canGeneralize = true,
ty = (case arg of
NONE => resultType
| SOME t => Type.arrow (t, resultType)),
tyvars = tyvars}
in
{con = con,
name = Con.toAst con,
scheme = scheme}
end)
val _ =
Vector.foreach (cs, fn {con, name, scheme} =>
extendCon (E, name, con, scheme))
in
extendTycon
(E, Tycon.toAst tycon,
TypeStr.data (tycon,
TypeStr.Kind.Arity (Vector.length tyvars),
cs))
end)
val _ =
extendTycon (E, Ast.Tycon.fromString ("unit", Region.bogus),
TypeStr.def (Scheme.fromType Type.unit,
TypeStr.Kind.Arity 0))
val scheme = Scheme.fromType Type.exn
val _ = List.foreach (primitiveExcons, fn c =>
extendCon (E, Con.toAst c, c, scheme))
in
()
end
end
end
(* ------------------------------------------------- *)
(* Basis Library *)
(* ------------------------------------------------- *)
val basisEnv = Env.empty ()
val allConstants: (string * ConstType.t) list ref = ref []
val amBuildingConstants: bool ref = ref false
val lookupConstant =
let
val zero = Const.int (IntX.make (0, IntSize.default))
val f =
Promise.lazy
(fn () =>
if !amBuildingConstants
then fn ct => (List.push (allConstants, ct)
; zero)
else
File.withIn
(concat [!Control.libTargetDir, "/constants"], fn ins =>
LookupConstant.load ins))
in
fn z => f () z
end
local
val dir = ref NONE
in
fun setBasisLibraryDir (d: Dir.t): unit =
dir := SOME d
fun basisLibrary ()
: {build: Decs.t,
localTopFinish: (unit -> Decs.t * Decs.t * Decs.t) ->
Decs.t * Decs.t * Decs.t,
libs: {name: string,
bind: Ast.Program.t,
prefix: Ast.Program.t,
suffix: Ast.Program.t} list} =
let
val d =
case !dir of
NONE => Error.bug "basis library dir not set"
| SOME d => d
fun basisFile f = String./ (d, f)
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
; withFiles (libsFile "build",
fn fs => parseAndElaborateFiles (fs, basisEnv,
lookupConstant))))
val _ =
Env.Structure.ffi
:= SOME (Env.lookupLongstrid
(basisEnv,
Ast.Longstrid.short
(Ast.Strid.fromString ("MLtonFFI", Region.bogus))))
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
{build = build,
localTopFinish = localTopFinish,
libs = List.map (Control.basisLibs, doit)}
end
end
val basisLibrary = Promise.lazy basisLibrary
fun forceBasisLibrary d =
(setBasisLibraryDir d
; basisLibrary ()
; ())
val primitiveDecs: CoreML.Dec.t vector =
let
open CoreML.Dec
in
Vector.concat [Vector.new1 (Datatype primitiveDatatypes),
Vector.fromListMap
(primitiveExcons, fn c =>
Exception {con = c, arg = NONE})]
end
fun outputBasisConstants (out: Out.t): unit =
let
val _ = amBuildingConstants := true
val {build, ...} = basisLibrary ()
(* Need to defunctorize so the constants are forced. *)
val _ =
Defunctorize.defunctorize
(CoreML.Program.T {decs = Vector.concat [primitiveDecs,
Decs.toVector build]})
val _ = LookupConstant.build (!allConstants, out)
in
()
end
fun lookupConstantError _ = Error.bug "const in user input"
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 (concat ["Missing basis library: ", lib])
| SOME {bind, prefix, suffix, ...} =>
let
val (bind, prefix, suffix) =
localTopFinish
(fn () =>
(elaborateProg (bind, basisEnv, lookupConstantError),
elaborateProg (prefix, basisEnv, lookupConstantError),
elaborateProg (suffix, basisEnv, lookupConstantError)))
in
{basis = Decs.append (build, bind),
prefix = prefix,
suffix = suffix}
end
end
fun layoutBasisLibrary () =
let val _ = selectBasisLibrary ()
in Env.layoutPretty basisEnv
end
(* ------------------------------------------------- *)
(* compile *)
(* ------------------------------------------------- *)
fun preCodegen {input}: Machine.Program.t =
let
fun parseElabMsg () = (lexAndParseMsg (); elaborateMsg ())
val decs =
let
val {basis, prefix, suffix, ...} = selectBasisLibrary ()
fun parseAndElab () =
parseAndElaborateFiles (input, basisEnv, lookupConstantError)
val input =
if !Control.showBasisUsed
then let
val input =
Elaborate.Env.scopeAll (basisEnv, parseAndElab)
val _ =
Layout.outputl
(Elaborate.Env.layoutUsed basisEnv,
Out.standard)
in
Process.succeed ()
end
else
parseAndElab ()
val _ =
if not (!Control.exportHeader)
then ()
else
let
val _ =
File.outputContents
(concat [!Control.libDir, "/include/types.h"],
Out.standard)
val _ = print "\n"
val _ = Ffi.declareHeaders {print = print}
in
Process.succeed ()
end
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)
*)
(* Set GC_state offsets. *)
val _ =
let
fun get (s: string): int =
case lookupConstant (s, ConstType.Int) of
Const.Int i => IntX.toInt i
| _ => Error.bug "GC_state offset must be an int"
in
Runtime.GCField.setOffsets
{
canHandle = get "canHandle",
cardMap = get "cardMapForMutator",
currentThread = get "currentThread",
exnStack = get "exnStack",
frontier = get "frontier",
limit = get "limit",
limitPlusSlop = get "limitPlusSlop",
maxFrameSize = get "maxFrameSize",
signalIsPending = get "signalIsPending",
stackBottom = get "stackBottom",
stackLimit = get "stackLimit",
stackTop = get "stackTop"
}
end
val xml =
Control.passSimplify
{name = "defunctorize",
suffix = "xml",
style = Control.ML,
thunk = fn () => Defunctorize.defunctorize coreML,
display = Control.Layout Xml.Program.layout,
typeCheck = Xml.typeCheck,
simplify = Xml.simplify}
val _ = Control.message (Control.Detail, fn () =>
Xml.Program.layoutStats xml)
val sxml =
Control.passSimplify
{name = "mono",
suffix = "sxml",
style = Control.ML,
thunk = fn () => Monomorphise.monomorphise xml,
display = Control.Layout Sxml.Program.layout,
typeCheck = Sxml.typeCheck,
simplify = Sxml.simplify}
val _ = Control.message (Control.Detail, fn () =>
Sxml.Program.layoutStats sxml)
val ssa =
Control.passSimplify
{name = "closureConvert",
suffix = "ssa",
style = Control.No,
thunk = fn () => ClosureConvert.closureConvert sxml,
typeCheck = Ssa.typeCheck,
display = Control.Layouts Ssa.Program.layouts,
simplify = Ssa.simplify}
val _ =
let
open Control
in
if !keepSSA
then saveToFile ({suffix = "ssa"}, No, ssa,
Layouts Ssa.Program.layouts)
else ()
end
val machine =
Control.pass
{name = "backend",
suffix = "machine",
style = Control.No,
thunk = fn () => Backend.toMachine ssa,
display = Control.Layouts Machine.Program.layouts}
val _ =
let
open Control
in
if !keepMachine
then saveToFile ({suffix = "machine"}, No, machine,
Layouts Machine.Program.layouts)
else ()
end
val _ =
Control.trace (Control.Pass, "machine type check")
Machine.Program.typeCheck machine
in
machine
end
fun compile {input: File.t list, outputC, outputS}: unit =
let
val machine =
Control.trace (Control.Top, "pre codegen")
preCodegen {input = input}
val _ =
if !Control.Native.native
then
Control.trace (Control.Top, "x86 code gen")
x86Codegen.output {program = machine,
outputC = outputC,
outputS = outputS}
else
Control.trace (Control.Top, "C code gen")
CCodegen.output {program = machine,
outputC = outputC}
val _ = Control.message (Control.Detail, PropertyList.stats)
val _ = Control.message (Control.Detail, HashSet.stats)
in
()
end
end
1.1 mlton/mlton/main/lookup-constant.fun
Index: lookup-constant.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor LookupConstant (S: LOOKUP_CONSTANT_STRUCTS): LOOKUP_CONSTANT =
struct
open S
local
open Const
in
structure IntX = IntX
structure RealX = RealX
structure WordX = WordX
end
structure IntSize = IntX.IntSize
structure RealSize = RealX.RealSize
structure WordSize = WordX.WordSize
val buildConstants: (string * (unit -> string)) list =
let
val bool = Bool.toString
val int = Int.toString
open Control
in
[("Exn_keepHistory", fn () => bool (!exnHistory)),
("MLton_detectOverflow", fn () => bool (!detectOverflow)),
("MLton_native", fn () => bool (!Native.native)),
("MLton_profile_isOn", fn () => bool (!profile <> ProfileNone)),
("MLton_safe", fn () => bool (!safe)),
("MLton_FFI_numExports", fn () => int (Ffi.numExports ())),
("TextIO_bufSize", fn () => int (!textIOBufSize))]
end
datatype z = datatype ConstType.t
fun escape s =
String.translate (s, fn c =>
let
val i = Char.ord c
fun dig j =
Char.chr
(Char.ord #"0" + Int.rem (Int.quot (i, j), 10))
in
implode [dig 100, dig 10, dig 1]
end)
fun unescape s =
let
fun sub i = Char.toInt (String.sub (s, i)) - Char.toInt #"0"
fun loop (i, ac) =
if i < 0
then ac
else
loop (i - 3,
Char.fromInt ((sub (i - 2) * 10 + sub (i - 1)) * 10 + sub i)
:: ac)
in
implode (loop (String.size s - 1, []))
end
val unescape = Trace.trace ("unescape", String.layout, String.layout) unescape
val gcFields =
[
"canHandle",
"currentThread",
"exnStack",
"frontier",
"cardMapForMutator",
"limit",
"limitPlusSlop",
"maxFrameSize",
"signalIsPending",
"stackBottom",
"stackLimit",
"stackTop"
]
val gcFields =
List.map (gcFields, fn s =>
{name = s,
value = concat ["offsetof (struct GC_state, ", s, ")"],
ty = ConstType.Int})
fun build (constants, out) =
let
val constants =
List.fold
(constants, gcFields, fn ((name, ty), ac) =>
if List.exists (buildConstants, fn (name', _) => name = name')
then ac
else {name = name, value = name, ty = ty} :: ac)
in
List.foreach
(List.concat
[["#include <stddef.h>", (* for offsetof *)
"#include <stdio.h>"],
List.map (["libmlton.h"], fn i =>
concat ["#include <", i, ">"]),
["struct GC_state gcState;",
"int main (int argc, char **argv) {"],
List.revMap
(constants, fn {name, value, ty} =>
let
val (format, value) =
case ty of
Bool => ("%s", concat [value, "? \"true\" : \"false\""])
| Int => ("%d", value)
| Real => ("%.20f", value)
| String => ("%s", concat ["\"", escape value, "\""])
| Word => ("%u", value)
in
concat ["fprintf (stdout, \"", name, " = ", format, "\\n\", ",
value, ");"]
end),
["return 0;}"]],
fn l => (Out.output (out, l); Out.newline out))
end
fun load (ins: In.t): string * ConstType.t -> Const.t =
let
val table: {hash: word, name: string, value: string} HashSet.t =
HashSet.new {hash = #hash}
fun add {name, value} =
let
val hash = String.hash name
val _ =
HashSet.lookupOrInsert
(table, hash,
fn {name = name', ...} => name = name',
fn () => {hash = hash, name = name, value = value})
in
()
end
val buildConstants =
List.foreach (buildConstants, fn (name, f) =>
add {name = name, value = f ()})
val _ =
In.foreachLine
(ins, fn l =>
case String.tokens (l, Char.isSpace) of
[name, "=", value] => add {name = name, value = value}
| _ => Error.bug (concat ["strange constants line: ", l]))
fun lookupConstant (name: string, ty: ConstType.t): Const.t =
let
val {value, ...} =
HashSet.lookupOrInsert
(table, String.hash name,
fn {name = name', ...} => name = name',
fn () => Error.bug (concat ["constant not found: ", name]))
fun int i = Const.int (IntX.make (i, IntSize.default))
in
case ty of
Bool =>
(case Bool.fromString value of
NONE => Error.bug "strange Bool constante"
| SOME b => int (if b then 1 else 0))
| Int =>
(case IntInf.fromString value of
NONE => Error.bug "strange Int constant"
| SOME i => int i)
| Real => Const.Real (RealX.make (value, RealSize.default))
| String => Const.string (unescape value)
| Word =>
(case IntInf.fromString value of
NONE => Error.bug "strange Word constant"
| SOME i =>
Const.Word (WordX.make (LargeWord.fromIntInf i,
WordSize.default)))
end
in
lookupConstant
end
end
1.1 mlton/mlton/main/lookup-constant.sig
Index: lookup-constant.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
type int = Int.t
type word = Word.t
signature LOOKUP_CONSTANT_STRUCTS =
sig
structure Const: CONST
structure ConstType: CONST_TYPE
structure Ffi: FFI
end
signature LOOKUP_CONSTANT =
sig
include LOOKUP_CONSTANT_STRUCTS
val build: (string * ConstType.t) list * Out.t -> unit
val load: In.t -> string * ConstType.t -> Const.t
end
1.1 mlton/mlton/main/main.fun
Index: main.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor Main (S: MAIN_STRUCTS): MAIN =
struct
open S
structure Compile = Compile ()
structure Place =
struct
datatype t = CM | Files | Generated | O | OUT | SML
val toInt: t -> int =
fn CM => 0
| Files => 1
| SML => 2
| Generated => 3
| O => 4
| OUT => 5
val toString =
fn CM => "cm"
| Files => "files"
| SML => "sml"
| Generated => "g"
| O => "o"
| OUT => "out"
val layout = Layout.str o toString
fun compare (p, p') = Int.compare (toInt p, toInt p')
end
structure OptPred =
struct
datatype t =
Target of string
| Yes
end
val buildConstants: bool ref = ref false
val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
val coalesce: int option ref = ref NONE
val expert: bool ref = ref false
val gcc: string ref = ref "<unset>"
val keepGenerated = ref false
val keepO = ref false
val keepSML = ref false
val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
val output: string option ref = ref NONE
val profileSet: bool ref = ref false
val runtimeArgs: string list ref = ref ["@MLton"]
val showBasis: bool ref = ref false
val stop = ref Place.OUT
val targetMap: unit -> {arch: MLton.Platform.Arch.t,
os: MLton.Platform.OS.t,
target: string} list =
Promise.lazy
(fn () =>
List.map
(File.lines (concat [!Control.libDir, "/target-map"]), fn line =>
case String.tokens (line, Char.isSpace) of
[target, arch, os] =>
let
val arch =
case MLton.Platform.Arch.fromString arch of
NONE => Error.bug (concat ["strange arch: ", arch])
| SOME a => a
val os =
case MLton.Platform.OS.fromString os of
NONE => Error.bug (concat ["strange os: ", os])
| SOME os => os
in
{arch = arch, os = os, target = target}
end
| _ => Error.bug (concat ["strange target mapping: ", line])))
fun setTargetType (target: string, usage): unit =
case List.peek (targetMap (), fn {target = t, ...} => t = target) of
NONE => usage (concat ["invalid target ", target])
| SOME {arch, os, ...} =>
let
datatype z = datatype MLton.Platform.Arch.t
open Control
in
targetArch := arch
; targetOS := os
; (case arch of
Sparc =>
(align := Align8
; Native.native := false)
| _ => ())
end
fun makeOptions {usage} =
let
val usage = fn s => (usage s; raise Fail "unreachable")
open Control Popt
fun push r = SpaceString (fn s => List.push (r, s))
datatype z = datatype MLton.Platform.Arch.t
in
List.map
(
[
(Normal, "align",
case !targetArch of
Sparc => " {8|4}"
| X86 => " {4|8}",
"object alignment",
(SpaceString (fn s =>
align
:= (case s of
"4" => Align4
| "8" => Align8
| _ => usage (concat ["invalid -align flag: ",
s]))))),
(Normal, "basis", " {2002|1997|...}",
"select basis library to prefix to the program",
SpaceString (fn s =>
let
val s' = concat ["basis-", s]
in
if List.contains (basisLibs, s', String.equals)
then basisLibrary := s'
else usage (concat ["invalid -basis flag: ", s])
end)),
(Expert, "build-constants", " {false|true}",
"output C file that prints basis constants",
boolRef buildConstants),
(Expert, "card-size-log2", " <n>",
"log (base 2) of card size used by GC",
intRef cardSizeLog2),
(Expert, "cc", " <gcc>", "path to gcc executable",
SpaceString (fn s => gcc := s)),
(Normal, "cc-opt", " <opt>", "pass option to C compiler",
SpaceString (fn s =>
List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
(Expert, "coalesce", " <n>", "coalesce chunk size for C codegen",
Int (fn n => coalesce := SOME n)),
(Expert, "debug", " {false|true}", "produce executable with debug info",
boolRef debug),
(Normal, "detect-overflow", " {true|false}",
"overflow checking on integer arithmetic",
boolRef detectOverflow),
(Expert, "diag-pass", " <pass>", "keep diagnostic info for pass",
SpaceString (fn s =>
(case Regexp.fromString s of
SOME (re,_) => let val re = Regexp.compileDFA re
in
List.push (keepDiagnostics, re)
; List.push (keepPasses, re)
end
| NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
(Expert, "drop-pass", " <pass>", "omit optimization pass",
SpaceString
(fn s => (case Regexp.fromString s of
SOME (re,_) => let val re = Regexp.compileDFA re
in List.push (dropPasses, re)
end
| NONE => usage (concat ["invalid -drop-pass flag: ", s])))),
(Expert, "eliminate-overflow", " {true|false}",
"eliminate useless overflow tests",
boolRef eliminateOverflow),
(Normal, "exn-history", " {false|true}",
"enable Exn.history",
boolRef exnHistory),
(Expert, "expert", " {false|true}",
"enable expert status",
boolRef expert),
(Normal, "export-header", " {false|true}",
"output header file for _export's",
boolRef exportHeader),
(Expert, "gc-check", " {limit|first|every}", "force GCs",
SpaceString (fn s =>
gcCheck :=
(case s of
"limit" => Limit
| "first" => First
| "every" => Every
| _ => usage (concat ["invalid -gc-check flag: ", s])))),
(Expert, "handlers", " {flow|pushpop|simple}",
"how to implement handlers",
SpaceString (fn s =>
case s of
"flow" => handlers := Flow
| "simple" => handlers := Simple
| _ => usage (concat ["invalid -handlers flag: ", s]))),
(Normal, "ieee-fp", " {false|true}", "use strict IEEE floating-point",
boolRef Native.IEEEFP),
(Expert, "indentation", " <n>", "indentation level in ILs",
intRef indentation),
(Normal, "inline", " <n>", "inlining threshold", Int setInlineSize),
(Normal, "keep", " {g|o|sml}", "save intermediate files",
SpaceString (fn s =>
case s of
"dot" => keepDot := true
| "g" => keepGenerated := true
| "machine" => keepMachine := true
| "o" => keepO := true
| "sml" => keepSML := true
| "rssa" => keepRSSA := true
| "ssa" => keepSSA := true
| _ => usage (concat ["invalid -keep flag: ", s]))),
(Expert, "keep-pass", " <pass>", "keep the results of pass",
SpaceString
(fn s => (case Regexp.fromString s of
SOME (re,_) => let val re = Regexp.compileDFA re
in List.push (keepPasses, re)
end
| NONE => usage (concat ["invalid -keep-pass flag: ", s])))),
(Expert, "limit-check", " {lhle|pb|ebb|lh|lhf|lhfle}",
"limit check insertion algorithm",
SpaceString (fn s =>
case s of
"pb" => limitCheck := PerBlock
| "ebb" => limitCheck := ExtBasicBlocks
| "lh" => limitCheck := LoopHeaders {fullCFG = false,
loopExits = false}
| "lhf" => limitCheck := LoopHeaders {fullCFG = true,
loopExits = false}
| "lhle" => limitCheck := LoopHeaders {fullCFG = false,
loopExits = true}
| "lhfle" => limitCheck := LoopHeaders {fullCFG = true,
loopExits = true}
| _ => usage (concat ["invalid -limit-check flag: ", s]))),
(Expert, "limit-check-counts", " {false|true}",
"compute dynamic counts of limit checks",
boolRef limitCheckCounts),
(Normal, "link-opt", " <opt>", "pass option to linker",
SpaceString (fn s =>
List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
(Expert, "loop-passes", " <n>", "loop optimization passes (1)",
Int
(fn i =>
if i >= 1
then loopPasses := i
else usage (concat ["invalid -loop-passes arg: ", Int.toString i]))),
(Expert, "mark-cards", " {true|false}", "mutator marks cards",
boolRef markCards),
(Normal, "native",
if !targetArch = Sparc then " {false}" else " {true|false}",
"use native code generator",
boolRef Native.native),
(Expert, "native-commented", " <n>", "level of comments (0)",
intRef Native.commented),
(Expert, "native-copy-prop", " {true|false}",
"use copy propagation",
boolRef Native.copyProp),
(Expert, "native-cutoff", " <n>",
"live transfer cutoff distance",
intRef Native.cutoff),
(Expert, "native-live-transfer", " {0,...,8}",
"use live transfer",
intRef Native.liveTransfer),
(Expert, "native-live-stack", " {false|true}",
"track liveness of stack slots",
boolRef Native.liveStack),
(Expert, "native-move-hoist", " {true|false}",
"use move hoisting",
boolRef Native.moveHoist),
(Expert, "native-optimize", " <n>", "level of optimizations",
intRef Native.optimize),
(Expert, "native-split", " <n>", "split assembly files at ~n lines",
Int (fn i => Native.split := SOME i)),
(Expert, "native-shuffle", " {true|false}",
"shuffle registers at C-calls",
Bool (fn b => Native.shuffle := b)),
(Expert, "new-return", " {false|true}", "non-tail call return convention",
boolRef newReturn),
(Expert, "polyvariance", " {true|false}", "use polyvariance",
Bool (fn b => if b then () else polyvariance := NONE)),
(Normal, "output", " <file>", "name of output file",
SpaceString (fn s => output := SOME s)),
(Normal, "profile", " {no|alloc|time}",
"produce executable suitable for profiling",
SpaceString
(fn s =>
if !profileSet
then usage "can't have multiple -profile switches"
else
(profileSet := true
; profile := (case s of
"no" => ProfileNone
| "alloc" => ProfileAlloc
| "time" => ProfileTime
| _ => usage (concat
["invalid -profile arg: ", s]))))),
(Expert, "profile-basis", " {false|true}",
"profile the basis implementation",
boolRef profileBasis),
(Expert, "profile-il", " {source}", "where to insert profile exps",
SpaceString
(fn s =>
case s of
"source" => profileIL := ProfileSource
| _ => usage (concat ["invalid -profile-il arg: ", s]))),
(Normal, "profile-stack", " {false|true}", "profile the stack",
boolRef profileStack),
(Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
push runtimeArgs),
(Normal, "safe", " {true|false}", "bounds checking and other checks",
boolRef safe),
(Normal, "show-basis", " {false|true}", "display the basis library",
boolRef showBasis),
(Normal, "show-basis-used", " {false|true}",
"display the basis library used by the program",
boolRef showBasisUsed),
(Expert, "show-types", " {false|true}", "print types in ILs",
boolRef showTypes),
(Expert, "stack-cont", " {false|true}",
"force continuation formals to stack",
boolRef stackCont),
(Normal, "static", " {false|true}",
"produce a statically linked executable",
boolRef static),
(Normal, "stop", " {f|g|o|sml}", "where to stop",
SpaceString
(fn s =>
stop := (case s of
"f" => Place.Files
| "g" => Place.Generated
| "o" => Place.O
| "sml" => Place.SML
| _ => usage (concat ["invalid -stop arg: ", s])))),
(Normal, "target",
concat [" {",
concat (List.separate (List.map (targetMap (), #target), "|")),
"}"],
"platform that executable will run on",
SpaceString (fn s =>
(setTargetType (s, usage)
; target := (if s = "self" then Self else Cross s)))),
(Expert, "target-cc-opt", " <target> <opt>", "target-dependent CC option",
(SpaceString2
(fn (target, opt) =>
List.push (ccOpts, {opt = opt, pred = OptPred.Target target})))),
(Expert, "target-link-opt", " <target> <opt>",
"target-dependent link option",
(SpaceString2
(fn (target, opt) =>
List.push (linkOpts, {opt = opt, pred = OptPred.Target target})))),
(Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
(Expert, "text-io-buf-size", " <n>", "TextIO buffer size",
intRef textIOBufSize),
(Expert, "type-check", " {false|true}", "type check ILs",
boolRef typeCheck),
(Normal, "verbose", " {0|1|2|3}", "how verbose to be",
SpaceString
(fn s =>
verbosity := (case s of
"0" => Silent
| "1" => Top
| "2" => Pass
| "3" => Detail
| _ => usage (concat ["invalid -verbose arg: ", s])))),
(Expert, "variant", " {header|first-word}",
"how to represent variant tags",
SpaceString
(fn s =>
variant := (case s of
"first-word" => FirstWord
| "header" => Header
| _ => usage (concat ["invalid -variant arg: ", s]))))
],
fn (style, name, arg, desc, opt) =>
{arg = arg, desc = desc, name = name, opt = opt, style = style})
end
val mainUsage =
"mlton [option ...] file.{cm|sml|c|o} [file.{c|S|o} ...]"
val {parse, usage} =
Popt.makeUsage {mainUsage = mainUsage,
makeOptions = makeOptions,
showExpert = fn () => !expert}
val usage = fn s => (usage s; raise Fail "unreachable")
fun commandLine (args: string list): unit =
let
open Control
val args =
case args of
lib :: args => (libDir := lib; args)
| _ => Error.bug "incorrect args from shell script"
val _ = setTargetType ("self", usage)
val result = parse args
val gcc = !gcc
val target = !target
val targetStr =
case target of
Cross s => s
| Self => "self"
val _ = libTargetDir := concat [!libDir, "/", targetStr]
val targetArch = !targetArch
val archStr = MLton.Platform.Arch.toString targetArch
val targetOS = !targetOS
val OSStr = MLton.Platform.OS.toString targetOS
fun tokenize l =
String.tokens (concat (List.separate (l, " ")), Char.isSpace)
fun addTargetOpts opts =
tokenize
(List.fold
(!opts, [], fn ({opt, pred}, ac) =>
if (case pred of
OptPred.Target s => s = archStr orelse s = OSStr
| OptPred.Yes => true)
then opt :: ac
else ac))
val ccOpts = addTargetOpts ccOpts
val linkOpts = addTargetOpts linkOpts
datatype z = datatype MLton.Platform.OS.t
val linkWithGmp =
case targetOS of
Cygwin => ["-lgmp"]
| FreeBSD => ["-L/usr/local/lib/", "-lgmp"]
| Linux =>
(* This mess is necessary because the linker on linux
* adds a dependency to a shared library even if there are
* no references to it. So, on linux, we explicitly link
* with libgmp.a instead of using -lgmp.
*)
let
val conf = "/etc/ld.so.conf"
val dirs = if File.canRead conf then File.lines conf else []
val dirs = "/lib\n" :: "/usr/lib\n" :: dirs
in
case (List.peekMap
(dirs, fn d =>
let
val lib =
concat [String.dropSuffix (d, 1), "/libgmp.a"]
in
if File.canRead lib
then SOME lib
else NONE
end)) of
NONE => ["-lgmp"]
| SOME lib => [lib]
end
| NetBSD => ["-Wl,-R/usr/pkg/lib", "-L/usr/pkg/lib", "-lgmp"]
| Sun => ["-lgmp"]
val linkOpts =
List.concat [[concat ["-L", !libTargetDir],
if !debug then "-lmlton-gdb" else "-lmlton"],
linkWithGmp,
linkOpts]
val _ =
if !Native.native andalso targetArch = Sparc
then usage "can't use -native true on Sparc"
else ()
val _ =
chunk := (if !Native.native
then
if isSome (!coalesce)
then usage "can't use -coalesce and -native true"
else ChunkPerFunc
else Coalesce {limit = (case !coalesce of
NONE => 4096
| SOME n => n)})
val _ = if not (!Native.native) andalso !Native.IEEEFP
then usage "can't use -native false and -ieee-fp true"
else ()
val _ =
if !keepDot andalso List.isEmpty (!keepPasses)
then keepSSA := true
else ()
val _ =
if targetOS = Cygwin andalso !profile = ProfileTime
then usage "can't use -profile time on Cygwin"
else ()
fun printVersion (out: Out.t): unit =
Out.output (out, concat [version, " ", build, "\n"])
in
case result of
Result.No msg => usage msg
| Result.Yes [] =>
(case !verbosity of
Silent =>
if !showBasis
then Layout.outputl (Compile.layoutBasisLibrary (),
Out.standard)
else if !buildConstants
then Compile.outputBasisConstants Out.standard
else printVersion Out.standard
| Top => printVersion Out.standard
| _ => (inputFile := ""
; outputHeader' (No, Out.standard)))
| Result.Yes (input :: rest) =>
let
val _ = inputFile := File.base (File.fileOf input)
val (start, base) =
let
val rec loop =
fn [] => usage (concat ["invalid file suffix on ", input])
| (suf, start, hasNum) :: sufs =>
if String.isSuffix {string = input, suffix = suf}
then (start,
let
val f = File.base input
in
if hasNum
then File.base f
else f
end)
else loop sufs
datatype z = datatype Place.t
in
loop [(".cm", CM, false),
(".sml", SML, false),
(".c", Generated, true),
(".o", O, true)]
end
val _ =
List.foreach
(rest, fn f =>
if List.exists ([".c", ".o", ".s", ".S"], fn suffix =>
String.isSuffix {string = f, suffix = suffix})
andalso File.canRead f
then ()
else usage (concat ["invalid file: ", f]))
val csoFiles = rest
val stop = !stop
in
case Place.compare (start, stop) of
GREATER => usage (concat ["cannot go from ", Place.toString start,
" to ", Place.toString stop])
| EQUAL => usage "nothing to do"
| LESS =>
let
val _ =
if !verbosity = Top
then printVersion Out.error
else ()
val tempFiles: File.t list ref = ref []
val tmpDir =
case Process.getEnv "TMPDIR" of
NONE => "/tmp"
| SOME d => d
fun temp (suf: string): File.t =
let
val (f, out) =
File.temp {prefix = concat [tmpDir, "/file"],
suffix = suf}
val _ = Out.close out
val _ = List.push (tempFiles, f)
in
f
end
fun suffix s = concat [base, s]
fun maybeOut suf =
case !output of
NONE => suffix suf
| SOME f => f
val _ =
atMLtons :=
Vector.fromList
(maybeOut "" :: tokenize (rev ("--" :: (!runtimeArgs))))
datatype debugFormat =
Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus
(* The -Wa,--gstabs says to pass the --gstabs option to the
* assembler. This tells the assembler to generate stabs
* debugging information for each assembler line.
*)
val debugFormat = StabsPlus
val (gccDebug, asDebug) =
case debugFormat of
Dwarf => (["-gdwarf", "-g2"], "-Wa,--gdwarf2")
| DwarfPlus => (["-gdwarf+", "-g2"], "-Wa,--gdwarf2")
| Dwarf2 => (["-gdwarf-2", "-g2"], "-Wa,--gdwarf2")
| Stabs => (["-gstabs", "-g2"], "-Wa,--gstabs")
| StabsPlus => (["-gstabs+", "-g2"], "-Wa,--gstabs")
fun compileO (inputs: File.t list): unit =
let
val output = maybeOut ""
val _ =
trace (Top, "Link")
(fn () =>
System.system
(gcc,
List.concat
[["-o", output],
(case target of
Cross s => ["-b", s]
| Self => []),
if !debug then gccDebug else [],
if !static then ["-static"] else [],
inputs,
linkOpts]))
()
(* gcc on Cygwin appends .exe, which I don't want, so
* move the output file to it's rightful place.
* Notice that we do not use targetOS here, since we
* care about the platform we're running on, not the
* platform we're generating for.
*)
val _ =
if MLton.Platform.OS.host = Cygwin
then
if String.contains (output, #".")
then ()
else
File.move {from = concat [output, ".exe"],
to = output}
else ()
in
()
end
fun compileCSO (inputs: File.t list): unit =
if List.forall (inputs, fn f =>
SOME "o" = File.extension f)
then compileO inputs
else
let
val c = Counter.new 0
val oFiles =
trace (Top, "Compile C and Assemble")
(fn () =>
List.fold
(inputs, [], fn (input, ac) =>
let
val extension = File.extension input
in
if SOME "o" = extension
then input :: ac
else
let
val (debugSwitches, switches) =
if SOME "c" = extension
then
(gccDebug @ ["-DASSERT=1"],
ccOpts)
else ([asDebug], [])
val switches =
if !debug
then debugSwitches @ switches
else switches
val switches =
case target of
Cross s => "-b" :: s :: switches
| Self => switches
val switches = "-c" :: switches
val output =
if stop = Place.O orelse !keepO
then
if !keepGenerated
orelse start = Place.Generated
then
concat [String.dropSuffix
(input, 1),
"o"]
else
suffix
(concat [".",
Int.toString
(Counter.next c),
".o"])
else temp ".o"
val _ =
System.system
(gcc,
List.concat [switches,
["-o", output, input]])
in
output :: ac
end
end))
()
in
case stop of
Place.O => ()
| _ => compileO (rev oFiles)
end
fun compileSml (files: File.t list) =
let
val outputs: File.t list ref = ref []
val r = ref 0
fun make (style: style, suf: string) () =
let
val suf = concat [".", Int.toString (!r), suf]
val _ = Int.inc r
val file = (if !keepGenerated
orelse stop = Place.Generated
then suffix
else temp) suf
val _ = List.push (outputs, file)
val out = Out.openOut file
fun print s = Out.output (out, s)
val _ = outputHeader' (style, out)
fun done () = Out.close out
in
{file = file,
print = print,
done = done}
end
val _ =
case !verbosity of
Silent => ()
| Top => ()
| _ =>
outputHeader
(Control.No, fn l =>
let val out = Out.error
in Layout.output (l, out)
; Out.newline out
end)
val _ =
trace (Top, "Compile SML")
Compile.compile
{input = files,
outputC = make (Control.C, ".c"),
outputS = make (Control.Assembly,
if !debug then ".s" else ".S")}
(* Shrink the heap before calling gcc. *)
val _ = MLton.GC.pack ()
in
case stop of
Place.Generated => ()
| _ => compileCSO (List.concat [!outputs, csoFiles])
end
fun compileCM input =
let
val files = CM.cm {cmfile = input}
fun saveSML smlFile =
File.withOut
(smlFile, fn out =>
(outputHeader' (ML, out)
; (List.foreach
(files, fn f =>
(Out.output
(out, concat ["(*#line 0.0 \"", f, "\"*)\n"])
; File.outputContents (f, out))))))
in
case stop of
Place.Files =>
List.foreach
(files, fn f => print (concat [f, "\n"]))
| Place.SML => saveSML (maybeOut ".sml")
| _ =>
(if !keepSML
then saveSML (suffix ".sml")
else ()
; compileSml files)
end
fun compile () =
case start of
Place.CM => compileCM input
| Place.SML => compileSml [input]
| Place.Generated => compileCSO (input :: csoFiles)
| Place.O => compileCSO (input :: csoFiles)
| _ => Error.bug "invalid start"
val doit
= trace (Top, "MLton")
(fn () =>
DynamicWind.wind
(compile, fn () =>
List.foreach (!tempFiles, File.remove)))
in doit ()
end
end
end
val commandLine = Process.makeCommandLine commandLine
fun exportNJ (root: Dir.t, file: File.t): unit =
(Compile.forceBasisLibrary root
; SMLofNJ.exportFn (file, fn (_, args) => commandLine args))
fun exportMLton (): unit =
case CommandLine.arguments () of
[root, file] => exportNJ (root, file)
| _ => Error.bug "usage: exportMLton root file"
val _ =
let
open Trace.Immediate
in
debug := Out Out.error
; flagged ()
(* ; on ["setConTycon"] *)
(* ; on ["elaborateDec", "elaborateExp", "elaboratePat"] *)
(* ; on ["coalesce"] *)
(* ; on ["elaborateStrdec"] *)
(* ; on ["extendVar"] *)
(* ; on ["elaborateStrdec", "elaborateTopdec"] *)
(* ; on ["unify"] *)
(* ; on ["Scheme.instantiate"] *)
(* ; on ["Unknown.minTime"] *)
(* ; on ["Xml.checkExp", "Xml.checkPrimExp"] *)
(* ; on ["Xml.Shrink.varInfo", "Xml.Shrink.setVarInfo"] *)
end
fun doit () =
let
in
Compile.forceBasisLibrary "/home/sweeks/mlton/src/basis-library"
end
end
1.1 mlton/mlton/match-compile/match-compile.fun
Index: match-compile.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor MatchCompile (S: MATCH_COMPILE_STRUCTS): MATCH_COMPILE =
struct
open S
structure Env = MonoEnv (structure Domain = Var
structure Range = Var)
structure FlatPat =
struct
datatype t =
Any
| Const of Const.t
| Con of {arg: NestedPat.t option,
con: Con.t,
targs: Type.t vector}
| Tuple of NestedPat.t vector
fun layout p =
let
open Layout
in
case p of
Any => str "Any"
| Const c => Const.layout c
| Con {con, arg, ...} => seq [Con.layout con, str " ",
Option.layout NestedPat.layout arg]
| Tuple v => Vector.layout NestedPat.layout v
end
val isRefutable =
fn Any => false
| Const _ => true
| Con _ => true
| Tuple ps => Vector.exists (ps, NestedPat.isRefutable)
val isAny =
fn Any => true
| _ => false
(* get rid of Wild, Var, Layered - also remove unary tuples *)
fun flatten (var: Var.t, pat: NestedPat.t, env: Env.t): t * Env.t =
let
fun extend x = Env.extend (env, x, var)
in
case NestedPat.node pat of
NestedPat.Con x => (Con x, env)
| NestedPat.Const c => (Const c, env)
| NestedPat.Layered (x, p) => flatten (var, p, extend x)
| NestedPat.Tuple ps =>
if 1 = Vector.length ps
then flatten (var, Vector.sub (ps, 0), env)
else (Tuple ps, env)
| NestedPat.Var x => (Any, extend x)
| NestedPat.Wild => (Any, env)
end
fun flattens (vars: Var.t vector,
pats: NestedPat.t vector,
env: Env.t): t vector * Env.t =
Vector.map2AndFold (vars, pats, env, flatten)
end
structure Continue =
struct
datatype t =
Finish of (Var.t -> Var.t) -> Exp.t
| Matches of FlatPat.t vector option * t
fun layout c =
let
open Layout
in
case c of
Finish _ => str "Finish"
| Matches (opt, c) =>
seq [str "Matches",
tuple [Option.layout (Vector.layout FlatPat.layout) opt,
layout c]]
end
end
datatype z = datatype Continue.t
structure Info =
struct
datatype t = T of {accum: Env.t,
continue: Continue.t}
fun layout (T {accum, continue}) =
Layout.record [("accum", Env.layout accum),
("continue", Continue.layout continue)]
end
structure Rule =
struct
datatype t = T of {info: Info.t,
pat: NestedPat.t}
fun layout (T {info, pat}) =
Layout.record [("info", Info.layout info),
("pat", NestedPat.layout pat)]
end
structure FlatRule =
struct
datatype t = T of {info: Info.t,
pat: FlatPat.t}
local
fun make f (T r) = f r
in
val info = make #info
end
fun layout (T {info, pat}) =
Layout.record [("info", Info.layout info),
("pat", FlatPat.layout pat)]
end
structure Finish =
struct
type t = Info.t vector -> Exp.t
fun layout (_: t) = Layout.str "<finish>"
end
local
fun make (name, layout) =
Trace.trace4
(concat ["MatchCompile.", name],
layout, Type.layout, Vector.layout FlatRule.layout, Finish.layout,
Exp.layout)
in
val traceMatchFlat = make ("matchFlat", Var.layout)
val traceTuple = make ("tuple", Exp.layout)
val traceConst = make ("const", Exp.layout)
end
local
fun make (all, ty, inj, get) =
List.map (all, fn s =>
(ty s,
fn (cases, finish) =>
inj (s,
Vector.map
(cases, fn {const, infos: Info.t list} =>
(get const, finish (Vector.fromList infos))))))
in
val directCases =
make (List.remove (IntSize.all, fn s => IntSize.I64 = s),
Type.int, Cases.int,
fn Const.Int i => i
| _ => Error.bug "caseInt type error")
@ make (List.remove (WordSize.all, fn s => WordSize.W64 = s),
Type.word, Cases.word,
fn Const.Word w => w
| _ => Error.bug "caseWord type error")
end
(*---------------------------------------------------*)
(* matchCompile *)
(*---------------------------------------------------*)
fun matchCompile {caseType: Type.t,
cases: (NestedPat.t * ((Var.t -> Var.t) -> Exp.t)) vector,
conTycon: Con.t -> Tycon.t,
region: Region.t,
test: Var.t,
testType: Type.t,
tyconCons: Tycon.t -> Con.t vector}: Exp.t =
let
fun match (var: Var.t,
ty: Type.t,
rules: Rule.t vector,
finish: Finish.t): Exp.t =
let
val rules =
Vector.map
(rules, fn Rule.T {pat, info as Info.T {accum, continue}} =>
let
val (pat, accum) = FlatPat.flatten (var, pat, accum)
in
FlatRule.T {pat = pat,
info = Info.T {accum = accum,
continue = continue}}
end)
in matchFlat (var, ty, rules, finish)
end
and matchFlat arg: Exp.t =
traceMatchFlat
(fn (var: Var.t,
ty: Type.t,
rules: FlatRule.t vector,
finish: Finish.t) =>
let
val test = Exp.var (var, ty)
in
case Vector.peek (rules, fn FlatRule.T {pat, ...} =>
case pat of
FlatPat.Any => false
| _ => true) of
NONE => finish (Vector.map (rules, FlatRule.info))
| SOME (FlatRule.T {pat, info}) =>
case pat of
FlatPat.Any => Error.bug "matchFlat"
| FlatPat.Const _ => const (test, ty, rules, finish)
| FlatPat.Con _ => sum (test, rules, finish)
| FlatPat.Tuple ps => tuple (test, ty, rules, finish)
end) arg
and matches (vars: (Var.t * Type.t) vector,
rules: {pats: NestedPat.t vector option, info: Info.t} vector,
finish: Finish.t): Exp.t =
let
val rules =
Vector.map
(rules, fn {pats, info as Info.T {accum, continue}} =>
case pats of
NONE => {pats = NONE, info = info}
| SOME pats =>
let
val (pats, accum) =
FlatPat.flattens (Vector.map (vars, #1),
pats,
accum)
in {pats = SOME pats,
info = Info.T {accum = accum, continue = continue}}
end)
in matchesFlat (0, vars, rules, finish)
end
and matchesFlat (i: int,
vars: (Var.t * Type.t) vector,
rules: {pats: FlatPat.t vector option,
info: Info.t} vector,
finish: Finish.t): Exp.t =
if i = Vector.length vars
then finish (Vector.map (rules, #info))
else
let
val (var, ty) = Vector.sub (vars, i)
val rules =
Vector.map
(rules, fn {pats, info as Info.T {accum, continue}} =>
case pats of
NONE =>
FlatRule.T
{pat = FlatPat.Any,
info = Info.T {accum = accum,
continue =
Matches (NONE, continue)}}
| SOME pats =>
FlatRule.T
{pat = Vector.sub (pats, i),
info =
Info.T {accum = accum,
continue = Matches (SOME pats, continue)}})
in matchFlat
(var, ty, rules, fn infos =>
matchesFlat
(i + 1, vars,
Vector.map (infos, fn Info.T {accum, continue} =>
case continue of
Matches (pats, continue) =>
{pats = pats,
info = Info.T {accum = accum,
continue = continue}}
| _ => Error.bug "matchesFlat:"),
finish))
end
(*------------------------------------*)
(* tuple *)
(*------------------------------------*)
and tuple arg =
traceTuple
(fn (test: Exp.t,
ty: Type.t,
rules: FlatRule.t vector,
finish: Finish.t) =>
let
val rules =
Vector.map
(rules, fn FlatRule.T {pat, info} =>
case pat of
FlatPat.Any => {pats = NONE, info = info}
| FlatPat.Tuple pats => {pats = SOME pats, info = info}
| _ => Error.bug "expected tuple pattern")
in Exp.detuple
{tuple = test,
body = fn vars => matches (vars, rules, finish)}
end) arg
(*------------------------------------*)
(* sum *)
(*------------------------------------*)
and sum (test, rules: FlatRule.t vector, finish: Finish.t) =
let
datatype arg =
NoArg of Info.t list
| Arg of {var: Var.t,
ty: Type.t,
rules: Rule.t list}
val (cases, defaults) =
Vector.foldr
(rules, ([], []),
fn (FlatRule.T {pat, info}, (cases, defaults)) =>
case pat of
FlatPat.Any =>
(List.map
(cases, fn {con, tys, arg} =>
{con = con, tys = tys,
arg = (case arg of
NoArg infos => NoArg (info :: infos)
| Arg {var, ty, rules} =>
Arg {var = var,
ty = ty,
rules = Rule.T {pat = NestedPat.wild ty,
info = info} :: rules})}),
info :: defaults)
| FlatPat.Con {con=c, targs=tys, arg} =>
let
fun insert cases =
case cases of
[] =>
[{con = c, tys = tys,
arg =
(case arg of
NONE => NoArg (info :: defaults)
| SOME p =>
let val ty = NestedPat.ty p
in Arg {var = Var.newNoname (),
ty = ty,
rules =
Rule.T {pat = p, info = info}
:: (List.map
(defaults, fn info =>
Rule.T
{pat = NestedPat.wild ty,
info = info}))}
end)}]
| (cas as {con, tys, arg=a}) :: cases =>
if Con.equals (c, con)
then {con = con, tys = tys,
arg = (case (a, arg) of
(NoArg infos, NONE) =>
NoArg (info :: infos)
| (Arg {var, ty, rules},
SOME p) =>
Arg {var = var,
ty = ty,
rules =
Rule.T {pat = p,
info = info}
:: rules}
| _ => Error.bug "use of constructor with and without arg in pattern match")}
:: cases
else cas :: (insert cases)
in (insert cases, defaults)
end
| _ => Error.bug "expected constructor pat")
val cases = Vector.fromList cases
val defaults = Vector.fromList defaults
val default =
if Vector.isEmpty cases
then
SOME (finish defaults, region)
else
let
val {con, ...} = Vector.sub (cases, 0)
val tycon = conTycon con
in if Tycon.equals (tycon, Tycon.exn)
orelse Vector.length cases <> (Vector.length
(tyconCons tycon))
then SOME (finish defaults, region)
else NONE
end
fun normal () =
Exp.casee
{test = test, default = default,
ty = caseType,
cases =
Cases.con (Vector.map
(cases, fn {con, tys, arg} =>
let
val (arg, rhs) =
case arg of
NoArg infos =>
(NONE, finish (Vector.fromList infos))
| Arg {var, ty, rules} =>
(SOME (var, ty),
match (var, ty,
Vector.fromList rules,
finish))
in {con = con,
targs = tys,
arg = arg,
rhs = rhs}
end))}
in
if 1 = Vector.length cases
then
let
val {con, arg, ...} = Vector.sub (cases, 0)
in
case arg of
Arg {var, ty, rules} =>
if Con.equals (con, Con.reff)
then (Exp.lett
{var = var,
exp = Exp.deref test,
body = match (var, ty,
Vector.fromList rules,
finish)})
else normal ()
| _ => normal ()
end
else normal ()
end
(*------------------------------------*)
(* const *)
(*------------------------------------*)
and const arg =
traceConst
(fn (test: Exp.t,
ty: Type.t,
rules: FlatRule.t vector,
finish: Finish.t) =>
let
val (cases, defaults) =
Vector.foldr
(rules, ([], []),
fn (FlatRule.T {pat, info}, (cases, defaults)) =>
case pat of
FlatPat.Any =>
(List.map (cases, fn {const, infos} =>
{const = const, infos = info :: infos}),
info :: defaults)
| FlatPat.Const c =>
let
fun insert (cases, ac) =
case cases of
[] => Error.bug "match-compile insert"
| (casee as {const, infos}) :: cases =>
if Const.equals (c, const)
then
{const = c,
infos = info :: infos}
:: List.appendRev (ac, cases)
else insert (cases, casee :: ac)
val cases =
if List.exists (cases, fn {const, ...} =>
Const.equals (c, const))
then insert (cases, [])
else {const = c, infos = info :: defaults} :: cases
in (cases, defaults)
end
| _ => Error.bug "expected Const pat")
val default = finish (Vector.fromList defaults)
fun loop ds =
case ds of
[] =>
List.fold
(cases, default, fn ({const, infos}, rest) =>
Exp.iff {test = Exp.equal (test, Exp.const const),
thenn = finish (Vector.fromList infos),
elsee = rest,
ty = caseType})
| (ty', make) :: ds =>
if Type.equals (ty, ty')
then Exp.casee {test = test,
default = SOME (default, region),
ty = caseType,
cases = make (Vector.fromList cases,
finish)}
else loop ds
in loop directCases
end) arg
(*------------------------------------*)
(* main code for match compile *)
(*------------------------------------*)
in match (test, testType,
Vector.map (cases, fn (p, f) =>
Rule.T {pat = p,
info = Info.T {accum = Env.empty,
continue = Finish f}}),
fn infos =>
if Vector.isEmpty infos
then Error.bug "matchRules: no default"
else
let val Info.T {accum = env, continue} = Vector.sub (infos, 0)
in
case continue of
Finish f => f (fn x => Env.lookup (env, x))
| _ => Error.bug "matchRules: expecting Finish"
end)
end
val matchCompile =
Trace.trace
("matchCompile",
fn {cases, ...} => Vector.layout (NestedPat.layout o #1) cases,
Exp.layout)
matchCompile
end
1.1 mlton/mlton/match-compile/match-compile.sig
Index: match-compile.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
type int = Int.t
type word = Word.t
signature MATCH_COMPILE_STRUCTS =
sig
include ATOMS
structure Type:
sig
type t
val deTuple: t -> t vector
val equals: t * t -> bool
val int: IntSize.t -> t
val layout: t -> Layout.t
val word: WordSize.t -> t
end
structure Cases:
sig
type exp
type t
val con: {con: Con.t,
targs: Type.t vector,
arg: (Var.t * Type.t) option,
rhs: exp} vector -> t
val int: IntSize.t * (IntX.t * exp) vector -> t
val word: WordSize.t * (WordX.t * exp) vector -> t
end
structure Exp:
sig
type t
val const: Const.t -> t
val var: Var.t * Type.t -> t
val detuple: {tuple: t,
body: (Var.t * Type.t) vector -> t} -> t
val casee:
{cases: Cases.t,
default: (t * Region.t) option,
test: t,
ty: Type.t} (* type of entire case expression *)
-> t
val lett: {var: Var.t, exp: t, body: t} -> t
val iff: {test: t, thenn: t, elsee: t, ty: Type.t} -> t
val equal: t * t -> t
val deref: t -> t
val layout: t -> Layout.t
end
sharing type Cases.exp = Exp.t
structure NestedPat: NESTED_PAT
sharing Atoms = NestedPat.Atoms
sharing Type = NestedPat.Type
end
signature MATCH_COMPILE =
sig
include MATCH_COMPILE_STRUCTS
val matchCompile:
{caseType: Type.t, (* type of entire expression *)
cases: (NestedPat.t * ((Var.t -> Var.t) -> Exp.t)) vector,
conTycon: Con.t -> Tycon.t,
region: Region.t,
test: Var.t,
testType: Type.t,
tyconCons: Tycon.t -> Con.t vector}
-> Exp.t
end
1.1 mlton/mlton/match-compile/nested-pat.fun
Index: nested-pat.fun
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor NestedPat (S: NESTED_PAT_STRUCTS): NESTED_PAT =
struct
open S
datatype t = T of {pat: node, ty: Type.t}
and node =
Con of {arg: t option,
con: Con.t,
targs: Type.t vector}
| Const of Const.t
| Layered of Var.t * t
| Tuple of t vector
| Var of Var.t
| Wild
local
fun make f (T r) = f r
in
val node = make #pat
val ty = make #ty
end
fun tuple ps =
if 1 = Vector.length ps
then Vector.sub (ps, 0)
else T {pat = Tuple ps,
ty = Type.tuple (Vector.map (ps, ty))}
fun layout p =
let
open Layout
in
case node p of
Con {arg, con, targs} =>
Pretty.conApp {arg = Option.map (arg, layout),
con = Con.layout con,
targs = Vector.map (targs, Type.layout)}
| Const c => Const.layout c
| Layered (x, p) => seq [Var.layout x, str " as ", layout p]
| Tuple ps => tuple (Vector.toListMap (ps, layout))
| Var x => Var.layout x
| Wild => str "_"
end
fun make (p, t) =
case p of
Tuple ps =>
if 1 = Vector.length ps
then Vector.sub (ps, 0)
else T {pat = p, ty = t}
| _ => T {pat = p, ty = t}
fun wild t = make (Wild, t)
fun isRefutable p =
case node p of
Wild => false
| Var _ => false
| Const _ => true
| Con _ => true
| Tuple ps => Vector.exists (ps, isRefutable)
| Layered (_, p) => isRefutable p
fun isVar p =
case node p of
Var _ => true
| _ => false
val unit =
T {pat = Tuple (Vector.new0 ()),
ty = Type.tuple (Vector.new0 ())}
fun removeOthersReplace (p, {new, old}) =
let
fun loop (T {pat, ty}) =
let
val pat =
case pat of
Con {arg, con, targs} =>
Con {arg = Option.map (arg, loop),
con = con,
targs = targs}
| Const _ => pat
| Layered (x, p) =>
let
val p = loop p
in
if Var.equals (x, old)
then Layered (new, p)
else node p
end
| Tuple ps => Tuple (Vector.map (ps, loop))
| Var x =>
if Var.equals (x, old)
then Var new
else Wild
| Wild => Wild
in
T {pat = pat, ty = ty}
end
in
loop p
end
val removeOthersReplace =
Trace.trace ("NestedPat.removeOthersReplace", fn (p, _) => layout p, layout)
removeOthersReplace
local
val bogus = Var.newNoname ()
in
fun removeVars (p: t): t =
removeOthersReplace (p, {new = bogus, old = bogus})
end
fun replaceTypes (p: t, f: Type.t -> Type.t): t =
let
fun loop (T {pat, ty}) =
let
val pat =
case pat of
Con {arg, con, targs} =>
Con {arg = Option.map (arg, loop),
con = con,
targs = Vector.map (targs, f)}
| Const _ => pat
| Layered (x, p) => Layered (x, loop p)
| Tuple ps => Tuple (Vector.map (ps, loop))
| Var x => Var x
| Wild => Wild
in
T {pat = pat, ty = f ty}
end
in
loop p
end
fun varsAndTypes (p: t): (Var.t * Type.t) list =
let
fun loop (p: t, accum: (Var.t * Type.t) list) =
case node p of
Wild => accum
| Const _ => accum
| Var x => (x, ty p) :: accum
| Tuple ps => Vector.fold (ps, accum, loop)
| Con {arg, ...} => (case arg of
NONE => accum
| SOME p => loop (p, accum))
| Layered (x, p) => loop (p, (x, ty p) :: accum)
in loop (p, [])
end
fun vars (p: t): Var.t list =
List.revMap (varsAndTypes p, #1)
end
1.1 mlton/mlton/match-compile/nested-pat.sig
Index: nested-pat.sig
===================================================================
(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
signature NESTED_PAT_STRUCTS =
sig
include ATOMS
structure Type:
sig
type t
val layout: t -> Layout.t
val tuple: t vector -> t
end
end
signature NESTED_PAT =
sig
include NESTED_PAT_STRUCTS
datatype t = T of {pat: node, ty: Type.t}
and node =
Con of {arg: t option,
con: Con.t,
targs: Type.t vector}
| Const of Const.t
| Layered of Var.t * t
| Tuple of t vector
| Var of Var.t
| Wild
(* isRefutable p iff p contains a constant, constructor or variable. *)
val isRefutable: t -> bool
val isVar: t -> bool
val layout: t -> Layout.t
val make: node * Type.t -> t
val node: t -> node
val removeOthersReplace: t * {new: Var.t, old: Var.t} -> t
val removeVars: t -> t
val replaceTypes: t * (Type.t -> Type.t) -> t
val tuple: t vector -> t
val ty: t -> Type.t
val unit: t
(* varsAndTypes returns a list of the variables in the pattern, along with
* their types. It is used for match compilation in order to build a
* function that abstracts over the expression of a case rule p => e.
* See infer.fun.
*)
val varsAndTypes: t -> (Var.t * Type.t) list
val wild: Type.t -> t
end
1.1 mlton/mlton/match-compile/sources.cm
Index: sources.cm
===================================================================
Group
functor MatchCompile
functor NestedPat
is
../atoms/sources.cm
../control/sources.cm
../../lib/mlton/sources.cm
match-compile.fun
match-compile.sig
nested-pat.fun
nested-pat.sig
1.17 +2 -2 mlton/mlton/ssa/constant-propagation.fun
Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- constant-propagation.fun 23 Jun 2003 04:58:59 -0000 1.16
+++ constant-propagation.fun 9 Oct 2003 18:17:34 -0000 1.17
@@ -350,7 +350,7 @@
Exp.PrimApp {args = args,
prim = Prim.array,
targs = targs},
- Type.dearray ty)
+ Type.deArray ty)
| Const (Const.T {const, ...}) =>
(case !const of
Const.Const c => yes (Exp.Const c)
@@ -371,7 +371,7 @@
Exp.PrimApp {args = args,
prim = Prim.reff,
targs = targs},
- Type.deref ty)
+ Type.deRef ty)
| Tuple vs =>
(case globals (vs, newGlobal) of
NONE => No
1.15 +2 -2 mlton/mlton/ssa/direct-exp.fun
Index: direct-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/direct-exp.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- direct-exp.fun 23 Jun 2003 04:58:59 -0000 1.14
+++ direct-exp.fun 9 Oct 2003 18:17:34 -0000 1.15
@@ -338,7 +338,7 @@
fun selects (tuple: Var.t, ty: Type.t, components: Var.t vector)
: Statement.t list =
let
- val ts = Type.detuple ty
+ val ts = Type.deTuple ty
in
Vector.foldi
(ts, [], fn (i, t, ss) =>
@@ -544,7 +544,7 @@
val l = reify (k, ty)
val k = Cont.goto l
val (args, exps) =
- case Type.detupleOpt ty of
+ case Type.deTupleOpt ty of
NONE =>
let
val res = Var.newNoname ()
1.13 +5 -5 mlton/mlton/ssa/flatten.fun
Index: flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/flatten.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- flatten.fun 10 Jan 2003 18:36:13 -0000 1.12
+++ flatten.fun 9 Oct 2003 18:17:34 -0000 1.13
@@ -36,7 +36,7 @@
val isFlat = not o isTop
fun fromType t =
- case Type.detupleOpt t of
+ case Type.deTupleOpt t of
NONE => let val r = new () in makeTop r; r end
| SOME l => new ()
@@ -214,7 +214,7 @@
Vector.fromList
(Vector.fold2 (ts, rs, [], fn (t, r, ts) =>
if Rep.isFlat r
- then Vector.fold (Type.detuple t, ts, op ::)
+ then Vector.fold (Type.deTuple t, ts, op ::)
else t :: ts))
val datatypes =
Vector.map
@@ -265,7 +265,7 @@
(args, reps, ([], []), fn ((x, ty), r, (args, stmts)) =>
if Rep.isFlat r
then let
- val tys = Type.detuple ty
+ val tys = Type.deTuple ty
val xs = Vector.map (tys, fn _ => Var.newNoname ())
val _ = varTuple x := SOME xs
val args =
@@ -316,7 +316,7 @@
let
val xts =
Vector.map
- (Type.detuple ty, fn ty =>
+ (Type.deTuple ty, fn ty =>
(Var.newNoname (), ty))
val xs = Vector.map (xts, #1)
val formals =
@@ -349,7 +349,7 @@
let
val xts =
Vector.map
- (Type.detuple ty, fn ty =>
+ (Type.deTuple ty, fn ty =>
(Var.newNoname (), ty))
val xs = Vector.map (xts, #1)
val actuals =
1.16 +2 -2 mlton/mlton/ssa/local-flatten.fun
Index: local-flatten.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/local-flatten.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- local-flatten.fun 19 Dec 2002 23:43:36 -0000 1.15
+++ local-flatten.fun 9 Oct 2003 18:17:34 -0000 1.16
@@ -192,7 +192,7 @@
else
let
val vars = Vector.map
- (Type.detuple ty, fn ty =>
+ (Type.deTuple ty, fn ty =>
(Var.newNoname (), ty))
in
(vars,
@@ -220,7 +220,7 @@
let
val (vars, stmts) =
Vector.foldi
- (Type.detuple t, ([], stmts),
+ (Type.deTuple t, ([], stmts),
fn (i, ty, (vars, stmts)) =>
let val var = Var.newNoname ()
in (var :: vars,
1.19 +1 -1 mlton/mlton/ssa/local-ref.fun
Index: local-ref.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/local-ref.fun,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- local-ref.fun 19 Dec 2002 23:43:36 -0000 1.18
+++ local-ref.fun 9 Oct 2003 18:17:34 -0000 1.19
@@ -317,7 +317,7 @@
= Option.app
(var, fn var =>
let
- val vi = VarInfo.new (SOME (label, Type.deref ty))
+ val vi = VarInfo.new (SOME (label, Type.deRef ty))
val _ = setVarInfo (var, vi)
in
List.push (refs, var) ;
1.32 +1 -1 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -r1.31 -r1.32
--- shrink.fun 23 Jun 2003 04:58:59 -0000 1.31
+++ shrink.fun 9 Oct 2003 18:17:34 -0000 1.32
@@ -1227,7 +1227,7 @@
NONE =>
(case VarInfo.ty tuple of
SOME ty =>
- (case Type.detupleOpt ty of
+ (case Type.deTupleOpt ty of
SOME ts =>
if Vector.length xs =
Vector.length ts
1.13 +1 -1 mlton/mlton/ssa/simplify-types.fun
Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/simplify-types.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- simplify-types.fun 13 May 2003 20:20:15 -0000 1.12
+++ simplify-types.fun 9 Oct 2003 18:17:34 -0000 1.13
@@ -545,7 +545,7 @@
end)
| Select {tuple, offset} =>
let
- val ts = Type.detuple (oldVarType tuple)
+ val ts = Type.deTuple (oldVarType tuple)
in Vector.fold'
(ts, 0, (offset, 0), fn (pos, t, (n, offset)) =>
if n = 0
1.60 +1 -3 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- ssa-tree.fun 23 Jun 2003 04:58:59 -0000 1.59
+++ ssa-tree.fun 9 Oct 2003 18:17:34 -0000 1.60
@@ -299,9 +299,7 @@
then empty
else Vector.layout Type.layout targs
else empty,
- if isSome (Prim.numArgs prim)
- then seq [str " ", layoutTuple args]
- else empty]
+ seq [str " ", layoutTuple args]]
| Profile p => ProfileExp.layout p
| Select {tuple, offset} =>
seq [str "#", Int.layout (offset + 1), str " ",
1.25 +2 -17 mlton/mlton/ssa/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- type-check.fun 10 Sep 2003 01:00:12 -0000 1.24
+++ type-check.fun 9 Oct 2003 18:17:34 -0000 1.25
@@ -341,7 +341,7 @@
end,
Unit.layout) coerce
fun select {tuple: Type.t, offset: int, resultType}: Type.t =
- case Type.detupleOpt tuple of
+ case Type.deTupleOpt tuple of
NONE => error "select of non tuple"
| SOME ts => Vector.sub (ts, offset)
val {get = conInfo: Con.t -> {args: Type.t vector,
@@ -373,22 +373,7 @@
in ()
end
fun filterGround to (t: Type.t): unit = coerce {from = t, to = to}
- fun primApp {prim, targs, args, resultType, resultVar} =
- case Prim.checkApp {prim = prim,
- targs = targs,
- args = args,
- con = Type.con,
- equals = Type.equals,
- dearrowOpt = Type.dearrowOpt,
- detupleOpt = Type.detupleOpt,
- isUnit = Type.isUnit
- } of
- NONE => error (concat
- ["bad primapp ",
- Prim.toString prim,
- ", args = ",
- Layout.toString (Vector.layout Type.layout args)])
- | SOME t => t
+ fun primApp {prim, targs, args, resultType, resultVar} = resultType
val primApp =
Trace.trace ("checkPrimApp",
fn {prim, targs, args, ...} =>
1.20 +5 -5 mlton/mlton/ssa/useless.fun
Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- useless.fun 23 Jun 2003 04:58:59 -0000 1.19
+++ useless.fun 9 Oct 2003 18:17:34 -0000 1.20
@@ -771,11 +771,11 @@
targs = Prim.extractTargs {prim = prim,
args = argTypes,
result = resultType,
- dearray = Type.dearray,
- dearrow = Type.dearrow,
- deref = Type.deref,
- devector = Type.devector,
- deweak = Type.deweak}}
+ deArray = Type.deArray,
+ deArrow = Type.deArrow,
+ deRef = Type.deRef,
+ deVector = Type.deVector,
+ deWeak = Type.deWeak}}
end
| Select {tuple, offset} =>
let
1.10 +9 -7 mlton/mlton/xml/implement-exceptions.fun
Index: implement-exceptions.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/implement-exceptions.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- implement-exceptions.fun 23 Jun 2003 04:59:00 -0000 1.9
+++ implement-exceptions.fun 9 Oct 2003 18:17:34 -0000 1.10
@@ -226,11 +226,13 @@
| SOME e => SOME (loop e))
and loops es = List.map (es, loop)
and loop (e: Exp.t): Exp.t =
- let val {decs, result} = Exp.dest e
+ let
+ val {decs, result} = Exp.dest e
val decs = List.concatRev (List.fold (decs, [], fn (d, ds) =>
loopDec d :: ds))
- in Exp.new {decs = decs,
- result = result}
+ in
+ Exp.make {decs = decs,
+ result = result}
end
and loopDec (dec: Dec.t): Dec.t list =
case dec of
@@ -438,9 +440,9 @@
let
val {arg, argType, body} = Lambda.dest l
in
- Lambda.new {arg = arg,
- argType = argType,
- body = loop body}
+ Lambda.make {arg = arg,
+ argType = argType,
+ body = loop body}
end
val body =
let
@@ -489,7 +491,7 @@
val exn = Var.newNoname ()
in
Lambda
- (Lambda.new
+ (Lambda.make
{arg = exn,
argType = Type.exn,
body =
1.10 +13 -9 mlton/mlton/xml/monomorphise.fun
Index: monomorphise.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/monomorphise.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- monomorphise.fun 23 Jun 2003 04:59:00 -0000 1.9
+++ monomorphise.fun 9 Oct 2003 18:17:34 -0000 1.10
@@ -10,7 +10,8 @@
open S
open Xml.Atoms
-local open Xml
+local
+ open Xml
in
structure Xcases = Cases
structure Xpat = Pat
@@ -22,7 +23,8 @@
structure Xtype = Type
structure XvarExp = VarExp
end
-local open Sxml
+local
+ open Sxml
in
structure Scases = Cases
structure Spat = Pat
@@ -185,7 +187,7 @@
Property.destGetSet (Tycon.plist,
Property.initRaise ("mono", Tycon.layout))
val _ =
- List.foreach (Tycon.prims, fn t =>
+ List.foreach (Tycon.prims, fn (t, _) =>
setTycon (t, fn ts => Stype.con (t, ts)))
val {set = setTyvar, get = getTyvar: Tyvar.t -> Stype.t, ...} =
Property.getSet (Tyvar.plist,
@@ -344,14 +346,16 @@
fun monoExp (arg: Xexp.t): Sexp.t =
traceMonoExp
(fn (e: Xexp.t) =>
- let val {decs, result} = Xexp.dest e
+ let
+ val {decs, result} = Xexp.dest e
val thunks = List.fold (decs, [], fn (d, thunks) =>
monoDec d :: thunks)
val result = monoVarExp result
val decs =
List.fold (thunks, [], fn (thunk, decs) => thunk () @ decs)
- in Sexp.new {decs = decs,
- result = result}
+ in
+ Sexp.make {decs = decs,
+ result = result}
end) arg
and monoPrimExp (e: XprimExp.t): SprimExp.t =
case e of
@@ -403,9 +407,9 @@
val {arg, argType, body} = Xlambda.dest l
val (arg, argType) = renameMono (arg, argType)
in
- Slambda.new {arg = arg,
- argType = argType,
- body = monoExp body}
+ Slambda.make {arg = arg,
+ argType = argType,
+ body = monoExp body}
end
(*------------------------------------*)
(* monoDec *)
1.12 +8 -6 mlton/mlton/xml/polyvariance.fun
Index: polyvariance.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/polyvariance.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- polyvariance.fun 23 Jun 2003 04:59:00 -0000 1.11
+++ polyvariance.fun 9 Oct 2003 18:17:34 -0000 1.12
@@ -24,7 +24,7 @@
fun containsArrow t = containsTycon (t, Tycon.arrow)
fun isHigherOrder t =
- case dearrowOpt t of
+ case deArrowOpt t of
NONE => false
| SOME (t1, t2) => containsArrow t1 orelse isHigherOrder t2
@@ -264,16 +264,18 @@
then setVarInfo (var, Dup {duplicates = ref []})
else (bind var; ())
fun loopExp (e: Exp.t): Exp.t =
- let val {decs, result} = Exp.dest e
- in Exp.new (loopDecs (decs, result))
+ let
+ val {decs, result} = Exp.dest e
+ in
+ Exp.make (loopDecs (decs, result))
end
and loopLambda (l: Lambda.t): Lambda.t =
let
val {arg, argType, body} = Lambda.dest l
in
- Lambda.new {arg = bind arg,
- argType = argType,
- body = loopExp body}
+ Lambda.make {arg = bind arg,
+ argType = argType,
+ body = loopExp body}
end
and loopDecs (ds: Dec.t list, result): {decs: Dec.t list,
result: VarExp.t} =
1.10 +9 -7 mlton/mlton/xml/scc-funs.fun
Index: scc-funs.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/scc-funs.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- scc-funs.fun 12 Feb 2003 05:11:29 -0000 1.9
+++ scc-funs.fun 9 Oct 2003 18:17:34 -0000 1.10
@@ -18,7 +18,7 @@
let
(* For each function appearing in a fun dec record its node, which will
* have edges to the nodes of other functions declared in the same dec
- * if they appear in it's body.
+ * if they appear in its body.
*)
val {get = funInfo: Var.t -> {
node: unit Node.t,
@@ -39,9 +39,9 @@
let
val {arg, argType, body} = Lambda.dest l
in
- Lambda.new {arg = arg,
- argType = argType,
- body = loopExp body}
+ Lambda.make {arg = arg,
+ argType = argType,
+ body = loopExp body}
end
and loopPrimExp (e: PrimExp.t): PrimExp.t =
case e of
@@ -66,7 +66,8 @@
| Tuple xs => (loopVarExps xs; e)
| Var x => (loopVarExp x; e)
and loopExp (e: Exp.t): Exp.t =
- let val {decs, result} = Exp.dest e
+ let
+ val {decs, result} = Exp.dest e
val decs =
List.rev
(List.fold
@@ -116,9 +117,10 @@
end))
val _ = loopVarExp result
in
- Exp.new {decs = decs, result = result}
+ Exp.make {decs = decs, result = result}
end
- in Program.T {datatypes = datatypes,
+ in
+ Program.T {datatypes = datatypes,
body = loopExp body,
overflow = overflow}
end
1.3 +77 -49 mlton/mlton/xml/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/shrink.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- shrink.fun 23 Jun 2003 04:59:00 -0000 1.2
+++ shrink.fun 9 Oct 2003 18:17:34 -0000 1.3
@@ -76,7 +76,7 @@
fn (i, n) =>
case i of
Mono {numOccurrences = r, ...} => inc (r, n)
- | _ => ()
+ | Poly _ => ()
val inc =
Trace.trace2 ("VarInfo.inc", layout, Int.layout, Unit.layout) inc
@@ -92,6 +92,17 @@
| Poly x => x
end
+structure InternalVarInfo =
+ struct
+ datatype t =
+ VarInfo of VarInfo.t
+ | Self
+
+ val layout =
+ fn VarInfo i => VarInfo.layout i
+ | Self => Layout.str "self"
+ end
+
structure MonoVarInfo =
struct
type t = VarInfo.monoVarInfo
@@ -136,20 +147,24 @@
andalso (Vector.length v
= conNumCons (Pat.con (#1 (Vector.sub (v, 0)))))))
| _ => false
- val {get = varInfo: Var.t -> VarInfo.t, set = setVarInfo, ...} =
+ val {get = varInfo: Var.t -> InternalVarInfo.t, set = setVarInfo, ...} =
Property.getSet (Var.plist,
Property.initRaise ("shrink varInfo", Var.layout))
+ val setVarInfo =
+ Trace.trace2 ("Xml.Shrink.setVarInfo",
+ Var.layout, InternalVarInfo.layout, Unit.layout)
+ setVarInfo
val varInfo =
- Trace.trace ("Xml.Shrink.varInfo", Var.layout, VarInfo.layout) varInfo
+ Trace.trace ("Xml.Shrink.varInfo", Var.layout, InternalVarInfo.layout)
+ varInfo
fun monoVarInfo x =
case varInfo x of
- VarInfo.Mono i => i
+ InternalVarInfo.VarInfo (VarInfo.Mono i) => i
| _ => Error.bug "monoVarInfo"
- fun varInfos xs = List.map (xs, varInfo)
- fun varExpInfo (x as VarExp.T {var, targs, ...}): VarInfo.t =
- if Vector.isEmpty targs
- then varInfo var
- else VarInfo.Poly x
+ fun varExpInfo (x as VarExp.T {var, ...}): VarInfo.t =
+ case varInfo var of
+ InternalVarInfo.Self => VarInfo.Poly x
+ | InternalVarInfo.VarInfo i => i
val varExpInfo =
Trace.trace ("varExpInfo", VarExp.layout, VarInfo.layout) varExpInfo
fun varExpInfos xs = Vector.map (xs, varExpInfo)
@@ -157,7 +172,7 @@
{numOccurrences = r, ...}: MonoVarInfo.t,
i: VarInfo.t): unit =
(VarInfo.inc (i, !r)
- ; setVarInfo (x, i))
+ ; setVarInfo (x, InternalVarInfo.VarInfo i))
val replaceInfo =
Trace.trace ("replaceInfo",
fn (x, _, i) => Layout.tuple [Var.layout x,
@@ -167,16 +182,16 @@
fun replace (x, i) = replaceInfo (x, monoVarInfo x, i)
val shrinkVarExp = VarInfo.varExp o varExpInfo
fun shrinkVarExps xs = Vector.map (xs, shrinkVarExp)
- val dummyVarExp = VarExp.mono (Var.newString "dummy")
local
fun handleBoundVar (x, ts, ty) =
setVarInfo (x,
if Vector.isEmpty ts
- then VarInfo.Mono {numOccurrences = ref 0,
- value = ref NONE,
- varExp = VarExp.mono x}
- else VarInfo.Poly dummyVarExp)
- fun handleVarExp x = VarInfo.inc (varInfo (VarExp.var x), 1)
+ then (InternalVarInfo.VarInfo
+ (VarInfo.Mono {numOccurrences = ref 0,
+ value = ref NONE,
+ varExp = VarExp.mono x}))
+ else InternalVarInfo.Self)
+ fun handleVarExp x = VarInfo.inc (varExpInfo x, 1)
in
fun countExp (e: Exp.t): unit =
Exp.foreach {exp = e,
@@ -186,7 +201,7 @@
handleVarExp = handleVarExp}
end
fun deleteVarExp (x: VarExp.t): unit =
- VarInfo.inc (varInfo (VarExp.var x), ~1)
+ VarInfo.inc (varExpInfo x, ~1)
fun deleteExp (e: Exp.t): unit = Exp.foreachVarExp (e, deleteVarExp)
val deleteExp =
Trace.trace ("deleteExp", Exp.layout, Unit.layout) deleteExp
@@ -197,9 +212,11 @@
fun shrinkExp arg: Exp.t =
traceShrinkExp
(fn (e: Exp.t) =>
- let val {decs, result} = Exp.dest e
- in Exp.new {decs = shrinkDecs decs,
- result = shrinkVarExp result}
+ let
+ val {decs, result} = Exp.dest e
+ in
+ Exp.make {decs = shrinkDecs decs,
+ result = shrinkVarExp result}
end) arg
and shrinkDecs (decs: Dec.t list): Dec.t list =
case decs of
@@ -275,7 +292,7 @@
| MonoVal b =>
shrinkMonoVal (b, fn () => shrinkDecs decs)
and shrinkMonoVal ({var, ty, exp},
- rest: unit -> Dec.t list) =
+ rest: unit -> Dec.t list) =
let
val info as {numOccurrences, value, ...} = monoVarInfo var
fun finish (exp, decs) =
@@ -308,7 +325,28 @@
end
in
case exp of
- Case {test, cases, default} =>
+ App {func, arg} =>
+ let
+ val arg = varExpInfo arg
+ fun normal func =
+ expansive (App {func = func,
+ arg = VarInfo.varExp arg})
+ in case varExpInfo func of
+ VarInfo.Poly x => normal x
+ | VarInfo.Mono {numOccurrences, value, varExp, ...} =>
+ case (!numOccurrences, !value) of
+ (1, SOME (Value.Lambda {isInlined, lam = l})) =>
+ let
+ val {arg = form, body, ...} = Lambda.dest l
+ in VarInfo.inc (arg, ~1)
+ ; replace (form, arg)
+ ; isInlined := true
+ ; numOccurrences := 0
+ ; expression body
+ end
+ | _ => normal varExp
+ end
+ | Case {test, cases, default} =>
let
fun match (cases, f): Dec.t list =
let
@@ -448,27 +486,6 @@
; VarInfo.inc (x, ~1)
; rest ()
end
- | App {func, arg} =>
- let
- val arg = varExpInfo arg
- fun normal func =
- expansive (App {func = func,
- arg = VarInfo.varExp arg})
- in case varExpInfo func of
- VarInfo.Poly x => normal x
- | VarInfo.Mono {numOccurrences, value, varExp, ...} =>
- case (!numOccurrences, !value) of
- (1, SOME (Value.Lambda {isInlined, lam = l})) =>
- let
- val {arg = form, body, ...} = Lambda.dest l
- in VarInfo.inc (arg, ~1)
- ; replace (form, arg)
- ; isInlined := true
- ; numOccurrences := 0
- ; expression body
- end
- | _ => normal varExp
- end
end
and shrinkLambda l: Lambda.t =
traceShrinkLambda
@@ -476,16 +493,27 @@
let
val {arg, argType, body} = Lambda.dest l
in
- Lambda.new {arg = arg,
- argType = argType,
- body = shrinkExp body}
+ Lambda.make {arg = arg,
+ argType = argType,
+ body = shrinkExp body}
end) l
val _ = countExp body
- val _ = Option.app (overflow, fn x => VarInfo.inc (varInfo x, 1))
+ val _ =
+ Option.app
+ (overflow, fn x =>
+ case varInfo x of
+ InternalVarInfo.VarInfo i => VarInfo.inc (i, 1)
+ | _ => Error.bug "strange overflow var")
val body = shrinkExp body
+ (* Must lookup the overflow variable again because it may have been set
+ * during shrinking.
+ *)
val overflow =
- Option.map (overflow, fn x =>
- VarExp.var (VarInfo.varExp (varInfo x)))
+ Option.map
+ (overflow, fn x =>
+ case varInfo x of
+ InternalVarInfo.VarInfo i => VarExp.var (VarInfo.varExp i)
+ | _ => Error.bug "strange overflow var")
val _ = Exp.clear body
val _ = Vector.foreach (datatypes, fn {cons, ...} =>
Vector.foreach (cons, Con.clear o #con))
1.8 +5 -5 mlton/mlton/xml/simplify-types.fun
Index: simplify-types.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/simplify-types.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- simplify-types.fun 23 Jun 2003 04:59:00 -0000 1.7
+++ simplify-types.fun 9 Oct 2003 18:17:34 -0000 1.8
@@ -229,16 +229,16 @@
let
val {decs, result} = I.Exp.dest e
in
- O.Exp.new {decs = List.map (decs, fixDec),
- result = fixVarExp result}
+ O.Exp.make {decs = List.map (decs, fixDec),
+ result = fixVarExp result}
end
and fixLambda (l: I.Lambda.t): O.Lambda.t =
let
val {arg, argType, body} = I.Lambda.dest l
in
- O.Lambda.new {arg = arg,
- argType = fixType argType,
- body = fixExp body}
+ O.Lambda.make {arg = arg,
+ argType = fixType argType,
+ body = fixExp body}
end
and fixPrimExp (e: I.PrimExp.t): O.PrimExp.t =
case e of
1.14 +20 -30 mlton/mlton/xml/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- type-check.fun 14 Jul 2003 20:42:17 -0000 1.13
+++ type-check.fun 9 Oct 2003 18:17:34 -0000 1.14
@@ -58,8 +58,8 @@
end
val {get = getVar: Var.t -> {tyvars: Tyvar.t vector, ty: Type.t},
set = setVar, ...} =
- Property.getSetOnce (Var.plist,
- Property.initRaise ("var scheme", Var.layout))
+ Property.getSet (Var.plist,
+ Property.initRaise ("var scheme", Var.layout))
(* val getVar = Trace.trace ("getVar", Var.layout, Layout.ignore) getVar *)
(* val setVar = Trace.trace2 ("setVar", Var.layout, Layout.ignore, Layout.ignore) setVar *)
fun checkVarExp (VarExp.T {var, targs}): Type.t =
@@ -83,7 +83,7 @@
let
val t = checkConExp (con, targs)
in
- case (arg, Type.dearrowOpt t) of
+ case (arg, Type.deArrowOpt t) of
(NONE, NONE) => t
| (SOME (x, ty), SOME (t1, t2)) =>
(checkType ty
@@ -93,8 +93,8 @@
else (Type.error
("argument constraint of wrong type",
let open Layout
- in align [seq [str "t1: ", Type.layout t1],
- seq [str "ty: ", Type.layout ty],
+ in align [seq [str "constructor expects : ", Type.layout t1],
+ seq [str "but got: ", Type.layout ty],
seq [str "p: ", Pat.layout p]]
end)))
| _ => Type.error ("constructor pattern mismatch", Pat.layout p)
@@ -139,7 +139,7 @@
let
val t2 = checkVarExp x
in
- case Type.dearrowOpt t1 of
+ case Type.deArrowOpt t1 of
NONE => error "function not of arrow type"
| SOME (t2', t3) =>
if Type.equals (t2, t2') then t3
@@ -224,30 +224,20 @@
else error "bad handle"
end
| Lambda l => checkLambda l
- | PrimApp {prim, targs, args} =>
+ | PrimApp {prim, targs, args} =>
let
val _ = checkTypes targs
in
- case Prim.checkApp {prim = prim,
- targs = targs,
- args = checkVarExps args,
- con = Type.con,
- equals = Type.equals,
- dearrowOpt = Type.dearrowOpt,
- detupleOpt = Type.detupleOpt,
- isUnit = Type.isUnit
- } of
- NONE => error "bad primapp"
- | SOME t => t
+ ty
end
| Profile _ => Type.unit
| Raise {exn, ...} => if isExnType (checkVarExp exn)
then ty
else error "bad raise"
| Select {tuple, offset} =>
- (case Type.detupleOpt (checkVarExp tuple) of
- SOME ts => Vector.sub (ts, offset)
- | NONE => error "selection from nontuple")
+ (case Type.deTupleOpt (checkVarExp tuple) of
+ NONE => error "selection from nontuple"
+ | SOME ts => Vector.sub (ts, offset))
| Tuple xs =>
if 1 = Vector.length xs
then error "unary tuple"
@@ -268,6 +258,15 @@
in
case d of
Exception c => setCon (c, Vector.new0 (), Type.exn)
+ | Fun {tyvars, decs} =>
+ (bindTyvars tyvars
+ ; (Vector.foreach
+ (decs, fn {lambda, ty, var} =>
+ (checkType ty
+ ; setVar (var, {tyvars = tyvars, ty = ty}))))
+ ; Vector.foreach (decs, fn {ty, lambda, ...} =>
+ check (ty, checkLambda lambda))
+ ; unbindTyvars tyvars)
| MonoVal {var, ty, exp} =>
(checkType ty
; check (ty, checkPrimExp (exp, ty))
@@ -278,15 +277,6 @@
; check (ty, checkExp exp)
; unbindTyvars tyvars
; setVar (var, {tyvars = tyvars, ty = ty}))
- | Fun {tyvars, decs} =>
- (bindTyvars tyvars
- ; (Vector.foreach
- (decs, fn {var, ty, lambda} =>
- (checkType ty
- ; setVar (var, {tyvars = tyvars, ty = ty}))))
- ; Vector.foreach (decs, fn {ty, lambda, ...} =>
- check (ty, checkLambda lambda))
- ; unbindTyvars tyvars)
end handle e => (Layout.outputl (Dec.layout d, Out.error)
; raise e)
val _ =
1.17 +197 -253 mlton/mlton/xml/xml-tree.fun
Index: xml-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.fun,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- xml-tree.fun 23 Jun 2003 04:59:00 -0000 1.16
+++ xml-tree.fun 9 Oct 2003 18:17:34 -0000 1.17
@@ -9,13 +9,6 @@
struct
open S
-local open Ast
-in
- structure Adec = Dec
- structure Aexp = Exp
- structure Amatch = Match
- structure Apat = Pat
-end
structure Type =
struct
@@ -32,35 +25,40 @@
| Dest.Con x => Con x
end
+fun maybeConstrain (x, t) =
+ let
+ open Layout
+ in
+ if !Control.showTypes
+ then seq [x, str ": ", Type.layout t]
+ else x
+ end
+
structure Pat =
struct
- structure Apat = Ast.Pat
-
- datatype t = T of {con: Con.t,
- targs: Type.t vector,
- arg: (Var.t * Type.t) option}
+ datatype t = T of {arg: (Var.t * Type.t) option,
+ con: Con.t,
+ targs: Type.t vector}
+ local
+ open Layout
+ in
+ fun layout (T {arg, con, targs}) =
+ seq [Con.layout con,
+ case arg of
+ NONE => empty
+ | SOME (x, t) =>
+ maybeConstrain (seq [str " ", Var.layout x], t)]
+ end
+
fun con (T {con, ...}) = con
- local fun make c = T {con = c, targs = Vector.new0 (), arg = NONE}
- in val truee = make Con.truee
+ local
+ fun make c = T {con = c, targs = Vector.new0 (), arg = NONE}
+ in
val falsee = make Con.falsee
+ val truee = make Con.truee
end
-
- fun toAst (T {con, arg, ...}) =
- let
- val con = Con.toAst con
- in
- case arg of
- NONE => Apat.con con
- | SOME (x, t) =>
- if !Control.showTypes
- then Apat.app (con, Apat.constraint (Apat.var (Var.toAst x),
- Type.toAst t))
- else Apat.app (con, Apat.var (Var.toAst x))
- end
-
- val layout = Apat.layout o toAst
end
structure Cases =
@@ -70,6 +68,20 @@
| Int of IntSize.t * (IntX.t * 'a) vector
| Word of WordSize.t * (WordX.t * 'a) vector
+ fun layout (cs, layout) =
+ let
+ open Layout
+ fun doit (v, f) =
+ align (Vector.toListMap (v, fn (x, e) =>
+ align [seq [f x, str " => "],
+ indent (layout e, 3)]))
+ in
+ case cs of
+ Con v => doit (v, Pat.layout)
+ | Int (_, v) => doit (v, IntX.layout)
+ | Word (_, v) => doit (v, WordX.layout)
+ end
+
fun fold (c: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b =
let
fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
@@ -115,14 +127,10 @@
end
end
-(*---------------------------------------------------*)
-(* VarExp *)
-(*---------------------------------------------------*)
-
structure VarExp =
struct
- datatype t = T of {var: Var.t,
- targs: Type.t vector}
+ datatype t = T of {targs: Type.t vector,
+ var: Var.t}
fun mono var = T {var = var, targs = Vector.new0 ()}
@@ -133,10 +141,6 @@
val var = make #var
end
- val toAst = Aexp.var o Var.toAst o var
-
- fun toAsts (xs: t list): Aexp.t list = List.map (xs, toAst)
-
fun layout (T {var, targs, ...}) =
if !Control.showTypes
then let open Layout
@@ -170,9 +174,9 @@
catch: Var.t * Type.t,
handler: exp}
| Lambda of lambda
- | PrimApp of {prim: Prim.t,
- targs: Type.t vector,
- args: VarExp.t vector}
+ | PrimApp of {args: VarExp.t vector,
+ prim: Prim.t,
+ targs: Type.t vector}
| Profile of ProfileExp.t
| Raise of {exn: VarExp.t,
filePos: string option}
@@ -181,190 +185,134 @@
| Tuple of VarExp.t vector
| Var of VarExp.t
and dec =
- Exception of {con: Con.t,
- arg: Type.t option}
- | Fun of {tyvars: Tyvar.t vector,
- decs: {var: Var.t,
+ Exception of {arg: Type.t option,
+ con: Con.t}
+ | Fun of {decs: {lambda: lambda,
ty: Type.t,
- lambda: lambda} vector}
- | MonoVal of {var: Var.t,
- ty: Type.t,
- exp: primExp}
- | PolyVal of {tyvars: Tyvar.t vector,
+ var: Var.t} vector,
+ tyvars: Tyvar.t vector}
+ | MonoVal of {exp: primExp,
+ ty: Type.t,
+ var: Var.t}
+ | PolyVal of {exp: exp,
ty: Type.t,
- var: Var.t,
- exp: exp}
+ tyvars: Tyvar.t vector,
+ var: Var.t}
and lambda = Lam of {arg: Var.t,
argType: Type.t,
body: exp,
plist: PropertyList.t}
-(*---------------------------------------------------*)
-(* Conversion to Ast *)
-(*---------------------------------------------------*)
-
-fun expToAst (Exp {decs, result, ...}): Aexp.t =
- Aexp.lett (decsToAst decs, VarExp.toAst result)
-and expsToAsts es = List.map (es, expToAst)
-and decsToAst decs = Vector.fromListMap (decs, decToAst)
-and decToAst d : Adec.t =
- let
- fun doit n = Adec.makeRegion (n, Region.bogus)
- in
+local
+ open Layout
+in
+ fun layoutConArg {arg, con} =
+ seq [Con.layout con,
+ case arg of
+ NONE => empty
+ | SOME t => seq [str " of ", Type.layout t]]
+ fun layoutTyvars ts =
+ case Vector.length ts of
+ 0 => empty
+ | 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
+ | _ => seq [str " ", tuple (Vector.toListMap (ts, Tyvar.layout))]
+ fun layoutDec d =
case d of
- MonoVal {var, ty, exp} =>
- doit
- (Adec.Val
- {tyvars = Vector.new0 (),
- vbs = (Vector.new1
- {filePos = "",
- exp = primExpToAst exp,
- pat = if !Control.showTypes
- then Apat.constraint (Apat.var (Var.toAst var),
- Type.toAst ty)
- else Apat.var (Var.toAst var)}),
- rvbs = Vector.new0 ()})
- | PolyVal {tyvars, var, exp, ...} =>
- Adec.vall (tyvars, Var.toAst var, expToAst exp)
- | Fun {tyvars, decs} =>
- doit
- (Adec.Fun
- (tyvars,
- Vector.map
- (decs, fn {var, ty, lambda = Lam {arg, argType, body, ...}, ...} =>
- {filePos = "",
- clauses =
- Vector.new1
- {pats = (Vector.new2
- (Apat.var (Var.toAst var),
- if !Control.showTypes
- then Apat.constraint (Apat.var (Var.toAst arg),
- Type.toAst argType)
- else Apat.var (Var.toAst arg))),
- resultType = SOME (Type.toAst (#2 (Type.dearrow ty))),
- body = expToAst body}})))
- | Exception {con, arg} =>
- Adec.exceptionn (Con.toAst con, Type.optionToAst arg)
- end
-and primExpToAst e : Aexp.t =
- case e of
- App {func, arg} => Aexp.app (VarExp.toAst func, VarExp.toAst arg)
- | Case {test, cases, default, ...} =>
- let
- fun doit (l, f) =
- Vector.map (l, fn (i, exp) => (f i, expToAst exp))
- datatype z = datatype Cases.t
- val make =
- fn n => Ast.Pat.const (Ast.Const.makeRegion (n, Region.bogus))
- val cases =
- case cases of
- Con l => Vector.map (l, fn (pat, exp) =>
- (Pat.toAst pat, expToAst exp))
- | Int (_, l) => doit (l, make o Ast.Const.Int o IntX.toIntInf)
- | Word (_, l) => doit (l, make o Ast.Const.Word o WordX.toIntInf)
- val cases =
- case default of
- NONE => cases
- | SOME (e, _) =>
- Vector.concat [cases,
- Vector.new1 (Ast.Pat.wild, expToAst e)]
- in
- Aexp.casee (VarExp.toAst test,
- Amatch.T {rules = cases,
- filePos = ""})
- end
- | ConApp {con, arg, ...} =>
- let val con = Aexp.con (Con.toAst con)
- in case arg of
- NONE => con
- | SOME e => Aexp.app (con, VarExp.toAst e)
- end
- | Const c => Const.toAstExp c
- | Handle {try, catch, handler} =>
- Aexp.handlee
- (expToAst try,
- Amatch.T {filePos = "",
- rules = Vector.new1 (Apat.var (Var.toAst (#1 catch)),
- expToAst handler)})
- | Lambda lambda => Aexp.fnn (lambdaToAst lambda)
- | PrimApp {prim, args, ...} =>
- let
- val p = Aexp.longvid (Ast.Longvid.short
- (Ast.Longvid.Id.fromString
- (Prim.toString prim,
- Region.bogus)))
- in
- case Prim.numArgs prim of
- NONE => p
- | SOME _ => Aexp.app (p, Aexp.tuple (Vector.map
- (args, VarExp.toAst)))
- end
- | Profile s =>
- let
- val (oper, si) =
- case s of
- ProfileExp.Enter si => ("ProfileEnter", si)
- | ProfileExp.Leave si => ("ProfileLeave", si)
- in
- Aexp.app
- (Aexp.var (Ast.Var.fromString (oper, Region.bogus)),
- Aexp.const (Ast.Const.makeRegion
- (Ast.Const.String (SourceInfo.toString si),
- Region.bogus)))
- end
- | Raise {exn, filePos} =>
- Aexp.raisee {exn = VarExp.toAst exn,
- filePos = (case filePos of
- NONE => ""
- | SOME s => s)}
- | Select {tuple, offset} =>
- Aexp.select {tuple = VarExp.toAst tuple,
- offset = offset}
- | Tuple xs => Aexp.tuple (Vector.map (xs, VarExp.toAst))
- | Var x => VarExp.toAst x
-
-and lambdaToAst (Lam {arg, body, argType, ...}): Amatch.t =
- Amatch.T
- {filePos = "",
- rules = Vector.new1 ((if !Control.showTypes
- then Apat.constraint (Apat.var (Var.toAst arg),
- Type.toAst argType)
- else Apat.var (Var.toAst arg),
- expToAst body))}
-
-fun layoutLambda f = Aexp.layout (Aexp.fnn (lambdaToAst f))
-
-(*---------------------------------------------------*)
-(* Declarations *)
-(*---------------------------------------------------*)
+ Exception ca =>
+ seq [str "exception ", layoutConArg ca]
+ | Fun {decs, tyvars} =>
+ align [seq [str "val rec", layoutTyvars tyvars, str " "],
+ indent (align (Vector.toListMap
+ (decs, fn {lambda, ty, var} =>
+ align [seq [maybeConstrain (Var.layout var, ty),
+ str " = "],
+ indent (layoutLambda lambda, 3)])),
+ 3)]
+ | MonoVal {exp, ty, var} =>
+ align [seq [str "val ",
+ maybeConstrain (Var.layout var, ty), str " = "],
+ indent (layoutPrimExp exp, 3)]
+ | PolyVal {exp, ty, tyvars, var} =>
+ align [seq [str "val",
+ if !Control.showTypes
+ then layoutTyvars tyvars
+ else empty,
+ str " ",
+ maybeConstrain (Var.layout var, ty),
+ str " = "],
+ indent (layoutExp exp, 3)]
+ and layoutExp (Exp {decs, result}) =
+ align [str "let",
+ indent (align (List.map (decs, layoutDec)), 3),
+ str "in",
+ indent (VarExp.layout result, 3),
+ str "end"]
+ and layoutPrimExp e =
+ case e of
+ App {arg, func} => seq [VarExp.layout func, str " ", VarExp.layout arg]
+ | Case {test, cases, default} =>
+ align [seq [str "case ", VarExp.layout test, str " of"],
+ indent
+ (align
+ [case default of
+ NONE => empty
+ | SOME (e, _) => seq [str "_ => ", layoutExp e]],
+ 2),
+ Cases.layout (cases, layoutExp)]
+ | ConApp {arg, con, ...} =>
+ seq [Con.layout con,
+ case arg of
+ NONE => empty
+ | SOME x => seq [str " ", VarExp.layout x]]
+ | Const c => Const.layout c
+ | Handle {catch, handler, try} =>
+ align [layoutExp try,
+ seq [str "handle ",
+ Var.layout (#1 catch),
+ str " => ", layoutExp handler]]
+ | Lambda l => layoutLambda l
+ | PrimApp {args, prim, targs} =>
+ seq [Prim.layout prim,
+ if !Control.showTypes
+ andalso 0 < Vector.length targs
+ then list (Vector.toListMap (targs, Type.layout))
+ else empty,
+ str " ", tuple (Vector.toListMap (args, VarExp.layout))]
+ | Profile e => ProfileExp.layout e
+ | Raise {exn, ...} => seq [str "raise ", VarExp.layout exn]
+ | Select {offset, tuple} =>
+ seq [str "#", Int.layout offset, str " ", VarExp.layout tuple]
+ | Tuple xs => tuple (Vector.toListMap (xs, VarExp.layout))
+ | Var x => VarExp.layout x
+ and layoutLambda (Lam {arg, argType, body, ...}) =
+ align [seq [str "fn ", maybeConstrain (Var.layout arg, argType),
+ str " => "],
+ layoutExp body]
+
+end
structure Dec =
struct
type exp = exp
datatype t = datatype dec
- val toAst = decToAst
- val layout = Ast.Dec.layout o toAst
+ val layout = layoutDec
end
-(*---------------------------------------------------*)
-(* Expressions *)
-(*---------------------------------------------------*)
-
structure PrimExp =
struct
type exp = exp
datatype t = datatype primExp
- val toAst = primExpToAst
- val layout = Aexp.layout o toAst
+ val layout = layoutPrimExp
end
structure Exp =
struct
datatype t = datatype exp
- val new = Exp
+ val layout = layoutExp
+ val make = Exp
fun dest (Exp r) = r
val decs = #decs o dest
val result = #result o dest
@@ -383,9 +331,6 @@
val prefixs = make (op @)
end
- val toAst = expToAst
- val layout = Ast.Exp.layout o toAst
-
fun enterLeave (e: t, ty: Type.t, si: SourceInfo.t): t =
if !Control.profile = Control.ProfileNone
orelse !Control.profileIL <> Control.ProfileSource
@@ -401,18 +346,18 @@
val exn = Var.newNoname ()
val res = Var.newNoname ()
val handler =
- new {decs = [prof ProfileExp.Leave,
- MonoVal {exp = Raise {exn = VarExp.mono exn,
- filePos = NONE},
- ty = ty,
- var = res}],
- result = VarExp.mono res}
+ make {decs = [prof ProfileExp.Leave,
+ MonoVal {exp = Raise {exn = VarExp.mono exn,
+ filePos = NONE},
+ ty = ty,
+ var = res}],
+ result = VarExp.mono res}
val {decs, result} = dest e
val decs =
List.concat [[prof ProfileExp.Enter],
decs,
[prof ProfileExp.Leave]]
- val try = new {decs = decs, result = result}
+ val try = make {decs = decs, result = result}
in
fromPrimExp (Handle {catch = (exn, Type.exn),
handler = handler,
@@ -589,7 +534,7 @@
val body = make #body
end
- fun new {arg, argType, body} =
+ fun make {arg, argType, body} =
Lam {arg = arg,
argType = argType,
body = body,
@@ -750,8 +695,10 @@
fun deref (e: t): t =
convert (e, fn (x, t) =>
- let val t = Type.deref t
- in (PrimApp {prim = Prim.deref,
+ let
+ val t = Type.deRef t
+ in
+ (PrimApp {prim = Prim.deref,
targs = Vector.new1 t,
args = Vector.new1 x},
t)
@@ -797,9 +744,9 @@
Dec.MonoVal {var = var, ty = ty, exp = exp}))
fun lambda {arg, argType, body, bodyType} =
- simple (Lambda (Lambda.new {arg = arg,
- argType = argType,
- body = toExp body}),
+ simple (Lambda (Lambda.make {arg = arg,
+ argType = argType,
+ body = toExp body}),
Type.arrow (argType, bodyType))
fun detupleGen (e: PrimExp.t,
@@ -813,7 +760,7 @@
| 1 => [MonoVal {var = Vector.sub (components, 0), ty = t, exp = e}]
| _ =>
let
- val ts = Type.detuple t
+ val ts = Type.deTuple t
val tupleVar = Var.newNoname ()
in MonoVal {var = tupleVar, ty = t, exp = e}
::
@@ -835,17 +782,20 @@
tuple
(fn (e, t) =>
let
- val ts = Type.detuple t
- in case e of
- Tuple xs => send (body (Vector.zip (xs, ts)), k)
- | _ => let
- val components = Vector.map (ts, fn _ => Var.newNoname ())
- in detupleGen (e, t, components,
- send (body (Vector.map2
- (components, ts, fn (x, t) =>
- (VarExp.mono x, t))),
- k))
- end
+ val ts = Type.deTuple t
+ in
+ case e of
+ Tuple xs => send (body (Vector.zip (xs, ts)), k)
+ | _ => let
+ val components =
+ Vector.map (ts, fn _ => Var.newNoname ())
+ in
+ detupleGen (e, t, components,
+ send (body (Vector.map2
+ (components, ts, fn (x, t) =>
+ (VarExp.mono x, t))),
+ k))
+ end
end)
end
@@ -865,16 +815,20 @@
structure Datatype =
struct
- type t = {tycon: Tycon.t,
- tyvars: Tyvar.t vector,
- cons: {con: Con.t,
- arg: Type.t option} vector}
+ type t = {cons: {arg: Type.t option,
+ con: Con.t} vector,
+ tycon: Tycon.t,
+ tyvars: Tyvar.t vector}
- fun toAst ({tyvars, tycon, cons}:t) =
- {tyvars = tyvars,
- tycon = Tycon.toAst tycon,
- cons = Vector.map (cons, fn {con, arg} =>
- (Con.toAst con, Type.optionToAst arg))}
+ fun layout ({cons, tycon, tyvars}: t): Layout.t =
+ let
+ open Layout
+ in
+ seq [layoutTyvars tyvars, str " ", Tycon.layout tycon, str " = ",
+ align
+ (separateLeft (Vector.toListMap (cons, layoutConArg),
+ "| "))]
+ end
end
(*---------------------------------------------------*)
@@ -883,31 +837,21 @@
structure Program =
struct
- datatype t = T of {datatypes: Datatype.t vector,
- body: Exp.t,
+ datatype t = T of {body: Exp.t,
+ datatypes: Datatype.t vector,
overflow: Var.t option}
fun size (T {body, ...}) = Exp.size body
- fun toAst (T {datatypes, body, ...}) =
- let
- val body = Exp.toAst body
- in
- if Vector.isEmpty datatypes
- then body
- else
- Aexp.lett (Vector.new1
- (Adec.datatypee (Vector.map
- (datatypes, Datatype.toAst))),
- body)
- end
-
- fun layout (p as T {overflow, ...}) =
+ fun layout (p as T {body, datatypes, overflow, ...}) =
let
open Layout
in
align [seq [str "Overflow: ", Option.layout Var.layout overflow],
- Ast.Exp.layout (toAst p)]
+ str "Datatypes:",
+ align (Vector.toListMap (datatypes, Datatype.layout)),
+ str "Body:",
+ Exp.layout body]
end
fun clear (T {datatypes, body, ...}) =
1.13 +17 -19 mlton/mlton/xml/xml-tree.sig
Index: xml-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/xml-tree.sig,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- xml-tree.sig 23 Jun 2003 04:59:00 -0000 1.12
+++ xml-tree.sig 9 Oct 2003 18:17:35 -0000 1.13
@@ -37,7 +37,6 @@
val falsee: t
val truee: t
val con: t -> Con.t
- val toAst: t -> Ast.Pat.t
val layout: t -> Layout.t
end
@@ -67,9 +66,9 @@
body: exp}
val equals: t * t -> bool
val layout: t -> Layout.t
- val new: {arg: Var.t,
- argType: Type.t,
- body: exp} -> t
+ val make: {arg: Var.t,
+ argType: Type.t,
+ body: exp} -> t
val plist: t -> PropertyList.t
end
@@ -136,7 +135,6 @@
tyvars: Tyvar.t vector,
var: Var.t}
- val toAst: t -> Ast.Dec.t
val layout: t -> Layout.t
end
@@ -171,7 +169,7 @@
val fromPrimExp: PrimExp.t * Type.t -> t
val hasPrim: t * (Prim.t -> bool) -> bool
val layout: t -> Layout.t
- val new: {decs: Dec.t list, result: VarExp.t} -> t
+ val make: {decs: Dec.t list, result: VarExp.t} -> t
val prefix: t * Dec.t -> t
val result: t -> VarExp.t
val size: t -> int
@@ -188,9 +186,9 @@
test: t,
ty: Type.t} (* type of entire case expression *)
-> t
- val conApp: {con: Con.t,
+ val conApp: {arg: t option,
+ con: Con.t,
targs: Type.t vector,
- arg: t option,
ty: Type.t} -> t
val const: Const.t -> t
val deref: t -> t
@@ -199,10 +197,10 @@
val equal: t * t -> t
val falsee: unit -> t
val fromExp: Exp.t * Type.t -> t
- val handlee: {try: t,
- ty: Type.t,
- catch: Var.t * Type.t,
- handler: t} -> t
+ val handlee: {catch: Var.t * Type.t,
+ handler: t,
+ try: t,
+ ty: Type.t} -> t
val iff: {test: t, thenn: t, elsee: t, ty: Type.t} -> t
val lambda: {arg: Var.t,
argType: Type.t,
@@ -212,9 +210,9 @@
val let1: {var: Var.t, exp: t, body: t} -> t
val lett: {decs: Dec.t list, body: t} -> t
val monoVar: Var.t * Type.t -> t
- val primApp: {prim: Prim.t,
+ val primApp: {args: t vector,
+ prim: Prim.t,
targs: Type.t vector,
- args: t vector,
ty: Type.t} -> t
val raisee: {exn: t, filePos: string option} * Type.t -> t
val reff: t -> t
@@ -227,20 +225,20 @@
val tuple: {exps: t vector, ty: Type.t} -> t
val unit: unit -> t
val vall: {var: Var.t, exp: t} -> Dec.t list
- val var: {var: Var.t,
- targs: Type.t vector,
- ty: Type.t} -> t
+ val var: {targs: Type.t vector,
+ ty: Type.t,
+ var: Var.t} -> t
val varExp: VarExp.t * Type.t -> t
end
structure Program:
sig
datatype t =
- T of {datatypes: {cons: {arg: Type.t option,
+ T of {body: Exp.t,
+ datatypes: {cons: {arg: Type.t option,
con: Con.t} vector,
tycon: Tycon.t,
tyvars: Tyvar.t vector} vector,
- body: Exp.t,
(* overflow is SOME only after exceptions have been
* implemented.
*)
1.8 +2 -0 mlton/regression/.cvsignore
Index: .cvsignore
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/.cvsignore,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- .cvsignore 2 Jan 2003 17:45:22 -0000 1.7
+++ .cvsignore 9 Oct 2003 18:17:35 -0000 1.8
@@ -1,3 +1,5 @@
+*.ui
+*.uo
*.dat
*.dot
*.ssa
1.2 +1 -1 mlton/regression/6.sml
Index: 6.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/6.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- 6.sml 18 Jul 2001 05:51:07 -0000 1.1
+++ 6.sml 9 Oct 2003 18:17:35 -0000 1.2
@@ -1,6 +1,6 @@
fun f x = x
-val r = ref f
+val r: (int -> int) ref = ref f
val _ = r := (fn y => y)
1.2 +5 -5 mlton/regression/asterisk.sml
Index: asterisk.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/asterisk.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- asterisk.sml 5 Oct 2001 19:07:42 -0000 1.1
+++ asterisk.sml 9 Oct 2003 18:17:35 -0000 1.2
@@ -1,5 +1,5 @@
-(* asterisk.sml *)
-
-(* Checks parsing of "* )". *)
-
-val op* = (op*);
+(* asterisk.sml *)
+
+(* Checks parsing of "* )". *)
+
+val op* : int * int -> int = (op*);
1.2 +11 -11 mlton/regression/exnHistory.ok
Index: exnHistory.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/exnHistory.ok,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- exnHistory.ok 1 Oct 2001 17:10:31 -0000 1.1
+++ exnHistory.ok 9 Oct 2003 18:17:35 -0000 1.2
@@ -1,11 +1,11 @@
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:4.26
-exnHistory.sml:3.18
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 4.26
+exnHistory.sml 3.18
1.5 +1 -1 mlton/regression/exnHistory2.ok
Index: exnHistory2.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/exnHistory2.ok,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- exnHistory2.ok 24 Sep 2003 17:27:54 -0000 1.4
+++ exnHistory2.ok 9 Oct 2003 18:17:35 -0000 1.5
@@ -1,4 +1,4 @@
unhandled exception: Fail: foo
with history:
- exnHistory2.sml:1.15
+ exnHistory2.sml 1.15
Nonzero exit status.
1.2 +22 -22 mlton/regression/exnHistory3.ok
Index: exnHistory3.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/exnHistory3.ok,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- exnHistory3.ok 25 Aug 2002 22:23:58 -0000 1.1
+++ exnHistory3.ok 9 Oct 2003 18:17:35 -0000 1.2
@@ -1,23 +1,23 @@
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:5.18
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 5.18
ZZZ
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:6.26
-exnHistory3.sml:5.18
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 6.26
+exnHistory3.sml 5.18
1.4 +8 -11 mlton/regression/flexrecord.sml
Index: flexrecord.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/flexrecord.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- flexrecord.sml 18 Oct 2001 21:19:50 -0000 1.3
+++ flexrecord.sml 9 Oct 2003 18:17:35 -0000 1.4
@@ -83,16 +83,13 @@
(* flexrecord7 *)
(* flexrecord8 *)
-val f = #foo
-val g = (fn x => x) f
-val _ = f {foo=0, bar=1}
-(* flexrecord8 *)
-
-(* flexrecord9 *)
-structure S =
- struct
+val _ =
+ fn _ =>
+ let
val f = #foo
+ val g = (fn x => x) f
+ val _ = f {foo=0, bar=1}
+ in
+ ()
end
-
-val _ = S.f {foo=1, goo=2}
-(* flexrecord9 *)
+(* flexrecord8 *)
1.2 +2 -2 mlton/regression/undetermined.sml
Index: undetermined.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/undetermined.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- undetermined.sml 5 Oct 2001 19:07:42 -0000 1.1
+++ undetermined.sml 9 Oct 2003 18:17:35 -0000 1.2
@@ -7,10 +7,10 @@
structure A : sig val a : int list ref end =
struct
- val a = ref nil
+ val a: int list ref = ref nil
end;
structure B : sig end =
struct
- val a = ref nil
+ val a: unit list ref = ref nil
end;
1.2 +1 -0 mlton/regression/valrec.ok
Index: valrec.ok
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/valrec.ok,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- valrec.ok 18 Jul 2001 05:51:07 -0000 1.1
+++ valrec.ok 9 Oct 2003 18:17:35 -0000 1.2
@@ -1,2 +1,3 @@
Hello, world!
Hello, world!
+13
1.3 +4 -8 mlton/regression/valrec.sml
Index: valrec.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/regression/valrec.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- valrec.sml 5 Oct 2001 19:07:42 -0000 1.2
+++ valrec.sml 9 Oct 2003 18:17:35 -0000 1.3
@@ -50,11 +50,7 @@
and rec e as f as g = fn x => x
and h : 'b -> 'b : 'b -> 'b = fn x => x;
-val x =
-let
- val rec LESS = fn x => x (* will raise Bind *)
- and NONE as SOME = fn x => x
- val SOME = 1;
-in
- raise Fail "should not get here!"
-end handle Bind => ();
+val rec LESS = fn x => x
+and NONE as SOME = fn x => x
+val SOME = 13
+val _ = print (concat [Int.toString SOME, "\n"])
1.10 +0 -10 mlton/runtime/libmlton.c
Index: libmlton.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/libmlton.c,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- libmlton.c 1 Jun 2003 00:31:33 -0000 1.9
+++ libmlton.c 9 Oct 2003 18:17:35 -0000 1.10
@@ -9,16 +9,6 @@
#include <string.h>
#include "libmlton.h"
-void MLton_printStringEscaped (FILE *f, unsigned char *s) {
- int i;
- for (i = 0; s[i] != '\0'; i++)
- fprintf(f, "%d%d%d",
- s[i] / 100 % 10,
- s[i] / 10 % 10,
- s[i] % 10);
- fprintf(f, "\n");
-}
-
/* ------------------------------------------------- */
/* MLton_init */
/* ------------------------------------------------- */
-------------------------------------------------------
This SF.net email is sponsored by: SF.net Giveback Program.
SourceForge.net hosts over 70,000 Open Source Projects.
See the people who have HELPED US provide better services:
Click here: http://sourceforge.net/supporters.php
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel