[MLton-devel] cvs commit: types for Rssa
Stephen Weeks
sweeks@users.sourceforge.net
Fri, 06 Dec 2002 18:21:54 -0800
sweeks 02/12/06 18:21:54
Modified: . Makefile
basis-library/misc primitive.sml
include ccodegen.h x86codegen.h
mlton Makefile mlton-stubs-1997.cm mlton-stubs.cm
mlton.cm
mlton/ast record.fun
mlton/atoms id.fun id.sig prim.fun prim.sig sources.cm
mlton/backend allocate-registers.fun allocate-registers.sig
backend.fun chunkify.fun limit-check.fun
machine.fun machine.sig profile-alloc.fun
representation.fun representation.sig rssa.fun
rssa.sig runtime.fun runtime.sig signal-check.fun
sources.cm ssa-to-rssa.fun ssa-to-rssa.sig
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-codegen.fun
x86-mlton-basic.fun x86-mlton-basic.sig
x86-mlton.fun x86-translate.fun x86.sig
mlton/control control.sig control.sml
mlton/elaborate elaborate-env.fun
mlton/main compile.sml main.sml
mlton/ssa analyze.fun constant-propagation.fun ssa-tree.fun
ssa-tree.sig useless.fun
mlton/type-inference infer.fun type-env.fun
runtime gc.c
Added: mlton/backend machine-atoms.fun machine-atoms.sig switch.fun
switch.sig
Removed: mlton/backend machine-cases.fun machine-cases.sig
Log:
Added types to Rssa and Machine, as discussed in earlier email. The
basic idea is to have object types that correspond to the header
information that is available to the runtime, and sum types that are
used to represent datatypes. See backend/machine-atoms.sig for the
new types.
There is now quite a bit of type checking that is done on Rssa, but it
is still far from type safe, partially due to lack of effort and
partially due to some unsolved problems. A careful pass through the
type checker in rssa.fun should make stuff better. But there are
still some casts used. See castIsOk in machine-atoms.fun to see the
casts that are currently allowed. Other things that remain to be
(type-)checked: liveness info, limit checks, case statements that
narrow types, globals defined before use, primapps, ...
Various primitives are now implemented as casts by SsaToRssa instead
of being implemented in the codegens.
Byte_byteToChar
Byte_charToByte
C_CS_charArrayToWord8Array
IntInf_fromVector
IntInf_fromWord
IntInf_toVector
IntInf_toWord
String_fromWord8Vector
String_toWord8Vector
Vector_fromArray
Word32_fromInt
Word32_toIntX
Of course, some of these are unsafe (e.g. IntInf_fromWord).
Vector_fromArray now changes the object header, in anticipation of
object headers including mutability information some day.
It should now be a simple matter to use headers as variant tags, but
I haven't done it yet.
Combined all the switch statements used by Rssa and Machine into a
single datatype -- see backend/switch.sig. With that and the changes
to operands, Rssa and Machine are starting to look suspiciously
similar. Hopefully one day we will be able to unify them.
Eliminated Array_array0, and Array_array is now used to allocate
zero-length arrays. This required a minor change to the runtime,
since zero-length arrays now have the proper type tag instead of all
having the same one.
The backend register allocation is no longer attempts to share a
register for multiple variables. This may cause performance problems
since the local{char,int,...} arrays used by the native codegen to
cache real registers will no longer be as small or as densely used.
There were some pretty straightforward changes to the codegens to
keep up with the changes to MACHINE.
Added a new flag "-keep rssa" and added lots of improvements to Rssa
pretty printing.
Changes for rearrangement of sorting functions in library.
Revision Changes Path
1.80 +1 -1 mlton/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/Makefile,v
retrieving revision 1.79
retrieving revision 1.80
diff -u -r1.79 -r1.80
--- Makefile 21 Nov 2002 02:49:20 -0000 1.79
+++ Makefile 7 Dec 2002 02:21:50 -0000 1.80
@@ -44,7 +44,7 @@
.PHONY: cm
cm:
- $(MAKE) -C $(COMP) mlton_cm
+ $(MAKE) -C $(COMP) mlton_cm mlton-stubs-1997_cm
$(MAKE) -C $(LEX) mllex_cm
$(MAKE) -C $(PROF) mlprof_cm
$(MAKE) -C $(YACC) mlyacc_cm
1.42 +5 -6 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- primitive.sml 5 Dec 2002 01:25:15 -0000 1.41
+++ primitive.sml 7 Dec 2002 02:21:50 -0000 1.42
@@ -242,12 +242,11 @@
struct
open Array
- fun array n =
- if safe andalso Int.< (n, 0)
- then raise Size
- else if eq (n, 0)
- then _prim "Array_array0": unit -> 'a array; ()
- else _prim "Array_array": int -> 'a array; n
+ val array = fn n => _prim "Array_array": int -> 'a array; n
+ val array =
+ fn n => if safe andalso Int.< (n, 0)
+ then raise Size
+ else array n
end
structure IntInf =
1.42 +5 -43 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- ccodegen.h 24 Nov 2002 01:19:41 -0000 1.41
+++ ccodegen.h 7 Dec 2002 02:21:51 -0000 1.42
@@ -41,13 +41,6 @@
sfread(globaluint, sizeof(uint), u, file); \
}
-#define Locals(c, d, i, p, u) \
- char localuchar[c]; \
- double localdouble[d]; \
- int localint[i]; \
- pointer localpointer[p]; \
- uint localuint[u]
-
#define BeginIntInfs static struct GC_intInfInit intInfInits[] = {
#define IntInf(g, n) { g, n },
#define EndIntInfs { 0, NULL }};
@@ -56,9 +49,9 @@
#define String(g, s, l) { g, s, l },
#define EndStrings { 0, NULL, 0 }};
-#define BeginFloats static void float_Init() {
-#define Float(c, f) globaldouble[c] = f;
-#define EndFloats }
+#define BeginReals static void real_Init() {
+#define Real(c, f) globaldouble[c] = f;
+#define EndReals }
#define IsInt(p) (0x3 & (int)(p))
@@ -140,7 +133,7 @@
gcState.stringInits = stringInits; \
MLton_init (argc, argv, &gcState); \
if (gcState.isOriginal) { \
- float_Init(); \
+ real_Init(); \
PrepFarJump(mc, ml); \
} else { \
/* Return to the saved world */ \
@@ -205,6 +198,7 @@
#define GD(i) Global(double, i)
#define GI(i) Global(int, i)
#define GP(i) Global(pointer, i)
+#define GPNR(i) Global(pointerNonRoot, i)
#define GU(i) Global(uint, i)
#define Offset(ty, b, o) (*(ty*)((b) + (o)))
@@ -342,19 +336,6 @@
#define XU(b, i) ArrayOffset(uint, b, i)
/* ------------------------------------------------- */
-/* Byte */
-/* ------------------------------------------------- */
-
-#define Byte_byteToChar(b) b
-#define Byte_charToByte(c) c
-
-/* ------------------------------------------------- */
-/* C */
-/* ------------------------------------------------- */
-
-#define C_CS_charArrayToWord8Array(x) x
-
-/* ------------------------------------------------- */
/* Char */
/* ------------------------------------------------- */
@@ -584,15 +565,6 @@
#define Int_neg(n) (-(n))
/* ------------------------------------------------- */
-/* IntInf */
-/* ------------------------------------------------- */
-
-#define IntInf_fromVector(x) x
-#define IntInf_fromWord(w) ((pointer)(w))
-#define IntInf_toVector(x) x
-#define IntInf_toWord(i) ((uint)(i))
-
-/* ------------------------------------------------- */
/* MLton */
/* ------------------------------------------------- */
@@ -644,18 +616,10 @@
#define Real_toInt(x) ((int)(x))
/* ------------------------------------------------- */
-/* String */
-/* ------------------------------------------------- */
-
-#define String_fromWord8Vector(x) x
-#define String_toWord8Vector(x) x
-
-/* ------------------------------------------------- */
/* Vector */
/* ------------------------------------------------- */
#define Vector_length GC_arrayNumElements
-#define Vector_fromArray(a) a
/* ------------------------------------------------- */
/* Word8 */
@@ -715,7 +679,6 @@
*/
#define Word32_arshift(w, s) ((int)(w) >> (s))
#define Word32_div(w1, w2) ((w1) / (w2))
-#define Word32_fromInt(x) ((uint)(x))
#define Word32_ge(w1, w2) ((w1) >= (w2))
#define Word32_gt(w1, w2) ((w1) > (w2))
#define Word32_le(w1, w2) ((w1) <= (w2))
@@ -730,7 +693,6 @@
#define Word32_rol(x, y) ((x)>>(32-(y)) | ((x)<<(y)))
#define Word32_rshift(w, s) ((w) >> (s))
#define Word32_sub(w1, w2) ((w1) - (w2))
-#define Word32_toIntX(x) ((int)(x))
#define Word32_xorb(w1, w2) ((w1) ^ (w2))
#endif /* #ifndef _CCODEGEN_H_ */
1.19 +4 -4 mlton/include/x86codegen.h
Index: x86codegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/x86codegen.h,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- x86codegen.h 2 Nov 2002 03:37:36 -0000 1.18
+++ x86codegen.h 7 Dec 2002 02:21:51 -0000 1.19
@@ -60,9 +60,9 @@
#define String(g, s, l) { g, s, l },
#define EndStrings { 0, NULL, 0 }};
-#define BeginFloats static void float_Init() {
-#define Float(c, f) globaldouble[c] = f;
-#define EndFloats }
+#define BeginReals static void real_Init() {
+#define Real(c, f) globaldouble[c] = f;
+#define EndReals }
#define Main(cs, mmc, mfs, mfi, mot, mg, ml, reserveEsp, a1, a2, a3) \
extern pointer ml; \
@@ -88,7 +88,7 @@
gcState.stringInits = stringInits; \
MLton_init (argc, argv, &gcState); \
if (gcState.isOriginal) { \
- float_Init(); \
+ real_Init(); \
jump = (pointer)&ml; \
} else { \
jump = *(pointer*)(gcState.stackTop - WORD_SIZE); \
1.63 +1 -1 mlton/mlton/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/Makefile,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -r1.62 -r1.63
--- Makefile 7 Dec 2002 01:40:18 -0000 1.62
+++ Makefile 7 Dec 2002 02:21:51 -0000 1.63
@@ -4,7 +4,7 @@
LIB = $(BUILD)/lib
MLTON = mlton
HOST = self
-FLAGS = @MLton $(RUNTIME_ARGS) gc-summary -- -host $(HOST) -v2 -o $(AOUT)
+FLAGS = @MLton $(RUNTIME_ARGS) gc-summary -- -host $(HOST) -v -o $(AOUT)
NAME = mlton
AOUT = mlton-compile
PATH = $(BIN):$(shell echo $$PATH)
1.3 +8 -8 mlton/mlton/mlton-stubs-1997.cm
Index: mlton-stubs-1997.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs-1997.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- mlton-stubs-1997.cm 24 Nov 2002 22:59:47 -0000 1.2
+++ mlton-stubs-1997.cm 7 Dec 2002 02:21:51 -0000 1.3
@@ -200,6 +200,10 @@
ast/ast.sig
ast/ast-const.fun
ast/field.fun
+../lib/mlton/basic/quick-sort.sig
+../lib/mlton/basic/insertion-sort.sig
+../lib/mlton/basic/insertion-sort.sml
+../lib/mlton/basic/quick-sort.sml
ast/record.fun
ast/tyvar.fun
ast/ast-id.fun
@@ -319,13 +323,15 @@
backend/mtype.sig
backend/c-function.sig
backend/runtime.sig
+backend/machine-atoms.sig
+backend/switch.sig
+backend/switch.fun
backend/mtype.fun
backend/c-function.fun
backend/runtime.fun
backend/err.sml
-backend/machine-cases.sig
+backend/machine-atoms.fun
backend/machine.sig
-backend/machine-cases.fun
backend/machine.fun
../lib/mlton/basic/unique-set.sig
../lib/mlton/basic/unique-set.fun
@@ -350,10 +356,6 @@
backend/chunkify.sig
backend/chunkify.fun
backend/backend.sig
-../lib/mlton/basic/quick-sort.sig
-../lib/mlton/basic/insertion-sort.sig
-../lib/mlton/basic/insertion-sort.sml
-../lib/mlton/basic/quick-sort.sml
backend/live.sig
backend/live.fun
backend/allocate-registers.sig
@@ -444,8 +446,6 @@
elaborate/elaborate-env.sig
elaborate/elaborate.sig
elaborate/decs.fun
-../lib/mlton/basic/merge-sort.sig
-../lib/mlton/basic/merge-sort.sml
elaborate/elaborate-env.fun
elaborate/elaborate-sigexp.sig
elaborate/elaborate-sigexp.fun
1.8 +8 -8 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- mlton-stubs.cm 24 Nov 2002 01:19:43 -0000 1.7
+++ mlton-stubs.cm 7 Dec 2002 02:21:51 -0000 1.8
@@ -199,6 +199,10 @@
ast/ast.sig
ast/ast-const.fun
ast/field.fun
+../lib/mlton/basic/quick-sort.sig
+../lib/mlton/basic/insertion-sort.sig
+../lib/mlton/basic/insertion-sort.sml
+../lib/mlton/basic/quick-sort.sml
ast/record.fun
ast/tyvar.fun
ast/ast-id.fun
@@ -318,13 +322,15 @@
backend/mtype.sig
backend/c-function.sig
backend/runtime.sig
+backend/machine-atoms.sig
+backend/switch.sig
+backend/switch.fun
backend/mtype.fun
backend/c-function.fun
backend/runtime.fun
backend/err.sml
-backend/machine-cases.sig
+backend/machine-atoms.fun
backend/machine.sig
-backend/machine-cases.fun
backend/machine.fun
../lib/mlton/basic/unique-set.sig
../lib/mlton/basic/unique-set.fun
@@ -349,10 +355,6 @@
backend/chunkify.sig
backend/chunkify.fun
backend/backend.sig
-../lib/mlton/basic/quick-sort.sig
-../lib/mlton/basic/insertion-sort.sig
-../lib/mlton/basic/insertion-sort.sml
-../lib/mlton/basic/quick-sort.sml
backend/live.sig
backend/live.fun
backend/allocate-registers.sig
@@ -443,8 +445,6 @@
elaborate/elaborate-env.sig
elaborate/elaborate.sig
elaborate/decs.fun
-../lib/mlton/basic/merge-sort.sig
-../lib/mlton/basic/merge-sort.sml
elaborate/elaborate-env.fun
elaborate/elaborate-sigexp.sig
elaborate/elaborate-sigexp.fun
1.56 +8 -8 mlton/mlton/mlton.cm
Index: mlton.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton.cm,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -r1.55 -r1.56
--- mlton.cm 7 Nov 2002 01:36:55 -0000 1.55
+++ mlton.cm 7 Dec 2002 02:21:51 -0000 1.56
@@ -170,6 +170,10 @@
ast/ast.sig
ast/ast-const.fun
ast/field.fun
+../lib/mlton/basic/quick-sort.sig
+../lib/mlton/basic/insertion-sort.sig
+../lib/mlton/basic/insertion-sort.sml
+../lib/mlton/basic/quick-sort.sml
ast/record.fun
ast/tyvar.fun
ast/ast-id.fun
@@ -289,13 +293,15 @@
backend/mtype.sig
backend/c-function.sig
backend/runtime.sig
+backend/machine-atoms.sig
+backend/switch.sig
+backend/switch.fun
backend/mtype.fun
backend/c-function.fun
backend/runtime.fun
backend/err.sml
-backend/machine-cases.sig
+backend/machine-atoms.fun
backend/machine.sig
-backend/machine-cases.fun
backend/machine.fun
../lib/mlton/basic/unique-set.sig
../lib/mlton/basic/unique-set.fun
@@ -320,10 +326,6 @@
backend/chunkify.sig
backend/chunkify.fun
backend/backend.sig
-../lib/mlton/basic/quick-sort.sig
-../lib/mlton/basic/insertion-sort.sig
-../lib/mlton/basic/insertion-sort.sml
-../lib/mlton/basic/quick-sort.sml
backend/live.sig
backend/live.fun
backend/allocate-registers.sig
@@ -414,8 +416,6 @@
elaborate/elaborate-env.sig
elaborate/elaborate.sig
elaborate/decs.fun
-../lib/mlton/basic/merge-sort.sig
-../lib/mlton/basic/merge-sort.sml
elaborate/elaborate-env.fun
elaborate/elaborate-sigexp.sig
elaborate/elaborate-sigexp.fun
1.4 +2 -1 mlton/mlton/ast/record.fun
Index: record.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/record.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- record.fun 10 Apr 2002 07:02:18 -0000 1.3
+++ record.fun 7 Dec 2002 02:21:51 -0000 1.4
@@ -42,7 +42,8 @@
| _ => false)
val v =
if isSorted
- then Vector.sort (v, fn ((s, _), (s', _)) => Field.<= (s, s'))
+ then QuickSort.sortVector (v, fn ((s, _), (s', _)) =>
+ Field.<= (s, s'))
else v
in if isTuple v
then Tuple (Vector.map (v, #2))
1.5 +15 -3 mlton/mlton/atoms/id.fun
Index: id.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- id.fun 10 Apr 2002 07:02:19 -0000 1.4
+++ id.fun 7 Dec 2002 02:21:51 -0000 1.5
@@ -13,7 +13,7 @@
val getCounter = String.memoize (fn _ => Counter.new 0)
end
-functor Id (S: ID_STRUCTS): ID =
+functor IdNoAst (S: ID_NO_AST_STRUCTS): ID_NO_AST =
struct
open S
@@ -108,13 +108,25 @@
printName = ref NONE,
plist = Plist.new ()}
+val clear = Plist.clear o plist
+
+end
+
+functor Id (S: ID_STRUCTS): ID =
+struct
+
+open S
+local
+ structure I = IdNoAst (S)
+in
+ 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)
-val clear = Plist.clear o plist
-
end
functor HashId (S: ID_STRUCTS): HASH_ID =
1.3 +23 -9 mlton/mlton/atoms/id.sig
Index: id.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- id.sig 10 Apr 2002 07:02:19 -0000 1.2
+++ id.sig 7 Dec 2002 02:21:51 -0000 1.3
@@ -5,32 +5,46 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-signature ID_STRUCTS =
+signature ID_NO_AST_STRUCTS =
sig
- structure AstId: AST_ID
-
val noname: string
end
-signature ID =
+signature ID_NO_AST =
sig
- include ID_STRUCTS
- include T
+ include ID_NO_AST_STRUCTS
+
+ type t
val bogus: t
val clear: t -> unit
- val fromAst: AstId.t -> t
- val fromAsts: AstId.t list -> t list
+ val equals: t * t -> bool
val fromString: string -> t (* doesn't add uniquefying suffix *)
+ val layout: t -> Layout.t
val new: t -> t (* with the same prefix *)
val newNoname: unit -> t (* prefix is "x" *)
val newString: string -> t (* given prefix *)
val originalName: t -> string (* raw destructor *)
val plist: t -> PropertyList.t
val sameName: t * t -> bool
+ val toString: t -> string
+ end
+
+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
- val toString: t -> string
end
signature HASH_ID =
1.42 +0 -4 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- prim.fun 24 Nov 2002 01:19:43 -0000 1.41
+++ prim.fun 7 Dec 2002 02:21:51 -0000 1.42
@@ -34,7 +34,6 @@
struct
datatype t =
Array_array
- | Array_array0
| Array_array0Const
| Array_length
| Array_sub
@@ -256,7 +255,6 @@
val strings =
[
(Array_array, Moveable, "Array_array"),
- (Array_array0, Moveable, "Array_array0"),
(Array_array0Const, Moveable, "Array_array0Const"),
(Array_length, Functional, "Array_length"),
(Array_sub, DependsOnState, "Array_sub"),
@@ -528,7 +526,6 @@
end
val tuple = tuple o Vector.fromList
in
- val array0 = new (Name.Array_array0, make1 (fn a => unit --> array a))
val array = new (Name.Array_array, make1 (fn a => int --> 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))
@@ -678,7 +675,6 @@
in
case name prim of
Array_array => one (dearray result)
- | Array_array0 => one (dearray result)
| Array_array0Const => one (dearray result)
| Array_sub => one result
| Array_update => one (arg 2)
1.34 +0 -2 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- prim.sig 24 Nov 2002 01:19:43 -0000 1.33
+++ prim.sig 7 Dec 2002 02:21:51 -0000 1.34
@@ -24,7 +24,6 @@
sig
datatype t =
Array_array (* implemented in backend *)
- | Array_array0 (* implemented in backend *)
| Array_array0Const (* implemented in constant-propagation.fun *)
| Array_length
| Array_sub (* implemented in backend *)
@@ -250,7 +249,6 @@
val allocTooLarge: t
val apply: t * 'a ApplyArg.t list * ('a * 'a -> bool) -> 'a ApplyResult.t
- val array0: t
val array: t
val assign: t
val bogus: t
1.6 +1 -0 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.5
+++ sources.cm 7 Dec 2002 02:21:51 -0000 1.6
@@ -28,6 +28,7 @@
functor Atoms
functor Cases
functor Id
+functor IdNoAst
functor GenericScheme
functor HashType
functor TypeOps
1.22 +52 -100 mlton/mlton/backend/allocate-registers.fun
Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- allocate-registers.fun 6 Jul 2002 17:22:05 -0000 1.21
+++ allocate-registers.fun 7 Dec 2002 02:21:51 -0000 1.22
@@ -21,8 +21,8 @@
structure Function = Function
structure Kind = Kind
structure Label = Label
- structure Var = Var
structure Type = Type
+ structure Var = Var
end
local
@@ -36,14 +36,14 @@
val traceForceStack =
Trace.trace ("Allocate.forceStack", Var.layout, Unit.layout)
-(* If a handler is stored in a stack frame, then we need both a uint for
+(* If a handler is stored in a stack frame, then we need both a word for
* the old handler and space for the handler itself
*)
local
open Type
in
val labelSize = size label
- val handlerSize = labelSize + size uint
+ val handlerSize = labelSize + size word
end
structure Live = Live (open Rssa)
@@ -63,16 +63,17 @@
sig
type t
val empty: t
- val get: t * Type.t -> t * {index: int}
+ val get: t * Type.t -> t * Register.t
val layout: t -> Layout.t
- val new: {index: int, ty: Type.t} list -> t
+ val new: Register.t list -> t
end
+
type t
val empty: t
- val getRegister: t * Type.t -> t * {index: int}
+ val getRegister: t * Type.t -> t * Register.t
val getStack: t * Type.t -> t * {offset: int}
val layout: t -> Layout.t
- val new: {offset: int, ty: Type.t} list * {index: int, ty: Type.t} list -> t
+ val new: {offset: int, ty: Type.t} list * Register.t list -> t
val registers: t -> Registers.t
val stack: t -> Stack.t
val stackSize: t -> int
@@ -102,14 +103,12 @@
end
fun new (alloc): t =
- let
- val a = Array.fromListMap (alloc, fn {offset, ty} =>
- {offset = offset,
- size = Type.size ty})
- val _ = QuickSort.sort (a, fn (r, r') => #offset r <= #offset r')
- in
- T (Array.toList a)
- end
+ T (Array.toList
+ (QuickSort.sortArray
+ (Array.fromListMap (alloc, fn {offset, ty} =>
+ {offset = offset,
+ size = Type.size ty}),
+ fn (r, r') => #offset r <= #offset r')))
fun get (T alloc, ty) =
let
@@ -165,71 +164,20 @@
end
structure Registers =
struct
- datatype t = T of {ty: Type.t, alloc: {index: int} list} list
+ datatype t = T
- val empty = T (List.map (Type.all, fn ty => {ty = ty, alloc = []}))
+ val empty = T
- fun layout (T allocs) =
- List.layout (fn {ty, alloc} =>
- Layout.record [("ty", Type.layout ty),
- ("alloc", List.layout
- (fn {index} =>
- Layout.record
- [("index", Int.layout index)])
- alloc)])
- allocs
+ fun layout T = Layout.str "<registers>"
- fun new (allocs): t =
- let
- val allocs = List.equivalence (allocs, fn ({ty = ty1, ...},
- {ty = ty2, ...}) =>
- Type.equals (ty1, ty2))
- val allocs =
- List.revMap
- (allocs, fn alloc =>
- let
- val a = Array.fromListMap (alloc, fn {ty, index} =>
- {index = index})
- val _ = QuickSort.sort (a, fn (r, r') => #index r <= #index r')
- in
- {ty = #ty (hd alloc),
- alloc = Array.toList a}
- end)
- in
- T allocs
- end
+ fun new _ = T
- fun get (T allocs, ty') =
- let
- val (allocs, index) =
- case List.partition (allocs, fn {ty, ...} =>
- Type.equals (ty', ty)) of
- {yes = [], no = allocs} =>
- ({ty = ty', alloc = [{index = 0}]}::allocs,
- {index = 0})
- | {yes = [{ty, alloc}], no = allocs} =>
- let
- fun loop (i, [], alloc') =
- (List.appendRev
- (alloc', [{index = i}]),
- {index = i})
- | loop (i, index::alloc, alloc') =
- if i = #index index
- then loop (i + 1, alloc, index::alloc')
- else (List.appendRev
- ({index = i}::alloc', index::alloc),
- {index = i})
- val (alloc, index) = loop (0, alloc, [])
- in
- ({ty = ty, alloc = alloc}::allocs, index)
- end
- | _ => Error.bug "AllocateRegisters.Allocation.Registers.get"
- in
- (T allocs, index)
- end
+ fun get (rs, ty) = (rs, Register.new ty)
end
- datatype t = T of {stack: Stack.t, registers: Registers.t}
+ datatype t = T of {registers: Registers.t,
+ stack: Stack.t}
+
local
fun make s (T x) = s x
in
@@ -237,6 +185,7 @@
val stackSize = Stack.size o stack
val registers = make #registers
end
+
val empty = T {stack = Stack.empty,
registers = Registers.empty}
@@ -253,13 +202,16 @@
end
fun getRegister (T {stack, registers}, ty) =
let
- val (registers, index) = Registers.get (registers, ty)
+ val (registers, reg) = Registers.get (registers, ty)
in
- (T {stack = stack, registers = registers}, index)
+ (T {registers = registers,
+ stack = stack},
+ reg)
end
fun new (stack, registers) =
- T {stack = Stack.new stack, registers = Registers.new registers}
+ T {registers = Registers.new registers,
+ stack = Stack.new stack}
end
structure Info =
@@ -284,9 +236,8 @@
fun allocate {argOperands: Machine.Operand.t vector,
function = f: Rssa.Function.t,
- newRegister,
varInfo: Var.t -> {operand: Machine.Operand.t option ref option,
- ty: Machine.Type.t}} =
+ ty: Type.t}} =
let
fun diagnostics f =
Control.diagnostics
@@ -373,7 +324,6 @@
in
()
end)
- val nextReg = Type.memo (fn _ => ref 0)
fun allocateVar (x: Var.t,
l: Label.t option,
force: bool,
@@ -387,22 +337,17 @@
case place x of
Stack =>
let
- val (a, {offset}) = Allocation.getStack (a, ty)
+ val (a, {offset}) =
+ Allocation.getStack (a, ty)
in
(a, Operand.StackOffset {ty = ty,
offset = offset})
end
| Register =>
let
-(*
- val r = nextReg ty
- val reg = newRegister (l, !r, ty)
- val _ = Int.inc r
-*)
- val (a, {index}) = Allocation.getRegister (a, ty)
- val reg = newRegister (l, index, ty)
+ val (a, r) = Allocation.getRegister (a, ty)
in
- (a, Operand.Register reg)
+ (a, Operand.Register r)
end
val _ =
case operand of
@@ -416,7 +361,10 @@
val allocateVar =
Trace.trace4
("Allocate.allocateVar",
- Var.layout, Option.layout Label.layout, Bool.layout, Allocation.layout,
+ Var.layout,
+ Option.layout Label.layout,
+ Bool.layout,
+ Allocation.layout,
Allocation.layout)
allocateVar
(* Create the initial stack and set the stack slots for the formals. *)
@@ -427,7 +375,8 @@
case oper of
M.Operand.StackOffset {offset, ...} =>
(valOf (#operand (varInfo x)) := SOME oper
- ; {offset = offset, ty = t} :: ac)
+ ; ({offset = offset, ty = t}
+ :: ac))
| _ => Error.bug "callReturnOperands"))
(* Allocate slots for the link and handler, if necessary. *)
val (stack, handlerLinkOffset) =
@@ -437,7 +386,7 @@
val (stack, {offset = handler, ...}) =
Allocation.Stack.get (stack, Type.label)
val (stack, {offset = link, ...}) =
- Allocation.Stack.get (stack, Type.uint)
+ Allocation.Stack.get (stack, Type.word)
in
(stack, SOME {handler = handler, link = link})
end
@@ -475,7 +424,7 @@
if linkLive
then
Operand.StackOffset {offset = link,
- ty = Type.uint}
+ ty = Type.word}
:: ops
else ops
in
@@ -483,20 +432,23 @@
end)
val liveNoFormals = getOperands beginNoFormals
val (stackInit, registersInit) =
- List.fold (liveNoFormals, ([],[]), fn (oper, (stack, registers)) =>
- case oper of
- Operand.StackOffset a => (a::stack, registers)
- | Operand.Register (Register.T a) => (stack, a::registers)
- | _ => (stack, registers))
+ List.fold
+ (liveNoFormals, ([],[]), fn (oper, (stack, registers)) =>
+ case oper of
+ Operand.StackOffset a => (a::stack, registers)
+ | Operand.Register r => (stack, r::registers)
+ | _ => (stack, registers))
val stackInit =
case handlerLinkOffset of
NONE => stackInit
| SOME {handler, link} =>
{offset = handler, ty = Type.label}
- :: {offset = link, ty = Type.uint}
+ :: {offset = link, ty = Type.word}
:: stackInit
val a = Allocation.new (stackInit, registersInit)
- val size = Runtime.labelSize + Type.wordAlign (Allocation.stackSize a)
+ val size =
+ Runtime.labelSize
+ + Runtime.wordAlignInt (Allocation.stackSize a)
val a =
Vector.fold (args, a, fn ((x, _), a) =>
allocateVar (x, SOME label, false, a))
1.12 +7 -9 mlton/mlton/backend/allocate-registers.sig
Index: allocate-registers.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.sig,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- allocate-registers.sig 10 Apr 2002 07:02:19 -0000 1.11
+++ allocate-registers.sig 7 Dec 2002 02:21:51 -0000 1.12
@@ -22,16 +22,14 @@
val allocate:
{argOperands: Machine.Operand.t vector,
function: Rssa.Function.t,
- newRegister: (Rssa.Label.t option * int * Machine.Type.t
- -> Machine.Register.t),
varInfo: Rssa.Var.t -> {
- (* If (isSome operand) then a stack slot or
- * register needs to be allocated for the
- * variable.
- *)
- operand: Machine.Operand.t option ref option,
- ty: Machine.Type.t
- }
+ (* If (isSome operand) then a stack slot or
+ * register needs to be allocated for the
+ * variable.
+ *)
+ operand: Machine.Operand.t option ref option,
+ ty: Machine.Type.t
+ }
}
-> {(* If handlers are used, handlerLinkOffset gives the stack offsets
* where the handler and link (old exnStack) should be stored.
1.37 +146 -218 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- backend.fun 24 Nov 2002 01:19:43 -0000 1.36
+++ backend.fun 7 Dec 2002 02:21:51 -0000 1.37
@@ -15,33 +15,32 @@
open Machine
in
structure Chunk = Chunk
+ structure Global = Global
+ structure Label = Label
+ structure MemChunk = MemChunk
+ structure ObjectType = ObjectType
+ structure PointerTycon = PointerTycon
+ structure Register = Register
structure Runtime = Runtime
+ structure Type = Type
end
local
open Runtime
in
structure CFunction = CFunction
structure GCField = GCField
- structure ObjectType = ObjectType
end
val wordSize = Runtime.wordSize
-
-structure Rssa = Rssa (open Ssa
- structure Cases = Machine.Cases
- structure Runtime = Runtime
- structure Type = Machine.Type)
+
+structure Rssa = Rssa (open Ssa Machine)
structure R = Rssa
local
open Rssa
in
- structure Cases = Cases
- structure Con = Con
structure Const = Const
structure Func = Func
structure Function = Function
- structure Label = Label
structure Prim = Prim
- structure Tycon = Tycon
structure Type = Type
structure Var = Var
end
@@ -93,8 +92,7 @@
structure Chunk =
struct
datatype t = T of {blocks: M.Block.t list ref,
- chunkLabel: M.ChunkLabel.t,
- regMax: Type.t -> int ref}
+ chunkLabel: M.ChunkLabel.t}
fun label (T {chunkLabel, ...}) = chunkLabel
@@ -102,19 +100,7 @@
fun new (): t =
T {blocks = ref [],
- chunkLabel = M.ChunkLabel.new (),
- regMax = Type.memo (fn _ => ref 0)}
-
- fun register (T {regMax, ...}, n, ty) =
- let
- val r = regMax ty
- val _ = r := Int.max (!r, n + 1)
- in
- M.Register.T {index = n, ty = ty}
- end
-
- fun tempRegister (c as T {regMax, ...}, ty) =
- register (c, !(regMax ty), ty)
+ chunkLabel = M.ChunkLabel.new ()}
fun newBlock (T {blocks, ...}, z) =
List.push (blocks, M.Block.T z)
@@ -127,7 +113,7 @@
fun eliminateDeadCode (f: R.Function.t): R.Function.t =
let
- val {args, blocks, name, start} = R.Function.dest f
+ val {args, blocks, name, returns, raises, start} = R.Function.dest f
val {get, set, ...} =
Property.getSetOnce (Label.plist, Property.initConst false)
val get = Trace.trace ("Backend.labelIsReachable",
@@ -143,6 +129,8 @@
R.Function.new {args = args,
blocks = blocks,
name = name,
+ returns = returns,
+ raises = raises,
start = start}
end
@@ -162,7 +150,19 @@
if !Control.profile = Control.ProfileAlloc
then pass ("profileAlloc", ProfileAlloc.doit, program)
else program
- val program as R.Program.T {functions, main, profileAllocLabels} = program
+ val _ =
+ let
+ open Control
+ in
+ if !keepRSSA
+ then saveToFile ({suffix = "rssa"},
+ No,
+ program,
+ Layouts Rssa.Program.layouts)
+ else ()
+ end
+ val program as R.Program.T {functions, main, objectTypes,
+ profileAllocLabels} = program
val handlesSignals = Rssa.Program.handlesSignals program
(* Chunk information *)
val {get = labelChunk, set = setLabelChunk, ...} =
@@ -172,12 +172,6 @@
Property.getSetOnce (Func.plist,
Property.initRaise ("funcChunk", Func.layout))
val funcChunkLabel = Chunk.label o funcChunk
- val globalCounter = Type.memo (fn _ => Counter.new 0)
- fun newGlobal ty =
- M.Global.T {index = Counter.next (globalCounter ty),
- ty = ty}
- val globalPointerNonRootCounter = Counter.new 0
- val constantCounter = Type.memo (fn _ => Counter.new 0)
val chunks = ref []
fun newChunk () =
let
@@ -212,13 +206,10 @@
NONE =>
let
val opers =
- Vector.map
- (ts, fn t =>
- if Type.isPointer t
- then
- M.Operand.GlobalPointerNonRoot
- (Counter.next globalPointerNonRootCounter)
- else M.Operand.Global (newGlobal t))
+ Vector.map (ts, fn ty =>
+ M.Operand.Global
+ (Global.new {isRoot = false,
+ ty = ty}))
val _ = List.push (table, (ts, opers))
in
opers
@@ -260,7 +251,8 @@
(HashSet.lookupOrInsert
(set, hash, fn {string, ...} => s = string,
fn () => {hash = hash,
- global = newGlobal ty,
+ global = M.Global.new {isRoot = true,
+ ty = ty},
string = s})))
end
fun all () =
@@ -272,9 +264,9 @@
end
in
val (allIntInfs, globalIntInf) =
- make (Type.pointer, fn i => IntInf.format (i, StringCvt.DEC))
- val (allFloats, globalFloat) = make (Type.double, fn s => s)
- val (allStrings, globalString) = make (Type.pointer, fn s => s)
+ make (Type.intInf, fn i => IntInf.format (i, StringCvt.DEC))
+ val (allReals, globalReal) = make (Type.real, fn s => s)
+ val (allStrings, globalString) = make (Type.string, fn s => s)
fun constOperand (c: Const.t): M.Operand.t =
let
datatype z = datatype Const.Node.t
@@ -285,66 +277,22 @@
| IntInf i =>
(case Const.SmallIntInf.toWord i of
NONE => globalIntInf i
- | SOME w => M.Operand.IntInf w)
+ | SOME w => M.Operand.SmallIntInf w)
| Real f =>
if !Control.Native.native
- then globalFloat f
- else M.Operand.Float f
+ then globalReal f
+ else M.Operand.Real f
| String s => globalString s
| Word w =>
let val ty = Const.ty c
in if Const.Type.equals (ty, Const.Type.word)
- then M.Operand.Uint w
+ then M.Operand.Word w
else if Const.Type.equals (ty, Const.Type.word8)
then M.Operand.Char (Char.chr (Word.toInt w))
else Error.bug "strange word"
end
end
end
- (* Hash table for uniqifying object types. *)
- local
- val table = HashSet.new {hash = #hash}
- val arrayHash = Random.word ()
- val normalHash = Random.word ()
- fun hash1 (w: word, i: int): word =
- Word.fromInt i + Word.* (w, 0w31)
- fun hash (i1: int, i2: int, w: word) = hash1 (hash1 (w, i1), i2)
- (* Start the counter at 1 because index 0 is reserved for the stack
- * object type.
- *)
- val counter = Counter.new 1
- fun getIndex (hash: word, ty: ObjectType.t): int =
- #index
- (HashSet.lookupOrInsert
- (table, hash, fn r => ObjectType.equals (ty, #ty r),
- fn () => {hash = hash,
- index = Counter.next counter,
- ty = ty}))
- in
- fun arrayTypeIndex (z as {numBytesNonPointers = nbnp,
- numPointers = np}): int =
- getIndex (hash (nbnp, np, arrayHash), ObjectType.Array z)
- fun normalTypeIndex (z as {numPointers = np,
- numWordsNonPointers = nwnp}): int =
- getIndex (hash (np, nwnp, normalHash), ObjectType.Normal z)
- fun objectTypes () =
- let
- val a = Array.new (Counter.value counter, ObjectType.Stack)
- val _ = HashSet.foreach (table, fn {index, ty, ...} =>
- Array.update (a, index, ty))
- in
- Vector.fromArray a
- end
- (* The GC requires some hardwired type indices -- see gc.h. *)
- val stackTypeIndex = 0
- val stringTypeIndex = (* 1 *)
- arrayTypeIndex {numBytesNonPointers = 1, numPointers = 0}
- val threadTypeIndex = (* 2 *)
- normalTypeIndex {numPointers = 1, numWordsNonPointers = 2}
- val word8VectorTypeIndex = (* 1 *) stringTypeIndex
- val wordVectorTypeIndex = (* 3 *)
- arrayTypeIndex {numBytesNonPointers = 4, numPointers = 0}
- end
fun parallelMove {chunk,
dsts: M.Operand.t vector,
srcs: M.Operand.t vector}: M.Statement.t vector =
@@ -352,8 +300,7 @@
val moves =
Vector.fold2 (srcs, dsts, [],
fn (src, dst, ac) => {src = src, dst = dst} :: ac)
- fun temp r =
- M.Operand.Register (Chunk.tempRegister (chunk, M.Operand.ty r))
+ fun temp r = M.Operand.Register (Register.new (M.Operand.ty r))
in
Vector.fromList
(ParallelMove.move {
@@ -364,35 +311,31 @@
temp = temp
})
end
- val array0Header =
- M.Operand.Uint (Runtime.typeIndexToHeader
- (arrayTypeIndex {numBytesNonPointers = 0,
- numPointers = 0}))
fun translateOperand (oper: R.Operand.t): M.Operand.t =
let
datatype z = datatype R.Operand.t
in
case oper of
- ArrayHeader z =>
- M.Operand.Uint (Runtime.typeIndexToHeader (arrayTypeIndex z))
- | ArrayOffset {base, index, ty} =>
- M.Operand.ArrayOffset {base = varOperand base,
- index = varOperand index,
+ ArrayOffset {base, index, ty} =>
+ M.Operand.ArrayOffset {base = translateOperand base,
+ index = translateOperand index,
ty = ty}
- | CastInt z => M.Operand.CastInt (translateOperand z)
- | CastWord z => M.Operand.CastWord (translateOperand z)
+ | Cast (z, t) => M.Operand.Cast (translateOperand z, t)
| Const c => constOperand c
| EnsuresBytesFree =>
Error.bug "backend translateOperand saw EnsuresBytesFree"
| File => M.Operand.File
| GCState => M.Operand.GCState
| Line => M.Operand.Line
- | Offset {base, bytes, ty} =>
- M.Operand.Offset {base = varOperand base,
- offset = bytes,
+ | Offset {base, offset, ty} =>
+ M.Operand.Offset {base = translateOperand base,
+ offset = offset,
ty = ty}
- | Pointer n => M.Operand.Pointer n
+ | PointerTycon pt =>
+ M.Operand.Word (Runtime.typeIndexToHeader
+ (PointerTycon.index pt))
| Runtime r => M.Operand.Runtime r
+ | SmallIntInf w => M.Operand.SmallIntInf w
| Var {var, ...} => varOperand var
end
fun translateOperands ops = Vector.map (ops, translateOperand)
@@ -419,18 +362,13 @@
Vector.new1
(M.Statement.move {dst = translateOperand dst,
src = translateOperand src})
- | Object {dst, numPointers, numWordsNonPointers, stores} =>
+ | Object {dst, size, stores, tycon, ...} =>
Vector.new1
(M.Statement.Object
{dst = varOperand dst,
header = (Runtime.typeIndexToHeader
- (normalTypeIndex
- {numPointers = numPointers,
- numWordsNonPointers = numWordsNonPointers})),
- size = (Runtime.normalHeaderSize
- + (Runtime.normalSize
- {numPointers = numPointers,
- numWordsNonPointers = numWordsNonPointers})),
+ (PointerTycon.index tycon)),
+ size = size,
stores = Vector.map (stores, fn {offset, value} =>
{offset = offset,
value = translateOperand value})})
@@ -439,42 +377,7 @@
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
- Array_array0 =>
- let
- val frontier =
- M.Operand.Runtime GCField.Frontier
- fun arg i =
- translateOperand (Vector.sub (args, i))
- val numElts = arg 0
- in Vector.new5
- (M.Statement.Move
- {dst = M.Operand.Contents {oper = frontier,
- ty = Type.word},
- src = M.Operand.Uint 0w0},
- M.Statement.Move
- {dst = M.Operand.Offset {base = frontier,
- offset = wordSize,
- ty = Type.int},
- src = numElts},
- M.Statement.Move
- {dst = M.Operand.Offset {base = frontier,
- offset = 2 * wordSize,
- ty = Type.uint},
- src = array0Header},
- M.Statement.PrimApp
- {args = Vector.new2 (frontier,
- M.Operand.Uint
- (Word.fromInt
- (3 * wordSize))),
- dst = SOME (varOperand (#1 (valOf dst))),
- prim = Prim.word32Add},
- M.Statement.PrimApp
- {args = Vector.new2 (frontier,
- M.Operand.Uint (Word.fromInt Runtime.array0Size)),
- dst = SOME frontier,
- prim = Prim.word32Add})
- end
- | MLton_installSignalHandler => Vector.new0 ()
+ MLton_installSignalHandler => Vector.new0 ()
| _ =>
Vector.new1
(M.Statement.PrimApp
@@ -524,14 +427,18 @@
val chunk = funcChunk name
fun labelArgOperands (l: R.Label.t): M.Operand.t vector =
Vector.map (#args (labelInfo l), varOperand o #1)
- fun newVarInfo (x, ty) =
- setVarInfo
- (x, {operand = if isMain
- then
- VarOperand.Const (M.Operand.Global
- (newGlobal ty))
- else VarOperand.Allocate {operand = ref NONE},
- ty = ty})
+ fun newVarInfo (x, ty: Type.t) =
+ let
+ val operand =
+ if isMain
+ then VarOperand.Const (M.Operand.Global
+ (M.Global.new {isRoot = true,
+ ty = ty}))
+ else VarOperand.Allocate {operand = ref NONE}
+ in
+ setVarInfo (x, {operand = operand,
+ ty = ty})
+ end
fun newVarInfos xts = Vector.foreach (xts, newVarInfo)
(* Set the constant operands, labelInfo, and varInfo. *)
val _ = newVarInfos args
@@ -553,20 +460,33 @@
then normal ()
else
let
- fun set oper =
- setVarInfo
- (var, {operand = VarOperand.Const oper,
- ty = M.Operand.ty oper})
+ fun set (z: M.Operand.t,
+ casts: Type.t list) =
+ let
+ val z =
+ List.fold
+ (casts, z, fn (t, z) =>
+ M.Operand.Cast (z, t))
+ in
+ setVarInfo
+ (var, {operand = VarOperand.Const z,
+ ty = M.Operand.ty z})
+ end
+ fun loop (z: R.Operand.t, casts) =
+ case z of
+ R.Operand.Cast (z, t) =>
+ loop (z, t :: casts)
+ | R.Operand.Const c =>
+ set (constOperand c, casts)
+ | R.Operand.Var {var = var', ...} =>
+ (case #operand (varInfo var') of
+ VarOperand.Const z =>
+ set (z, casts)
+ | VarOperand.Allocate _ =>
+ normal ())
+ | _ => normal ()
in
- case oper of
- R.Operand.Const c => set (constOperand c)
- | R.Operand.Pointer n =>
- set (M.Operand.Pointer n)
- | R.Operand.Var {var = var', ...} =>
- (case #operand (varInfo var') of
- VarOperand.Const oper => set oper
- | VarOperand.Allocate _ => normal ())
- | _ => normal ()
+ loop (oper, [])
end
| _ => normal ()
end)
@@ -596,25 +516,16 @@
val {operand, ty, ...} = varInfo x
in
{operand = (case operand of
- VarOperand.Allocate {operand, ...} => SOME operand
+ VarOperand.Allocate {operand, ...} =>
+ SOME operand
| _ => NONE),
ty = ty}
end
- fun newRegister (l, n, ty) =
- let
- val chunk =
- case l of
- NONE => chunk
- | SOME l => labelChunk l
- in
- Chunk.register (chunk, n, ty)
- end
in
val {handlerLinkOffset, labelInfo = labelRegInfo, ...} =
AllocateRegisters.allocate
{argOperands = callReturnOperands (args, #2, 0),
function = f,
- newRegister = newRegister,
varInfo = varInfo}
end
val profileInfoFunc = Func.toString name
@@ -679,7 +590,7 @@
ty = Type.label},
M.Operand.StackOffset
{offset = link,
- ty = Type.uint}))
+ ty = Type.word}))
end
val size =
if !Control.newReturn
@@ -713,8 +624,8 @@
M.Transfer.Goto dst)
| R.Transfer.Raise srcs =>
(M.Statement.moves
- {dsts = raiseOperands (Vector.map
- (srcs, R.Operand.ty)),
+ {dsts = (raiseOperands
+ (Vector.map (srcs, R.Operand.ty))),
srcs = translateOperands srcs},
M.Transfer.Raise)
| R.Transfer.Return xs =>
@@ -726,30 +637,50 @@
dsts = dsts},
M.Transfer.Return {live = dsts})
end
- | R.Transfer.Switch {cases, default, test} =>
+ | R.Transfer.Switch switch =>
let
- fun doit l =
+ fun doit ({cases: ('a * Label.t) vector,
+ default: Label.t option,
+ test: R.Operand.t},
+ make: {cases: ('a * Label.t) vector,
+ default: Label.t option,
+ test: M.Operand.t} -> M.Switch.t) =
simple
- (case (l, default) of
- ([], NONE) => bugTransfer
- | ([(_, dst)], NONE) => M.Transfer.Goto dst
- | ([], SOME dst) => M.Transfer.Goto dst
+ (case (Vector.length cases, default) of
+ (0, NONE) => bugTransfer
+ | (1, NONE) =>
+ M.Transfer.Goto (#2 (Vector.sub (cases, 0)))
+ | (0, SOME dst) => M.Transfer.Goto dst
| _ =>
M.Transfer.Switch
- {cases = cases,
- default = default,
- test = translateOperand test})
+ (make {cases = cases,
+ default = default,
+ test = translateOperand test}))
in
- case cases of
- Cases.Char l => doit l
- | Cases.Int l => doit l
- | Cases.Word l => doit l
+ case switch of
+ R.Switch.Char z => doit (z, M.Switch.Char)
+ | R.Switch.EnumPointers {enum, pointers, test} =>
+ simple
+ (M.Transfer.Switch
+ (M.Switch.EnumPointers
+ {enum = enum,
+ pointers = pointers,
+ test = translateOperand test}))
+ | R.Switch.Int z => doit (z, M.Switch.Int)
+ | R.Switch.Pointer {cases, default, tag, test} =>
+ simple
+ (M.Transfer.Switch
+ (M.Switch.Pointer
+ {cases = (Vector.map
+ (cases, fn {dst, tag, tycon} =>
+ {dst = dst,
+ tag = tag,
+ tycon = tycon})),
+ default = default,
+ tag = translateOperand tag,
+ test = translateOperand test}))
+ | R.Switch.Word z => doit (z, M.Switch.Word)
end
- | R.Transfer.SwitchIP {int, pointer, test} =>
- simple (M.Transfer.SwitchIP
- {int = int,
- pointer = pointer,
- test = translateOperand test})
end
val genTransfer =
Trace.trace ("Backend.genTransfer",
@@ -794,9 +725,9 @@
(liveNoFormals, [], fn (oper, ac) =>
case oper of
M.Operand.StackOffset {offset, ty} =>
- (case Type.dest ty of
- Type.Pointer => offset :: ac
- | _ => ac)
+ if Type.isPointer ty
+ then offset :: ac
+ else ac
| _ => ac)
in
List.push (frames, {chunkLabel = Chunk.label chunk,
@@ -955,10 +886,9 @@
statements = statements,
transfer = transfer}
end
- fun chunkToMachine (Chunk.T {chunkLabel, blocks, regMax}) =
+ fun chunkToMachine (Chunk.T {chunkLabel, blocks}) =
Machine.Chunk.T {chunkLabel = chunkLabel,
- blocks = Vector.fromListMap (!blocks, blockToMachine),
- regMax = ! o regMax}
+ blocks = Vector.fromListMap (!blocks, blockToMachine)}
val mainName = R.Function.name main
val main = {chunkLabel = Chunk.label (funcChunk mainName),
label = funcToLabel mainName}
@@ -981,7 +911,7 @@
case z of
ArrayOffset {base, index, ...} =>
doOperand (base, doOperand (index, max))
- | CastInt z => doOperand (z, max)
+ | Cast (z, _) => doOperand (z, max)
| Contents {oper, ...} => doOperand (oper, max)
| Offset {base, ...} => doOperand (base, max)
| StackOffset {offset, ty} =>
@@ -1001,20 +931,18 @@
in
max
end))
- val maxFrameSize = Type.wordAlign maxFrameSize
+ val maxFrameSize = Runtime.wordAlignInt maxFrameSize
in
Machine.Program.T
{chunks = chunks,
- floats = allFloats (),
frameOffsets = frameOffsets,
- globals = Counter.value o globalCounter,
- globalsNonRoot = Counter.value globalPointerNonRootCounter,
handlesSignals = handlesSignals,
intInfs = allIntInfs (),
main = main,
maxFrameSize = maxFrameSize,
- objectTypes = objectTypes (),
+ objectTypes = objectTypes,
profileAllocLabels = profileAllocLabels,
+ reals = allReals (),
strings = allStrings ()}
end
1.13 +14 -6 mlton/mlton/backend/chunkify.fun
Index: chunkify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/chunkify.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- chunkify.fun 2 Nov 2002 03:37:38 -0000 1.12
+++ chunkify.fun 7 Dec 2002 02:21:51 -0000 1.13
@@ -41,7 +41,19 @@
let
val transferSize =
case transfer of
- Switch {cases, ...} => 1 + Cases.length cases
+ Switch s =>
+ let
+ datatype z = datatype Switch.t
+ fun simple {cases, default, test} =
+ 1 + Vector.length cases
+ in
+ case s of
+ Char z => simple z
+ | EnumPointers _ => 2
+ | Int z => simple z
+ | Pointer {cases, ...} => 1 + Vector.length cases
+ | Word z => simple z
+ end
| _ => 1
in transferSize + Vector.length statements
end
@@ -136,11 +148,7 @@
(same overflow; same success)
| CCall {return, ...} => Option.app (return, same)
| Goto {dst, ...} => same dst
- | Switch {cases, default, ...} =>
- (Cases.foreach (cases, same)
- ; Option.app (default, same))
- | SwitchIP {int, pointer, ...} =>
- (same int; same pointer)
+ | Switch s => Switch.foreachLabel (s, same)
| _ => ()
end)
in
1.28 +15 -17 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- limit-check.fun 4 Nov 2002 15:08:11 -0000 1.27
+++ limit-check.fun 7 Dec 2002 02:21:51 -0000 1.28
@@ -74,16 +74,7 @@
{big: Operand.t -> 'a,
small: word -> 'a}): 'a =
case s of
- Object {numPointers = np, numWordsNonPointers = nwnp, ...} =>
- small (Word.fromInt
- (Runtime.normalHeaderSize
- + Runtime.normalSize {numPointers = np,
- numWordsNonPointers = nwnp}))
- | PrimApp {args, prim, ...} =>
- (case Prim.name prim of
- Prim.Name.Array_array0 =>
- small (Word.fromInt Runtime.array0Size)
- | _ => small 0w0)
+ Object {size, ...} => small (Word.fromInt size)
| _ => small 0w0
end
@@ -122,7 +113,7 @@
blockCheckAmount: {blockIndex: int} -> word,
ensureBytesFree: Label.t -> word) =
let
- val {args, blocks, name, start} = Function.dest f
+ val {args, blocks, name, raises, returns, start} = Function.dest f
val newBlocks = ref []
val (_, allocTooLarge) = Block.allocTooLarge newBlocks
val _ =
@@ -175,8 +166,9 @@
profileInfo = profileInfo,
statements = Vector.new0 (),
transfer =
- Transfer.iff (global, {falsee = dontCollect,
- truee = collect})})
+ Transfer.ifInt
+ (global, {falsee = dontCollect,
+ truee = collect})})
in
(dontCollect',
Vector.new1
@@ -249,7 +241,7 @@
dst = SOME (res, Type.bool),
prim = prim}
val transfer =
- Transfer.iff
+ Transfer.ifBool
(Operand.Var {var = res, ty = Type.bool},
{falsee = dontCollect,
truee = collect})
@@ -396,6 +388,8 @@
Function.new {args = args,
blocks = Vector.fromList (!newBlocks),
name = name,
+ raises = raises,
+ returns = returns,
start = start}
end
@@ -417,7 +411,7 @@
fun insertCoalesce (f: Function.t, handlesSignals) =
let
- val {args, blocks, name, start} = Function.dest f
+ val {args, blocks, name, raises, returns, start} = Function.dest f
val n = Vector.length blocks
val {get = labelIndex, set = setLabelIndex, rem = remLabelIndex, ...} =
Property.getSetOnce
@@ -677,7 +671,7 @@
f
end
-fun insert (p as Program.T {functions, main, profileAllocLabels}) =
+fun insert (p as Program.T {functions, main, objectTypes, profileAllocLabels}) =
let
val _ = Control.diagnostic (fn () => Layout.str "Limit Check maxPaths")
datatype z = datatype Control.limitCheck
@@ -687,7 +681,8 @@
PerBlock => insertPerBlock (f, handlesSignals)
| _ => insertCoalesce (f, handlesSignals)
val functions = List.revMap (functions, insert)
- val {args, blocks, name, start} = Function.dest (insert main)
+ val {args, blocks, name, raises, returns, start} =
+ Function.dest (insert main)
val newStart = Label.newNoname ()
val block =
Block.T {args = Vector.new0 (),
@@ -706,10 +701,13 @@
val main = Function.new {args = args,
blocks = blocks,
name = name,
+ raises = raises,
+ returns = returns,
start = newStart}
in
Program.T {functions = functions,
main = main,
+ objectTypes = objectTypes,
profileAllocLabels = profileAllocLabels}
end
1.29 +293 -214 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- machine.fun 2 Nov 2002 03:37:38 -0000 1.28
+++ machine.fun 7 Dec 2002 02:21:51 -0000 1.29
@@ -5,19 +5,25 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+
functor Machine (S: MACHINE_STRUCTS): MACHINE =
struct
open S
+structure Runtime = Runtime ()
local
open Runtime
in
structure CFunction = CFunction
structure GCField = GCField
- structure Type = Type
end
+structure Atoms = MachineAtoms (structure Label = Label
+ structure Prim = Prim
+ structure Runtime = Runtime)
+open Atoms
+
structure ChunkLabel = IntUniqueId ()
structure SmallIntInf =
@@ -28,45 +34,90 @@
structure Register =
struct
datatype t = T of {index: int,
+ plist: PropertyList.t,
ty: Type.t}
local
fun make f (T r) = f r
in
val index = make #index
+ val plist = make #plist
val ty = make #ty
end
- fun toString (T {index, ty}) =
- concat ["R", Type.name ty, "(", Int.toString index, ")"]
-
- val layout = Layout.str o toString
+ local
+ val c = Counter.new 0
+ in
+ fun new ty = T {index = Counter.next c,
+ plist = PropertyList.new (),
+ ty = ty}
+ end
- fun equals (r1, r2) =
- Type.equals (ty r1, ty r2)
- andalso index r1 = index r2
+ fun layout (T {index, ty, ...}) =
+ let
+ open Layout
+ in
+ seq [str "reg ",
+ record [("index", Int.layout index),
+ ("ty", Type.layout ty)]]
+ end
+
+ val toString = Layout.toString o layout
+
+ fun equals (T {plist = p, ...}, T {plist = p', ...}) =
+ PropertyList.equals (p, p')
end
structure Global =
struct
datatype t = T of {index: int,
+ isRoot: bool,
+ plist: PropertyList.t,
ty: Type.t}
+ fun layout (T {index, ty, ...}) =
+ let
+ open Layout
+ in
+ seq [str "glob ",
+ record [("index", Int.layout index),
+ ("ty", Type.layout ty)]]
+ end
+
+ val toString = Layout.toString o layout
+
local
fun make f (T r) = f r
in
val index = make #index
+ val isRoot = make #isRoot
+ val plist = make #plist
val ty = make #ty
end
- fun toString (T {index, ty}) =
- concat ["G", Type.name ty, "(", Int.toString index, ")"]
+ val nonRootCounter = Counter.new 0
+ fun numberOfNonRoot () = Counter.value nonRootCounter
+
+ val memo = Runtime.Type.memo (fn _ => Counter.new 0)
+ fun numberOfType t = Counter.value (memo t)
- val layout = Layout.str o toString
+ fun new {isRoot, ty} =
+ let
+ val isRoot = isRoot orelse not (Type.isPointer ty)
+ val counter =
+ if isRoot
+ then memo (Type.toRuntime ty)
+ else nonRootCounter
+ val g = T {index = Counter.next counter,
+ isRoot = isRoot,
+ plist = PropertyList.new (),
+ ty = ty}
+ in
+ g
+ end
- fun equals (g1, g2) =
- Type.equals (ty g1, ty g2)
- andalso index g1 = index g2
+ fun equals (T {plist = p, ...}, T {plist = p', ...}) =
+ PropertyList.equals (p, p')
end
structure Operand =
@@ -75,115 +126,117 @@
ArrayOffset of {base: t,
index: t,
ty: Type.t}
- | CastInt of t
- | CastWord of t
+ | Cast of t * Type.t
| Char of char
| Contents of {oper: t,
ty: Type.t}
| File
- | Float of string
| GCState
| Global of Global.t
- | GlobalPointerNonRoot of int
| Int of int
- | IntInf of SmallIntInf.t
+ | SmallIntInf of SmallIntInf.t
| Label of Label.t
| Line
| Offset of {base: t, offset: int, ty: Type.t}
- | Pointer of int
| Register of Register.t
+ | Real of string
| Runtime of GCField.t
| StackOffset of {offset: int, ty: Type.t}
- | Uint of Word.t
+ | Word of Word.t
val rec isLocation =
fn ArrayOffset _ => true
- | CastWord z => isLocation z
+ | Cast (z, _) => isLocation z
| Contents _ => true
| Global _ => true
- | GlobalPointerNonRoot _ => true
| Offset _ => true
| Register _ => true
| Runtime z => true
| StackOffset _ => true
| _ => false
- val rec toString =
- fn ArrayOffset {base, index, ty} =>
- concat ["X", Type.name ty,
- "(", toString base, ",", toString index, ")"]
- | CastInt oper => concat ["(int) (", toString oper, ")"]
- | CastWord oper => concat ["(word) (", toString oper, ")"]
- | Char c => Char.escapeC c
- | Contents {oper, ty} =>
- concat ["C", Type.name ty, "(", toString oper, ")"]
- | File => "<FILE>"
- | Float s => s
- | GCState => "gcState"
- | Global g => Global.toString g
- | GlobalPointerNonRoot n =>
- concat ["globalpointerNonRoot [", Int.toString n, "]"]
- | Int n => Int.toString n
- | IntInf w => concat ["SmallIntInf (", Word.toString w, ")"]
- | Label l => Label.toString l
- | Line => "<LINE>"
- | Offset {base, offset, ty} =>
- concat ["O", Type.name ty,
- "(", toString base, ",", Int.toString offset, ")"]
- | Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
- | Register r => Register.toString r
- | Runtime r => GCField.toString r
- | StackOffset {offset, ty} =>
- concat ["S", Type.name ty, "(", Int.toString offset, ")"]
- | Uint w => concat ["0x", Word.toString w]
+ fun layout (z: t): Layout.t =
+ let
+ open Layout
+ fun constrain (ty: Type.t): Layout.t =
+ if !Control.showTypes
+ then seq [str ": ", Type.layout ty]
+ else empty
+ in
+ case z of
+ ArrayOffset {base, index, ty} =>
+ seq [str (concat ["X", Type.name ty, " "]),
+ tuple [layout base, layout index],
+ constrain ty]
+ | Cast (z, ty) =>
+ seq [str "Cast ", tuple [layout z, Type.layout ty]]
+ | Char c => str (Char.escapeC c)
+ | Contents {oper, ty} =>
+ seq [str (concat ["C", Type.name ty, " "]),
+ paren (layout oper)]
+ | File => str "<File>"
+ | GCState => str "<GCState>"
+ | Global g => Global.layout g
+ | Int i => Int.layout i
+ | Label l => Label.layout l
+ | Line => str "<Line>"
+ | Offset {base, offset, ty} =>
+ seq [str (concat ["O", Type.name ty, " "]),
+ tuple [layout base, Int.layout offset],
+ constrain ty]
+ | Real s => str s
+ | Register r => Register.layout r
+ | Runtime r => GCField.layout r
+ | SmallIntInf w => seq [str "SmallIntInf ", paren (Word.layout w)]
+ | StackOffset {offset, ty} =>
+ seq [str (concat ["S", Type.name ty, " "]),
+ paren (Int.layout offset)]
+ | Word w => seq [str "0x", Word.layout w]
+ end
- val layout = Layout.str o toString
+ val toString = Layout.toString o layout
val ty =
fn ArrayOffset {ty, ...} => ty
- | CastInt _ => Type.int
- | CastWord _ => Type.word
+ | Cast (_, ty) => ty
| Char _ => Type.char
| Contents {ty, ...} => ty
- | File => Type.pointer
- | Float _ => Type.double
- | GCState => Type.pointer
+ | File => Type.cpointer
+ | GCState => Type.cpointer
| Global g => Global.ty g
- | GlobalPointerNonRoot _ => Type.pointer
| Int _ => Type.int
- | IntInf _ => Type.pointer
| Label _ => Type.label
| Line => Type.int
| Offset {ty, ...} => ty
- | Pointer _ => Type.pointer
+ | Real _ => Type.real
| Register r => Register.ty r
- | Runtime z => GCField.ty z
+ | Runtime z => Type.fromRuntime (GCField.ty z)
+ | SmallIntInf _ => Type.intInf
| StackOffset {ty, ...} => ty
- | Uint _ => Type.uint
+ | Word _ => Type.word
val rec equals =
fn (ArrayOffset {base = b, index = i, ...},
ArrayOffset {base = b', index = i', ...}) =>
equals (b, b') andalso equals (i, i')
- | (CastInt z, CastInt z') => equals (z, z')
- | (CastWord z, CastWord z') => equals (z, z')
+ | (Cast (z, t), Cast (z', t')) =>
+ Type.equals (t, t') andalso equals (z, z')
| (Char c, Char c') => c = c'
| (Contents {oper = z, ...}, Contents {oper = z', ...}) =>
equals (z, z')
| (File, File) => true
- | (Float f, Float f') => f = f'
| (GCState, GCState) => true
- | (Int n, Int n') => n = n'
- | (IntInf w, IntInf w') => Word.equals (w, w')
+ | (Int i, Int i') => i = i'
| (Line, Line) => true
| (Offset {base = b, offset = i, ...},
Offset {base = b', offset = i', ...}) =>
equals (b, b') andalso i = i'
- | (Pointer n, Pointer n') => n = n'
+ | (Real s, Real s') => s = s'
| (Register r, Register r') => Register.equals (r, r')
+ | (SmallIntInf w, SmallIntInf w') => Word.equals (w, w')
| (StackOffset {offset = n, ...}, StackOffset {offset = n', ...}) =>
n = n'
- | (Uint w, Uint w') => w = w'
+ | (Word w, Word w') => w = w'
| _ => false
fun interfere {write: t, read: t}: bool =
@@ -193,7 +246,6 @@
inter base orelse inter index
| (Contents {oper, ...}, _) => inter oper
| (Global g, Global g') => Global.equals (g, g')
- | (GlobalPointerNonRoot i, GlobalPointerNonRoot j) => i = j
| (Offset {base, offset, ...}, _) => inter base
| (Register r, Register r') => Register.equals (r, r')
| (StackOffset {offset = off, ty = ty},
@@ -207,6 +259,9 @@
end
end
+structure Switch = Switch (open Atoms
+ structure Use = Operand)
+
structure Statement =
struct
datatype t =
@@ -274,9 +329,16 @@
| PrimApp {args, dst, ...} =>
Vector.fold (args, Option.fold (dst, ac, f), f)
| _ => ac
- end
-structure Cases = MachineCases (structure Label = Label)
+ fun foldDefs (s, a, f) =
+ case s of
+ Move {dst, ...} => f (dst, a)
+ | Object {dst, ...} => f (dst, a)
+ | PrimApp {dst, ...} => (case dst of
+ NONE => a
+ | SOME z => f (z, a))
+ | _ => a
+ end
structure FrameInfo =
struct
@@ -318,12 +380,7 @@
| Goto of Label.t
| Raise
| Return of {live: Operand.t vector}
- | Switch of {cases: Cases.t,
- default: Label.t option,
- test: Operand.t}
- | SwitchIP of {int: Label.t,
- pointer: Label.t,
- test: Operand.t}
+ | Switch of Switch.t
fun layout t =
let
@@ -360,24 +417,23 @@
| Return {live} =>
seq [str "Return ",
record [("live", Vector.layout Operand.layout live)]]
- | Switch {test, cases, default} =>
- seq [str "Switch ",
- tuple [Operand.layout test,
- Cases.layout cases,
- Option.layout Label.layout default]]
- | SwitchIP {test, int, pointer} =>
- seq [str "SwitchIP ", tuple [Operand.layout test,
- Label.layout int,
- Label.layout pointer]]
+ | Switch s => Switch.layout s
end
- fun foldOperands (t, ac, f) =
+ fun foldOperands (t, ac, f) =
+ case t of
+ Arith {args, dst, ...} => Vector.fold (args, f (dst, ac), f)
+ | CCall {args, ...} => Vector.fold (args, ac, f)
+ | Switch s =>
+ Switch.foldLabelUse
+ (s, ac, {label = fn (_, a) => a,
+ use = f})
+ | _ => ac
+
+ fun foldDefs (t, a, f) =
case t of
- Arith {args, dst, ...} => Vector.fold (args, f (dst, ac), f)
- | CCall {args, ...} => Vector.fold (args, ac, f)
- | Switch {test, ...} => f (test, ac)
- | SwitchIP {test, ...} => f (test, ac)
- | _ => ac
+ Arith {dst, ...} => f (dst, a)
+ | _ => a
end
structure Kind =
@@ -456,73 +512,80 @@
end
fun layouts (block, output' : Layout.t -> unit) = output' (layout block)
+
+ fun foldDefs (T {kind, statements, transfer, ...}, a, f) =
+ let
+ val a =
+ case kind of
+ Kind.CReturn {dst, ...} =>
+ (case dst of
+ NONE => a
+ | SOME z => f (z, a))
+ | _ => a
+ val a =
+ Vector.fold (statements, a, fn (s, a) =>
+ Statement.foldDefs (s, a, f))
+ val a = Transfer.foldDefs (transfer, a, f)
+ in
+ a
+ end
end
structure Chunk =
struct
datatype t = T of {chunkLabel: ChunkLabel.t,
- blocks: Block.t vector,
- regMax: Type.t -> int}
+ blocks: Block.t vector}
- fun layout (T {blocks, regMax, ...}) =
+ fun layout (T {blocks, ...}) =
let
open Layout
in
- align
- [align (List.map (Type.all, fn t =>
- seq [str "regMax ", Type.layout t,
- str " = ", Int.layout (regMax t)])),
- align (Vector.toListMap (blocks, Block.layout))]
+ align (Vector.toListMap (blocks, Block.layout))
end
- fun layouts (c as T {blocks, regMax, ...}, output' : Layout.t -> unit) =
- let
- open Layout
- val output = output'
- in
- List.foreach (Type.all, fn t =>
- output (seq [str "regMax ", Type.layout t,
- str " = ", Int.layout (regMax t)]))
- ; Vector.foreach (blocks, fn block => Block.layouts (block, output))
- end
+ fun layouts (c as T {blocks, ...}, output : Layout.t -> unit) =
+ Vector.foreach (blocks, fn block => Block.layouts (block, output))
+
+
+ fun foldRegs (T {blocks, ...}, a, f) =
+ Vector.fold
+ (blocks, a, fn (b, a) =>
+ Block.foldDefs
+ (b, a, fn (z, a) =>
+ case z of
+ Operand.Register r => f (r, a)
+ | _ => a))
end
structure Program =
struct
datatype t = T of {chunks: Chunk.t list,
- floats: (Global.t * string) list,
frameOffsets: int vector vector,
- globals: Type.t -> int,
- globalsNonRoot: int,
handlesSignals: bool,
intInfs: (Global.t * string) list,
main: {chunkLabel: ChunkLabel.t,
label: Label.t},
maxFrameSize: int,
- objectTypes: Runtime.ObjectType.t vector,
+ objectTypes: ObjectType.t vector,
profileAllocLabels: string vector,
+ reals: (Global.t * string) list,
strings: (Global.t * string) list}
- fun layouts (p as T {chunks, frameOffsets, globals, globalsNonRoot,
- handlesSignals, main = {label, ...}, maxFrameSize,
- objectTypes, profileAllocLabels, ...},
+ fun layouts (p as T {chunks, frameOffsets, handlesSignals,
+ main = {label, ...},
+ maxFrameSize, objectTypes,
+ profileAllocLabels, ...},
output': Layout.t -> unit) =
let
open Layout
val output = output'
in
output (record
- [("globals",
- List.layout (fn t =>
- seq [Type.layout t, str " ",
- Int.layout (globals t)])
- Type.all),
- ("globalsNonRoot", Int.layout globalsNonRoot),
- ("handlesSignals", Bool.layout handlesSignals),
+ [("handlesSignals", Bool.layout handlesSignals),
("main", Label.layout label),
("maxFrameSize", Int.layout maxFrameSize),
- ("objectTypes",
- Vector.layout Runtime.ObjectType.layout objectTypes),
+ ("pointerTypes",
+ Vector.layout ObjectType.layout objectTypes),
("profileAllocLabels",
Vector.layout String.layout profileAllocLabels),
("frameOffsets",
@@ -530,11 +593,20 @@
; List.foreach (chunks, fn chunk => Chunk.layouts (chunk, output))
end
- fun typeCheck (T {chunks, floats, frameOffsets, globals, globalsNonRoot,
- intInfs, main, maxFrameSize, objectTypes, strings, ...})
- =
+ fun foldRegs (T {chunks, ...}, a, f) =
+ List.fold (chunks, a, fn (c, a) => Chunk.foldRegs (c, a, f))
+
+ fun typeCheck (T {chunks, frameOffsets, intInfs, main,
+ maxFrameSize, objectTypes, reals, strings, ...}) =
let
- val numTypeIndices = Vector.length objectTypes
+ val _ =
+ Vector.foreach
+ (objectTypes, fn ty =>
+ Err.check ("objectType",
+ fn () => ObjectType.isOk ty,
+ fn () => ObjectType.layout ty))
+ fun tyconTy (pt: PointerTycon.t): ObjectType.t =
+ Vector.sub (objectTypes, PointerTycon.index pt)
open Layout
fun globals (name, gs, ty) =
List.foreach
@@ -543,9 +615,9 @@
fn () => Type.equals (ty, Global.ty g),
fn () =>
seq [String.layout s, str ": ", Type.layout ty]))
- val _ = globals ("float", floats, Type.double)
- val _ = globals ("intInf", intInfs, Type.pointer)
- val _ = globals ("string", strings, Type.pointer)
+ val _ = globals ("real", reals, Type.real)
+ val _ = globals ("intInf", intInfs, Type.intInf)
+ val _ = globals ("string", strings, Type.string)
val {get = labelBlock: Label.t -> Block.t,
set = setLabelBlock, ...} =
Property.getSetOnce (Label.plist,
@@ -559,54 +631,101 @@
val _ =
List.foreach
(chunks,
- fn Chunk.T {chunkLabel, blocks, regMax} =>
+ fn Chunk.T {blocks, ...} =>
let
fun checkOperand (x: Operand.t): unit =
let
datatype z = datatype Operand.t
fun ok () =
case x of
- ArrayOffset {base, index, ty} =>
- (checkOperand base
- ; checkOperand index
- ; (Type.equals (Operand.ty base, Type.pointer)
- andalso Type.equals (Operand.ty index,
- Type.int)))
- | CastInt x =>
- (checkOperand x
- ; Type.equals (Operand.ty x, Type.pointer))
- | CastWord x =>
- (checkOperand x
- ; (Type.equals (Operand.ty x, Type.pointer)
- orelse
- Type.equals (Operand.ty x, Type.int)))
+ ArrayOffset z => arrayOffsetIsOk z
+ | Cast (z, t) =>
+ (checkOperand z
+ ; (castIsOk
+ {from = Operand.ty z,
+ fromInt = (case z of
+ Int i => SOME i
+ | _ => NONE),
+ to = t,
+ tyconTy = tyconTy}))
| Char _ => true
| Contents {oper, ...} =>
(checkOperand oper
- ; Type.equals (Operand.ty oper, Type.pointer))
+ ; Type.equals (Operand.ty oper,
+ Type.cpointer))
| File => true
- | Float _ => true
| GCState => true
| Global _ => true
- | GlobalPointerNonRoot n =>
- 0 <= n andalso n < globalsNonRoot
| Int _ => true
- | IntInf w => 0wx1 = Word.andb (w, 0wx1)
| Label l => (labelBlock l; true)
| Line => true
- | Offset {base, ...} =>
- (checkOperand base
- ; Type.equals (Operand.ty base, Type.pointer))
- | Pointer n => 0 < Int.rem (n, Runtime.wordSize)
- | Register (Register.T {index, ty}) =>
- 0 <= index andalso index < regMax ty
+ | Offset z => offsetIsOk z
+ | Real _ => true
+ | Register _ => true
| Runtime _ => true
+ | SmallIntInf w => 0wx1 = Word.andb (w, 0wx1)
| StackOffset {offset, ty, ...} =>
offset + Type.size ty <= maxFrameSize
- | Uint _ => true
+ | Word _ => true
in
Err.check ("operand", ok, fn () => Operand.layout x)
end
+ and arrayOffsetIsOk {base, index, ty} =
+ let
+ val _ = checkOperand base
+ val _ = checkOperand index
+ in
+ Type.equals (Operand.ty index, Type.int)
+ andalso
+ case Operand.ty base of
+ Type.CPointer => true (* needed for card marking *)
+ | Type.EnumPointers {enum, pointers} =>
+ 0 = Vector.length enum
+ andalso
+ Vector.forall
+ (pointers, fn p =>
+ case tyconTy p of
+ ObjectType.Array
+ (MemChunk.T {components, ...}) =>
+ 1 = Vector.length components
+ andalso
+ let
+ val {offset, ty = ty', ...} =
+ Vector.sub (components, 0)
+ in
+ offset = 0
+ andalso Type.equals (ty, ty')
+ end
+ | _ => false)
+ | _ => false
+ end
+ and offsetIsOk {base, offset, ty} =
+ let
+ val _ = checkOperand base
+ fun memChunkIsOk (MemChunk.T {components, ...}) =
+ case (Vector.peek
+ (components, fn {offset = offset', ...} =>
+ offset = offset')) of
+ NONE => false
+ | SOME {ty = ty', ...} => Type.equals (ty, ty')
+
+ in
+ case Operand.ty base of
+ Type.EnumPointers {enum, pointers} =>
+ 0 = Vector.length enum
+ andalso
+ ((* Vector_fromArray header update. *)
+ (offset = Runtime.headerOffset
+ andalso Type.equals (ty, Type.word))
+ orelse
+ Vector.forall
+ (pointers, fn p =>
+ case tyconTy p of
+ ObjectType.Normal m => memChunkIsOk m
+ | _ => false))
+ | Type.MemChunk m => memChunkIsOk m
+ | _ => false
+ end
fun checkOperands v = Vector.foreach (v, checkOperand)
fun check' (x, name, isOk, layout) =
Err.check (name, fn () => isOk x, fn () => layout x)
@@ -619,40 +738,6 @@
andalso 0 = Int.rem (size, 4)
fun checkFrameInfo i =
check' (i, "frame info", frameInfoOk, FrameInfo.layout)
- fun isValidNormal ({numPointers = np,
- numWordsNonPointers = nwnp},
- stores): bool =
- let
- val pointerStart = nwnp * Runtime.wordSize
- val pointerEnd = pointerStart + np * Runtime.pointerSize
- val initPointers = Array.new (np, false)
- in
- (* Check that every store is valid *)
- Vector.forall
- (stores, fn {offset, value} =>
- let
- val _ = checkOperand value
- val ty = Operand.ty value
- in
- if Type.isPointer ty
- then
- pointerStart <= offset
- andalso offset < pointerEnd
- andalso Runtime.isWordAligned offset
- andalso (Array.update
- (initPointers,
- Int.quot (offset - pointerStart,
- Runtime.pointerSize),
- true)
- ; true)
- else
- 0 <= offset
- andalso (offset + Type.size ty <= pointerStart)
- end)
- andalso
- (* Check that every pointer is initialized. *)
- Array.forall (initPointers, fn b => b)
- end
fun kindOk (k: Kind.t): bool =
let
datatype z = datatype Kind.t
@@ -686,8 +771,13 @@
; (case Vector.sub (objectTypes,
Runtime.headerToTypeIndex
header) of
- Runtime.ObjectType.Normal z =>
- isValidNormal (z, stores)
+ ObjectType.Normal mc =>
+ MemChunk.isValidInit
+ (mc,
+ Vector.map
+ (stores, fn {offset, value} =>
+ {offset = offset,
+ ty = Operand.ty value}))
| _ => false) handle Subscript => false)
| PrimApp {args, dst, prim} =>
(Option.app (dst, checkOperand)
@@ -732,8 +822,10 @@
(case (dst, CFunction.returnTy f) of
(NONE, _) => true
| (SOME x, SOME ty) =>
- Type.equals
- (ty, Operand.ty x)
+ Runtime.Type.equals
+ (ty,
+ Type.toRuntime
+ (Operand.ty x))
| _ => false)
| _ => false
end
@@ -760,21 +852,8 @@
| Goto l => labelIsJump l
| Raise => true
| Return {live} => (checkOperands live; true)
- | Switch {cases, default, test} =>
- (checkOperand test
- ; (Cases.forall (cases, labelIsJump)
- andalso Option.forall (default, labelIsJump)
- andalso
- (Type.equals
- (Operand.ty test,
- case cases of
- Cases.Char _ => Type.char
- | Cases.Int _ => Type.int
- | Cases.Word _ => Type.uint))))
- | SwitchIP {int, pointer, test} =>
- (checkOperand test
- ; (labelIsJump pointer
- andalso labelIsJump int))
+ | Switch s =>
+ Switch.isOk (s, {labelIsOk = labelIsJump})
end
fun blockOk (Block.T {kind, label, live, profileInfo,
statements, transfer}): bool =
1.22 +32 -34 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- machine.sig 2 Nov 2002 03:37:38 -0000 1.21
+++ machine.sig 7 Dec 2002 02:21:52 -0000 1.22
@@ -12,39 +12,44 @@
sig
structure Label: HASH_ID
structure Prim: PRIM
- structure Runtime: RUNTIME
end
signature MACHINE =
sig
- include MACHINE_STRUCTS
+ include MACHINE_ATOMS
+ structure Switch: SWITCH
+ sharing Label = Switch.Label
+ sharing PointerTycon = Switch.PointerTycon
+ sharing Type = Switch.Type
structure CFunction: C_FUNCTION
sharing CFunction = Runtime.CFunction
structure ChunkLabel: UNIQUE_ID
- structure Type: MTYPE
- sharing Type = Runtime.Type
structure Register:
sig
- datatype t = T of {index: int,
- ty: Type.t}
+ type t
val equals: t * t -> bool
- val index: t -> int
+ val index: t -> int
val layout: t -> Layout.t
+ val new: Type.t -> t
+ val plist: t -> PropertyList.t
val toString: t -> string
val ty: t -> Type.t
end
structure Global:
sig
- datatype t = T of {index: int,
- ty: Type.t}
+ type t
val equals: t * t -> bool
val index: t -> int
+ val isRoot: t -> bool
val layout: t -> Layout.t
+ val new: {isRoot: bool, ty: Type.t} -> t
+ val numberOfNonRoot: unit -> int
+ val numberOfType: Runtime.Type.t -> int
val toString: t -> string
val ty: t -> Type.t
end
@@ -55,29 +60,26 @@
ArrayOffset of {base: t,
index: t,
ty: Type.t}
- | CastInt of t (* takes an IntOrPointer and makes it an int *)
- | CastWord of t (* takes a pointer and makes it a word *)
+ | Cast of t * Type.t
| Char of char
| Contents of {oper: t,
ty: Type.t}
| File (* expand by codegen into string constant *)
- | Float of string
| GCState
| Global of Global.t
- | GlobalPointerNonRoot of int
| Int of int
- | IntInf of word
| Label of Label.t
| Line (* expand by codegen into int constant *)
| Offset of {base: t,
offset: int,
ty: Type.t}
- | Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
+ | Real of string
| Register of Register.t
| Runtime of Runtime.GCField.t
+ | SmallIntInf of word
| StackOffset of {offset: int,
ty: Type.t}
- | Uint of Word.t
+ | Word of Word.t
val equals: t * t -> bool
val interfere: {write: t, read: t} -> bool
@@ -85,6 +87,7 @@
val toString: t -> string
val ty: t -> Type.t
end
+ sharing Operand = Switch.Use
structure Statement:
sig
@@ -117,8 +120,6 @@
srcs: Operand.t vector} -> t vector
end
- structure Cases: MACHINE_CASES sharing Label = Cases.Label
-
structure FrameInfo:
sig
datatype t =
@@ -160,16 +161,7 @@
| Goto of Label.t (* label must be a Jump *)
| Raise
| Return of {live: Operand.t vector}
- | Switch of {test: Operand.t,
- cases: Cases.t,
- default: Label.t option}
- (* Switch to one of two labels, based on whether the operand is an
- * Integer or a Pointer. Pointers are word aligned and integers
- * are not.
- *)
- | SwitchIP of {int: Label.t,
- pointer: Label.t,
- test: Operand.t}
+ | Switch of Switch.t
val foldOperands: t * 'a * (Operand.t * 'a -> 'a) -> 'a
val layout: t -> Layout.t
@@ -208,31 +200,37 @@
structure Chunk:
sig
datatype t = T of {blocks: Block.t vector,
- chunkLabel: ChunkLabel.t,
- regMax: Type.t -> int}
+ chunkLabel: ChunkLabel.t}
+
+ (* Fold over each register that appears in the chunk.
+ * May visit duplicates.
+ *)
+ val foldRegs: t * 'a * (Register.t * 'a -> 'a) -> 'a
end
structure Program:
sig
datatype t =
T of {chunks: Chunk.t list,
- floats: (Global.t * string) list,
(* Each vector in frame Offsets specifies the offsets
* of live pointers in a stack frame. A vector is referred
* to by index as the frameOffsetsIndex in a block kind.
*)
frameOffsets: int vector vector,
- globals: Type.t -> int,
- globalsNonRoot: int,
handlesSignals: bool,
intInfs: (Global.t * string) list,
main: {chunkLabel: ChunkLabel.t,
label: Label.t},
maxFrameSize: int,
- objectTypes: Runtime.ObjectType.t vector,
+ objectTypes: ObjectType.t vector,
profileAllocLabels: string vector,
+ reals: (Global.t * string) list,
strings: (Global.t * string) list}
+ (* Fold over each register that appears in the chunk.
+ * May visit duplicates.
+ *)
+ val foldRegs: t * 'a * (Register.t * 'a -> 'a) -> 'a
val layouts: t * (Layout.t -> unit) -> unit
val typeCheck: t -> unit
end
1.3 +7 -14 mlton/mlton/backend/profile-alloc.fun
Index: profile-alloc.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile-alloc.fun,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- profile-alloc.fun 2 Nov 2002 03:37:38 -0000 1.2
+++ profile-alloc.fun 7 Dec 2002 02:21:52 -0000 1.3
@@ -27,7 +27,7 @@
returnTy = NONE}
end
-fun doit (Program.T {functions, main, ...}) =
+fun doit (Program.T {functions, main, objectTypes, ...}) =
let
(* Start the counter at 1 because element 0 is PROFILE_ALLOC_MISC. *)
val counter = Counter.new 1
@@ -35,9 +35,9 @@
val labelIndex = String.memoize (fn s =>
(List.push (profileAllocLabels, s)
; Counter.next counter))
- fun doFunction (f: Function.t) =
+ fun doFunction (f: Function.t): Function.t =
let
- val {args, blocks, name, start} = Function.dest f
+ val {args, blocks, name, raises, returns, start} = Function.dest f
val extraBlocks = ref []
val blocks =
Vector.map
@@ -49,17 +49,7 @@
Vector.fold
(statements, 0, fn (s, ac) =>
case s of
- Statement.Object {numPointers, numWordsNonPointers,
- ...} =>
- ac
- + Runtime.normalHeaderSize
- + (Runtime.normalSize
- {numPointers = numPointers,
- numWordsNonPointers = numWordsNonPointers})
- | Statement.PrimApp {prim, ...} =>
- (case Prim.name prim of
- Prim.Name.Array_array0 => ac + Runtime.array0Size
- | _ => ac)
+ Statement.Object {size, ...} => ac + size
| _ => ac)
val needs =
case transfer of
@@ -123,6 +113,8 @@
Function.new {args = args,
blocks = blocks,
name = name,
+ raises = raises,
+ returns = returns,
start = start}
end
val functions = List.revMap (functions, doFunction)
@@ -131,6 +123,7 @@
in
Program.T {functions = functions,
main = main,
+ objectTypes = objectTypes,
profileAllocLabels = profileAllocLabels}
end
1.9 +507 -192 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- representation.fun 24 Nov 2002 01:19:43 -0000 1.8
+++ representation.fun 7 Dec 2002 02:21:52 -0000 1.9
@@ -12,262 +12,577 @@
struct
open S
-local open Ssa
+structure R = Rssa
+local
+ open Rssa
+in
+ structure ObjectType = ObjectType
+ structure PointerTycon = PointerTycon
+ structure Runtime = Runtime
+end
+structure S = Ssa
+local
+ open Ssa
in
structure Con = Con
- structure Datatype = Datatype
structure Tycon = Tycon
- structure Type = Type
end
structure TyconRep =
struct
datatype t =
- Enum of {numEnum: int}
- | EnumDirect of {numEnum: int}
- | EnumIndirect of {numEnum: int}
- | EnumIndirectTag of {numEnum: int,
- numTag: int}
- | IndirectTag of {numTag: int}
- | Prim of Mtype.t
+ Direct
+ | Enum
+ | EnumDirect
+ | EnumIndirect
+ | EnumIndirectTag
+ | IndirectTag
| Void
- val pointer = Prim Mtype.pointer
-
- val toMtype =
- fn Enum _ => SOME Mtype.int
- | EnumDirect _ => SOME Mtype.pointer
- | EnumIndirect _ => SOME Mtype.pointer
- | EnumIndirectTag _ => SOME Mtype.pointer
- | IndirectTag _ => SOME Mtype.pointer
- | Prim t => SOME t
- | Void => NONE
-
val layout =
let
open Layout
in
- fn Enum {numEnum} => seq [str "Enum ", Int.layout numEnum]
- | EnumDirect {numEnum} =>
- seq [str "EnumDirect ", Int.layout numEnum]
- | EnumIndirect {numEnum} =>
- seq [str "EnumIndirect ", Int.layout numEnum]
- | EnumIndirectTag {numEnum, numTag} =>
- seq [str "EnumIndirectTag",
- record [("numEnum", Int.layout numEnum),
- ("numTag", Int.layout numTag)]]
- | IndirectTag {numTag} =>
- seq [str "IndirectTag ", Int.layout numTag]
- | Prim m => Mtype.layout m
+ fn Direct => str "Direct"
+ | Enum => str "Enum"
+ | EnumDirect => str "EnumDirect"
+ | EnumIndirect => str "EnumIndirect"
+ | EnumIndirectTag => str "EnumIndirectTag"
+ | IndirectTag => str "IndirectTag"
| Void => str "Void"
end
- val equals =
- fn (Prim t, Prim t') => Mtype.equals (t, t')
- | (Enum {numEnum = n}, Enum {numEnum = n'}) => n = n'
- | (EnumDirect {numEnum = n}, EnumDirect {numEnum = n'}) => n = n'
- | (EnumIndirect {numEnum = n}, EnumIndirect {numEnum = n'}) => n = n'
- | (EnumIndirectTag {numEnum = n, numTag = t},
- EnumIndirectTag {numEnum = n', numTag = t'}) =>
- n = n' andalso t = t'
- | (IndirectTag {numTag = n}, IndirectTag {numTag = n'}) => n = n'
- | (Void, Void) => true
- | _ => false
+ val equals:t * t -> bool = op =
end
-structure ConRep =
+structure TupleRep =
struct
- datatype t =
- Void
- | Int of int
- | IntCast of int
- | Transparent of Mtype.t
- | Tuple
- | TagTuple of int
+ datatype t = T of {offsets: {offset: int,
+ ty: R.Type.t} option vector,
+ size: int,
+ ty: R.Type.t,
+ tycon: R.PointerTycon.t}
+
+ fun layout (T {offsets, size, ty, tycon, ...}) =
+ let
+ open Layout
+ in record [("offsets",
+ Vector.layout (Option.layout
+ (fn {offset, ty} =>
+ record [("offset", Int.layout offset),
+ ("ty", R.Type.layout ty)]))
+ offsets),
+ ("size", Int.layout size),
+ ("ty", R.Type.layout ty),
+ ("tycon", R.PointerTycon.layout tycon)]
+ end
local
- open Layout
+ fun make f (T r) = f r
in
- val layout =
- fn Void => str "Void"
- | Int n => seq [str "Int ", Int.layout n]
- | IntCast n => seq [str "IntCast ", Int.layout n]
- | Transparent t => seq [str "Transparent ", Mtype.layout t]
- | Tuple => str "Tuple"
- | TagTuple n => seq [str "TagTuple ", Int.layout n]
+ val tycon = make #tycon
end
end
-(* fixed-point. Initially assume all datatype tycons are Void
- * Change them if they have more than one variant or contain
- * a useful component
- *)
+structure ConRep =
+ struct
+ datatype t =
+ IntAsTy of {int: int,
+ ty: R.Type.t}
+ | TagTuple of {rep: TupleRep.t,
+ tag: int}
+ | Transparent of R.Type.t
+ | Tuple of TupleRep.t
+ | Void
+
+ val layout =
+ let
+ open Layout
+ in
+ fn IntAsTy {int, ty} =>
+ seq [Int.layout int, str ": ", R.Type.layout ty]
+ | TagTuple {rep, tag} =>
+ seq [str "TagTuple ",
+ record [("rep", TupleRep.layout rep),
+ ("tag", Int.layout tag)]]
+ | Transparent t => seq [str "Transparent ", R.Type.layout t]
+ | Tuple r => seq [str "Tuple ", TupleRep.layout r]
+ | Void => str "Void"
+ end
+ end
-fun compute (Ssa.Program.T {datatypes, ...}) =
- let
+fun compute (program as Ssa.Program.T {datatypes, ...}) =
+ let
val {get = tyconRep, set = setTyconRep, ...} =
- Property.getSet (Tycon.plist, Property.initRaise ("rep", Tycon.layout))
+ Property.getSet (Tycon.plist,
+ Property.initRaise ("rep", Tycon.layout))
val tyconRep =
Trace.trace ("tyconRep", Tycon.layout, TyconRep.layout) tyconRep
val {get = conRep, set = setConRep, ...} =
- Property.getSetOnce (Con.plist, Property.initRaise ("rep", Con.layout))
- val tyconMtype = TyconRep.toMtype o tyconRep
- fun toMtype t =
+ Property.getSetOnce (Con.plist,
+ Property.initRaise ("rep", Con.layout))
+ fun isEmpty (t: S.Type.t): bool =
let
- datatype z = datatype Type.dest
+ datatype z = datatype S.Type.dest
in
- case Type.dest t of
- Array _ => SOME Mtype.pointer
- | Char => SOME Mtype.char
- | Datatype c => tyconMtype c
- | Int => SOME Mtype.int
- | IntInf => SOME Mtype.pointer
- | Pointer => SOME Mtype.uint
- | PreThread => SOME Mtype.pointer
- | Real => SOME Mtype.double
- | Ref _ => SOME Mtype.pointer
- | Thread => SOME Mtype.pointer
- | Tuple ts => if Vector.isEmpty ts
- then NONE
- else SOME Mtype.pointer
- | Vector _ => SOME Mtype.pointer
- | Word => SOME Mtype.uint
- | Word8 => SOME Mtype.char
+ case S.Type.dest t of
+ Datatype c => (case tyconRep c of
+ TyconRep.Void => true
+ | _ => false)
+ | Tuple ts => Vector.isEmpty ts
+ | _ => false
end
- (* You can't memoize toMtype here because it depends on tyconMtype, which
- * is in the midst of being computed.
+ (* Split constructors into those that carry values and those that
+ * don't.
*)
- (* Split constructors into those that carry values and those that don't. *)
fun splitCons cons =
Vector.fold (cons, ([], []), fn ({con, args}, (no, have)) =>
- if Vector.forall (args, Option.isNone o toMtype)
+ if Vector.forall (args, isEmpty)
then (con :: no, have)
else (no, {con = con, args = args} :: have))
- (* Compute a least-fixed-point on tycon representations. *)
+ (* Compute a least-fixed-point on tycon representations. Initially
+ * assume all datatype tycons are Void. Change them if they have more
+ * than one variant or contain a useful component.
+ *)
val _ =
- Vector.foreach (datatypes, fn Datatype.T {tycon, ...} =>
+ Vector.foreach (datatypes, fn S.Datatype.T {tycon, ...} =>
setTyconRep (tycon, TyconRep.Void))
val _ =
FixedPoint.fix'
(fn continue =>
Vector.foreach
- (datatypes, fn Datatype.T {tycon, cons} =>
+ (datatypes, fn S.Datatype.T {tycon, cons} =>
let
val (noArgs, haveArgs) = splitCons cons
- val numEnum = List.length noArgs
- val numTag = List.length haveArgs
val old = tyconRep tycon
val new =
case (noArgs, haveArgs) of
- ([], []) => TyconRep.Void
- | ([_], []) => TyconRep.Void
- | (_, []) => TyconRep.Enum {numEnum = numEnum}
- | ([], [{args, ...}]) =>
- (case Vector.length args of
- 0 => Error.bug "args should be nonempty"
- | 1 => (case toMtype (Vector.sub (args, 0)) of
- NONE => TyconRep.Void
- | SOME t => TyconRep.Prim t)
- | _ => TyconRep.pointer)
- | (_, [{args, ...}]) =>
+ ([], []) => TyconRep.Void
+ | ([_], []) => TyconRep.Void
+ | (_, []) => TyconRep.Enum
+ | ([], [{args, ...}]) => TyconRep.Direct
+ | (_, [{args, ...}]) =>
if (if 1 = Vector.length args
then
let
val a = Vector.sub (args, 0)
- (* Which types are guaranteed to be represented
- * as zero mod 4. You can't use IntInf or
- * Thread here -- In fact, it's not clear to
- * me you can use anything, because of bogus
- * values.
+ (* Which types are guaranteed to be
+ * translated to R.Type.Pointer and are
+ * represented as zero mod 4.
*)
- open Type
- in case Type.dest a of
- Array _ => true
- | Datatype c =>
- (case tyconRep c of
- TyconRep.IndirectTag _ => true
- | _ => false)
- | Ref _ => true
- | Tuple _ => true
- | Vector _ => true
- | _ => false
+ datatype z = datatype S.Type.dest
+ in
+ case S.Type.dest a of
+ Array _ => true
+ | Datatype c =>
+ (case tyconRep c of
+ TyconRep.IndirectTag => true
+ | _ => false)
+ | Ref _ => true
+ | Tuple _ => true
+ | Vector _ => true
+ | _ => false
end
else true)
- then TyconRep.EnumDirect {numEnum = numEnum}
- else TyconRep.EnumIndirect {numEnum = numEnum}
- | ([], _) =>
- TyconRep.IndirectTag {numTag = numTag}
- | _ =>
- TyconRep.EnumIndirectTag {numEnum = numEnum,
- numTag = numTag}
+ then TyconRep.EnumDirect
+ else TyconRep.EnumIndirect
+ | ([], _) => TyconRep.IndirectTag
+ | _ => TyconRep.EnumIndirectTag
in if TyconRep.equals (old, new)
then ()
else (continue ()
; setTyconRep (tycon, new))
end))
- (* Now we can memoize toMtype. *)
- val {get = toMtype, ...} =
- Property.get (Type.plist, Property.initFun toMtype)
- (* Set constructor representations. *)
- fun direct (con, args, t) =
- setConRep (con,
- if 1 = Vector.length args
- then ConRep.Transparent t
- else ConRep.Tuple)
- (* Choose tags that are not equal to 0 mod 4. *)
- fun enum noArgs =
- let
- fun loop (i, cs) =
- case cs of
- [] => ()
- | c :: cs => (setConRep (c, ConRep.IntCast i)
- ; loop (i + 2, cs))
- in loop (1, noArgs)
- end
- fun indirectTag haveArgs =
- List.foreachi (haveArgs, fn (i, {con, args}) =>
- setConRep (con, ConRep.TagTuple i))
+ (* Accumulate all the ObjectTypes. *)
+ val objectTypes = ref []
+ (* Keep track of pointer types -- build them later, though. *)
+ val {get = refRep: S.Type.t -> TupleRep.t, set = setRefRep, ...} =
+ Property.getSetOnce
+ (S.Type.plist, Property.initRaise ("refRep", S.Type.layout))
+ val {get = tupleRep: S.Type.t -> TupleRep.t,
+ set = setTupleRep, ...} =
+ Property.getSetOnce
+ (S.Type.plist, Property.initRaise ("tupleRep", S.Type.layout))
+ val {get = tyconCons, set = setTyconCons, ...} =
+ Property.getSetOnce
+ (Tycon.plist, Property.initRaise ("cons", Tycon.layout))
+ val _ =
+ Vector.foreach (datatypes, fn S.Datatype.T {cons, tycon} =>
+ setTyconCons (tycon, cons))
+ (* We have to break the cycle in recursive types to avoid an infinite
+ * recursion when converting from S.Type.t to R.Type.t. This is done
+ * by creating pointer tycons and delaying building the corresponding
+ * object types until after toRtype is done. The "finish" list keeps
+ * the list of things to do later.
+ *)
+ val finish: (unit -> unit) list ref = ref []
+ val {get = toRtype: S.Type.t -> R.Type.t option, ...} =
+ Property.get
+ (S.Type.plist,
+ Property.initRec
+ (fn (t: S.Type.t, toRtype) =>
+ let
+ fun typesRep {isTagged: bool,
+ kind: R.MemChunk.t -> R.ObjectType.t,
+ mutable: bool,
+ pointerTycon: R.PointerTycon.t,
+ ty: R.Type.t,
+ tys: S.Type.t vector}: TupleRep.t =
+ let
+ val initialOffset = if isTagged then Runtime.wordSize else 0
+ val tys = Vector.map (tys, toRtype)
+ val bytes = ref []
+ val doubleWords = ref []
+ val words = ref []
+ val pointers = ref []
+ val _ =
+ Vector.foreachi
+ (tys, fn (i, t) =>
+ case t of
+ NONE => ()
+ | SOME t =>
+ let
+ val r =
+ if let
+ datatype z = datatype R.Type.t
+ in
+ case t of
+ EnumPointers {pointers, ...} =>
+ 0 < Vector.length pointers
+ | IntInf => true
+ | _ => false
+ end
+ then pointers
+ else (case R.Type.size t of
+ 1 => bytes
+ | 4 => words
+ | 8 => doubleWords
+ | _ => Error.bug "strange size")
+ in
+ List.push (r, (i, t))
+ end)
+ fun build (r, size, accum) =
+ List.fold
+ (!r, accum, fn ((index, ty), (res, offset)) =>
+ ({index = index, offset = offset, ty = ty} :: res,
+ offset + size))
+ val (accum, offset: int) =
+ build
+ (bytes, 1,
+ build (words, 4,
+ build (doubleWords, 8, ([], initialOffset))))
+ val offset =
+ Runtime.Type.align (Runtime.Type.pointer, offset)
+ val (components, size) = build (pointers, 4, (accum, offset))
+ val size = if 0 = size then 4 else size
+ val offsets =
+ Vector.mapi
+ (tys, fn (i, ty) =>
+ Option.map
+ (ty, fn ty =>
+ let
+ val {offset, ty, ...} =
+ List.lookup
+ (components, fn {index, ...} => i = index)
+ in
+ {offset = offset, ty = ty}
+ end))
+ val components =
+ List.revMap
+ (components, fn {offset, ty, ...} =>
+ {mutable = mutable, offset = offset, ty = ty})
+ val components =
+ if isTagged
+ then {mutable = false,
+ offset = 0,
+ ty = R.Type.int} :: components
+ else components
+ val components =
+ Vector.fromArray
+ (QuickSort.sortArray
+ (Array.fromList components,
+ fn ({offset = i, ...}, {offset = i', ...}) =>
+ i <= i'))
+ val _ =
+ List.push
+ (objectTypes,
+ (pointerTycon,
+ kind (R.MemChunk.T {components = components,
+ size = size})))
+ in
+ TupleRep.T {offsets = offsets,
+ size = size,
+ ty = ty,
+ tycon = pointerTycon}
+ end
+ fun pointer {fin, kind, mutable, tys}: R.Type.t =
+ let
+ val pt = R.PointerTycon.new ()
+ val ty = R.Type.pointer pt
+ val _ =
+ List.push
+ (finish, fn () =>
+ fin (typesRep {isTagged = false,
+ kind = kind,
+ mutable = mutable,
+ pointerTycon = pt,
+ ty = ty,
+ tys = tys}))
+ in
+ ty
+ end
+ fun convertDatatype (tycon: Tycon.t): R.Type.t option =
+ let
+ val (noArgs', haveArgs') = splitCons (tyconCons tycon)
+ val noArgs = Vector.fromList noArgs'
+ val haveArgs = Vector.fromList haveArgs'
+ fun pointers () =
+ Vector.tabulate (Vector.length haveArgs, fn _ =>
+ R.PointerTycon.new ())
+ fun indirect {conRep, isTagged, pointerTycons, ty} =
+ List.push
+ (finish, fn () =>
+ Vector.foreachi2
+ (pointerTycons, haveArgs, fn (i, pt, {con, args}) =>
+ let
+ val rep =
+ typesRep {isTagged = isTagged,
+ kind = R.ObjectType.Normal,
+ mutable = false,
+ pointerTycon = pt,
+ ty = ty,
+ tys = args}
+ in
+ setConRep (con, conRep {rep = rep, tag = i})
+ end))
+ fun transparent {con, args} =
+ let
+ val ty =
+ case toRtype (Vector.sub (args, 0)) of
+ NONE => Error.bug "strange transparent"
+ | SOME ty => ty
+ val _ = setConRep (con, ConRep.Transparent ty)
+ in
+ ty
+ end
+ fun enumAnd (pointers: R.PointerTycon.t vector): R.Type.t =
+ let
+ val enum =
+ Vector.tabulate
+ (Vector.length noArgs, fn i => 2 * i + 1)
+ val ty =
+ R.Type.EnumPointers {enum = enum,
+ pointers = pointers}
+ val _ =
+ Vector.foreach2
+ (noArgs, enum, fn (c, i) =>
+ setConRep (c, (ConRep.IntAsTy
+ {int = i, ty = ty})))
+ in
+ ty
+ end
+ fun indirectTag (): R.Type.t =
+ let
+ val pts = pointers ()
+ val ty = enumAnd pts
+ val _ = indirect {isTagged = true,
+ conRep = ConRep.TagTuple,
+ pointerTycons = pts,
+ ty = ty}
+ in
+ ty
+ end
+ in
+ case tyconRep tycon of
+ TyconRep.Direct =>
+ (case (noArgs', haveArgs') of
+ ([], []) => NONE
+ | ([con], []) =>
+ (setConRep (con, ConRep.Void)
+ ; NONE)
+ | ([], [ac as {args, con}]) =>
+ if 1 = Vector.length args
+ then SOME (transparent ac)
+ else
+ SOME
+ (pointer
+ {fin = (fn r =>
+ setConRep (con, ConRep.Tuple r)),
+ kind = R.ObjectType.Normal,
+ mutable = false,
+ tys = args})
+ | _ =>
+ Error.bug
+ (concat ["strange TyconRep.Direct for ",
+ Layout.toString (Tycon.layout tycon)]))
+ | TyconRep.Enum =>
+ let
+ val enum =
+ Vector.tabulate
+ (Vector.length noArgs, fn i => i)
+ val ty =
+ R.Type.EnumPointers {enum = enum,
+ pointers = Vector.new0 ()}
+ fun set (i, c) =
+ setConRep (c, (ConRep.IntAsTy
+ {int = i, ty = ty}))
+ val _ =
+ if Tycon.equals (tycon, Tycon.bool)
+ then (set (0, Con.falsee)
+ ; set (1, Con.truee))
+ else Vector.foreachi (noArgs, set)
+ in
+ SOME ty
+ end
+ | TyconRep.EnumDirect =>
+ (case haveArgs' of
+ [ca as {con, args}] =>
+ if 1 = Vector.length args
+ then
+ case transparent ca of
+ R.Type.EnumPointers {pointers, ...} =>
+ SOME (enumAnd pointers)
+ | _ =>
+ Error.bug "EnumDirect of non pointer"
+ else
+ let
+ val pt = R.PointerTycon.new ()
+ val ty = enumAnd (Vector.new1 pt)
+ val _ =
+ List.push
+ (finish, fn () =>
+ setConRep
+ (con,
+ ConRep.Tuple
+ (typesRep
+ {isTagged = false,
+ kind = R.ObjectType.Normal,
+ mutable = false,
+ pointerTycon = pt,
+ ty = ty,
+ tys = args})))
+ in
+ SOME ty
+ end
+ | _ =>
+ Error.bug "strange haveArgs for EnumDirect")
+ | TyconRep.EnumIndirect =>
+ let
+ val pts = pointers ()
+ val ty = enumAnd pts
+ val _ = indirect {conRep = ConRep.Tuple o #rep,
+ isTagged = false,
+ pointerTycons = pts,
+ ty = ty}
+ in
+ SOME ty
+ end
+ | TyconRep.EnumIndirectTag => SOME (indirectTag ())
+ | TyconRep.IndirectTag => SOME (indirectTag ())
+ | TyconRep.Void =>
+ let
+ val _ =
+ case (noArgs', haveArgs') of
+ ([], []) => ()
+ | ([con], []) => setConRep (con, ConRep.Void)
+ | _ => Error.bug "strange TyconRep.Void"
+ in
+ NONE
+ end
+ end
+ fun array {mutable: bool, ty: S.Type.t}: R.Type.t =
+ let
+ fun new () =
+ pointer {fin = fn _ => (),
+ kind = R.ObjectType.Array,
+ mutable = mutable,
+ tys = Vector.new1 ty}
+ datatype z = datatype S.Type.dest
+ in
+ case S.Type.dest ty of
+ Char => R.Type.string
+ | Word => if mutable
+ then new ()
+ else R.Type.wordVector
+ | Word8 => R.Type.string
+ | _ => new ()
+ end
+ datatype z = datatype S.Type.dest
+ in
+ case S.Type.dest t of
+ Array t => SOME (array {mutable = true, ty = t})
+ | Char => SOME R.Type.char
+ | Datatype tycon => convertDatatype tycon
+ | Int => SOME R.Type.int
+ | IntInf => SOME R.Type.intInf
+ | Pointer => SOME R.Type.cpointer
+ | PreThread => SOME R.Type.thread
+ | Real => SOME R.Type.real
+ | Ref t =>
+ SOME (pointer {fin = fn r => setRefRep (t, r),
+ kind = R.ObjectType.Normal,
+ mutable = true,
+ tys = Vector.new1 t})
+ | Thread => SOME R.Type.thread
+ | Tuple ts =>
+ if Vector.isEmpty ts
+ then NONE
+ else
+ SOME (pointer {fin = fn r => setTupleRep (t, r),
+ kind = R.ObjectType.Normal,
+ mutable = false,
+ tys = S.Type.detuple t})
+ | Vector t => SOME (array {mutable = false, ty = t})
+ | Word => SOME R.Type.word
+ | Word8 => SOME R.Type.char
+ end))
+ val toRtype =
+ Trace.trace
+ ("toRtype", S.Type.layout, Option.layout R.Type.layout)
+ toRtype
+ val _ = S.Program.foreachVar (program, fn (_, t) => (toRtype t; ()))
+ val n = List.length (!finish)
+ val _ = List.foreach (!finish, fn f => f ())
+ val _ =
+ if n = List.length (!finish)
+ then ()
+ else Error.bug "missed finish"
+ val objectTypes =
+ Vector.map
+ (QuickSort.sortVector
+ (Vector.concat [ObjectType.basic,
+ Vector.fromList (!objectTypes)],
+ fn ((pt, _), (pt', _)) =>
+ PointerTycon.<= (pt, pt')),
+ #2)
val _ =
- Vector.foreach
- (datatypes, fn Datatype.T {tycon, cons} =>
- let
- val (noArgs, haveArgs) = splitCons cons
- in
- case tyconRep tycon of
- TyconRep.Prim t =>
- (case (noArgs, haveArgs) of
- ([], []) => ()
- | ([con], []) => setConRep (con, ConRep.Void)
- | ([], [{con, args}]) => direct (con, args, t)
- | _ => Error.bug ("strange TyconRep.Prim for "
- ^ Layout.toString (Tycon.layout tycon)))
- | TyconRep.Enum _ =>
- if Tycon.equals (tycon, Tycon.bool)
- then (setConRep (Con.falsee, ConRep.Int 0)
- ; setConRep (Con.truee, ConRep.Int 1))
- else List.foreachi (noArgs, fn (i, c) =>
- setConRep (c, ConRep.Int i))
- | TyconRep.EnumDirect _ =>
- (enum noArgs
- ; (case haveArgs of
- [{con, args}] => direct (con, args, Mtype.pointer)
- | _ => Error.bug "strange haveArgs for EnumDirect"))
- | TyconRep.EnumIndirect _ =>
- (enum noArgs
- ; List.foreach (haveArgs, fn {con, ...} =>
- setConRep (con, ConRep.Tuple)))
- | TyconRep.EnumIndirectTag _ => (enum noArgs; indirectTag haveArgs)
- | TyconRep.IndirectTag _ => indirectTag haveArgs
- | TyconRep.Void =>
- (case (noArgs, haveArgs) of
- ([], []) => ()
- | ([con], []) => setConRep (con, ConRep.Void)
- | _ => Error.bug "strange TyconRep.Void")
- end)
+ Control.diagnostics
+ (fn display =>
+ (display (Layout.str "Representations:")
+ ; (Vector.foreach
+ (datatypes, fn S.Datatype.T {tycon, cons} =>
+ let
+ open Layout
+ in
+ display (seq [Tycon.layout tycon,
+ str " ",
+ TyconRep.layout (tyconRep tycon)])
+ ; display (indent
+ (Vector.layout (fn {con, ...} =>
+ record
+ [("con", Con.layout con),
+ ("rep",
+ ConRep.layout (conRep con))])
+ cons,
+ 2))
+ end))))
in
- {tyconRep = tyconRep,
- conRep = conRep,
- toMtype = toMtype}
+ {conRep = conRep,
+ objectTypes = objectTypes,
+ refRep = refRep,
+ toRtype = toRtype,
+ tupleRep = tupleRep,
+ tyconRep = tyconRep}
end
end
1.7 +33 -23 mlton/mlton/backend/representation.sig
Index: representation.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- representation.sig 10 Apr 2002 07:02:19 -0000 1.6
+++ representation.sig 7 Dec 2002 02:21:52 -0000 1.7
@@ -10,7 +10,7 @@
signature REPRESENTATION_STRUCTS =
sig
structure Ssa: SSA
- structure Mtype: MTYPE
+ structure Rssa: RSSA
end
signature REPRESENTATION =
@@ -24,62 +24,72 @@
* variant, and hence constructor requires no additional
* representation.
*)
- Prim of Mtype.t
+ Direct
(* All cons are non-value-carrying and are represented as ints. *)
- | Enum of {numEnum: int}
+ | Enum
(* All cons except for one are non-value-carrying and are
* represented as ints that are nonzero mod 4. The value carrying
* con is represented transparently, i.e. the value is known to be a
* pointer and is left as such.
*)
- | EnumDirect of {numEnum: int}
+ | EnumDirect
(* All cons except for one are non-value-carrying and are
* represented as ints that are nonzero mod 4. The value carrying
* con is represented by boxing its arg.
*)
- | EnumIndirect of {numEnum: int}
+ | EnumIndirect
(* Non-value-carrying and are represented as ints that are nonzero
* mod 4. Value carrying cons are represented by boxing the args
* and adding an integer tag.
*)
- | EnumIndirectTag of {numEnum: int,
- numTag: int}
+ | EnumIndirectTag
(* All cons are value carrying and are represented by boxing the
* args and adding an integer tag.
*)
- | IndirectTag of {numTag: int}
+ | IndirectTag
| Void
+ end
+
+ structure TupleRep:
+ sig
+ datatype t = T of {offsets: {offset: int,
+ ty: Rssa.Type.t} option vector,
+ size: int,
+ ty: Rssa.Type.t,
+ tycon: Rssa.PointerTycon.t}
- val equals: t * t -> bool
val layout: t -> Layout.t
- val toMtype: t -> Mtype.t option
+ val tycon: t -> Rssa.PointerTycon.t
end
(* How a constructor variant of a datatype is represented. *)
structure ConRep:
sig
datatype t =
- (* need no representation *)
- Void
- (* an integer *)
- | Int of int
- (* an integer, but of Pointer type *)
- | IntCast of int
+ (* an integer representing a variant in a datatype *)
+ IntAsTy of {int: int,
+ ty: Rssa.Type.t}
+ (* box the arg(s) and add the integer tag as the first word *)
+ | TagTuple of {rep: TupleRep.t,
+ tag: int}
(* just keep the value itself *)
- | Transparent of Mtype.t
+ | Transparent of Rssa.Type.t
(* box the arg(s) *)
- | Tuple
- (* box the arg(s) and add the integer tag as the first word *)
- | TagTuple of int
+ | Tuple of TupleRep.t
+ (* need no representation *)
+ | Void
val layout: t -> Layout.t
end
-
+
val compute:
Ssa.Program.t
-> {
- tyconRep: Ssa.Tycon.t -> TyconRep.t,
conRep: Ssa.Con.t -> ConRep.t,
- toMtype: Ssa.Type.t -> Mtype.t option
+ objectTypes: Rssa.ObjectType.t vector,
+ refRep: Ssa.Type.t -> TupleRep.t,
+ toRtype: Ssa.Type.t -> Rssa.Type.t option,
+ tupleRep: Ssa.Type.t -> TupleRep.t,
+ tyconRep: Ssa.Tycon.t -> TyconRep.t
}
end
1.20 +384 -249 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- rssa.fun 24 Nov 2002 01:19:43 -0000 1.19
+++ rssa.fun 7 Dec 2002 02:21:52 -0000 1.20
@@ -19,70 +19,32 @@
structure Operand =
struct
datatype t =
- ArrayHeader of {numBytesNonPointers: int,
- numPointers: int}
- | ArrayOffset of {base: Var.t,
- index: Var.t,
+ ArrayOffset of {base: t,
+ index: t,
ty: Type.t}
- | CastInt of t
- | CastWord of t
+ | Cast of t * Type.t
| Const of Const.t
| EnsuresBytesFree
| File
| GCState
| Line
- | Offset of {base: Var.t,
- bytes: int,
+ | Offset of {base: t,
+ offset: int,
ty: Type.t}
- | Pointer of int
+ | PointerTycon of PointerTycon.t
| Runtime of GCField.t
+ | SmallIntInf of word
| Var of {var: Var.t,
ty: Type.t}
val char = Const o Const.fromChar
val int = Const o Const.fromInt
val word = Const o Const.fromWord
- fun bool b = int (if b then 1 else 0)
+ fun bool b = Cast (int (if b then 1 else 0), Type.bool)
- val rec toString =
- fn ArrayHeader {numBytesNonPointers, numPointers} =>
- concat ["AH (",
- Int.toString numBytesNonPointers,
- ", ",
- Int.toString numPointers,
- ")"]
- | ArrayOffset {base, index, ty} =>
- concat ["X", Type.name ty,
- "(", Var.toString base, ",", Var.toString index, ")"]
- | CastInt z => concat ["CastInt ", toString z]
- | CastWord z => concat ["CastWord ", toString z]
- | Const c => Const.toString c
- | EnsuresBytesFree => "<EnsuresBytesFree>"
- | File => "<File>"
- | GCState => "<GCState>"
- | Line => "<Line>"
- | Offset {base, bytes, ty} =>
- concat ["O", Type.name ty,
- "(", Var.toString base, ",", Int.toString bytes, ")"]
- | Pointer n => concat ["IntAsPointer (", Int.toString n, ")"]
- | Runtime r => GCField.toString r
- | Var {var, ...} => Var.toString var
-
- val layout: t -> Layout.t = Layout.str o toString
-
- val rec isLocation =
- fn ArrayOffset _ => true
- | CastWord z => isLocation z
- | Offset _ => true
- | Runtime _ => true
- | Var _ => true
- | _ => false
-
val ty =
- fn ArrayHeader _ => Type.word
- | ArrayOffset {ty, ...} => ty
- | CastInt _ => Type.int
- | CastWord _ => Type.word
+ fn ArrayOffset {ty, ...} => ty
+ | Cast (_, ty) => ty
| Const c =>
let
datatype z = datatype Const.Node.t
@@ -90,35 +52,83 @@
case Const.node c of
Char _ => Type.char
| Int _ => Type.int
- | IntInf _ => Type.pointer
- | Real _ => Type.double
- | String _ => Type.pointer
+ | IntInf _ => Type.intInf
+ | Real _ => Type.real
+ | String _ => Type.string
| Word _ =>
let
val ty = Const.ty c
in
if Const.Type.equals (ty, Const.Type.word)
- then Type.uint
+ then Type.word
else if Const.Type.equals (ty, Const.Type.word8)
then Type.char
else Error.bug "strange word"
end
end
| EnsuresBytesFree => Type.word
- | File => Type.pointer
- | GCState => Type.pointer
+ | File => Type.cpointer
+ | GCState => Type.cpointer
| Line => Type.int
| Offset {ty, ...} => ty
- | Pointer _ => Type.pointer
- | Runtime z => GCField.ty z
+ | PointerTycon _ => Type.word
+ | Runtime z => Type.fromRuntime (GCField.ty z)
+ | SmallIntInf _ => Type.IntInf
| Var {ty, ...} => ty
+ fun layout (z: t): Layout.t =
+ let
+ open Layout
+ fun constrain (ty: Type.t): Layout.t =
+ if !Control.showTypes
+ then seq [str ": ", Type.layout ty]
+ else empty
+ in
+ case z of
+ ArrayOffset {base, index, ty} =>
+ seq [str (concat ["X", Type.name ty, " "]),
+ tuple [layout base, layout index],
+ constrain ty]
+ | Cast (z, ty) =>
+ seq [str "Cast ", tuple [layout z, Type.layout ty]]
+ | Const c => Const.layout c
+ | EnsuresBytesFree => str "<EnsuresBytesFree>"
+ | File => str "<File>"
+ | GCState => str "<GCState>"
+ | Line => str "<Line>"
+ | Offset {base, offset, ty} =>
+ seq [str (concat ["O", Type.name ty, " "]),
+ tuple [layout base, Int.layout offset],
+ constrain ty]
+ | PointerTycon pt => PointerTycon.layout pt
+ | Runtime r => GCField.layout r
+ | SmallIntInf w => seq [str "SmallIntInf ", paren (Word.layout w)]
+ | Var {var, ty} => seq [Var.layout var, constrain ty]
+ end
+
+ val toString = Layout.toString o layout
+
+ fun cast (z, t) =
+ if Type.equals (t, ty z)
+ then z
+ else Cast (z, t)
+
+ val cast = Trace.trace2 ("Operand.cast", layout, Type.layout, layout) cast
+
+ val rec isLocation =
+ fn ArrayOffset _ => true
+ | Cast (z, _) => isLocation z
+ | Offset _ => true
+ | Runtime _ => true
+ | Var _ => true
+ | _ => false
+
fun 'a foldVars (z: t, a: 'a, f: Var.t * 'a -> 'a): 'a =
case z of
- ArrayOffset {base, index, ...} => f (index, f (base, a))
- | CastInt z => foldVars (z, a, f)
- | CastWord z => foldVars (z, a, f)
- | Offset {base, ...} => f (base, a)
+ ArrayOffset {base, index, ...} =>
+ foldVars (index, foldVars (base, a, f), f)
+ | Cast (z, _) => foldVars (z, a, f)
+ | Offset {base, ...} => foldVars (base, a, f)
| Var {var, ...} => f (var, a)
| _ => a
@@ -138,6 +148,9 @@
| _ => big z
end
+structure Switch = Switch (open S
+ structure Use = Operand)
+
structure Statement =
struct
datatype t =
@@ -147,10 +160,11 @@
| Move of {dst: Operand.t,
src: Operand.t}
| Object of {dst: Var.t,
- numPointers: int,
- numWordsNonPointers: int,
+ size: int,
stores: {offset: int,
- value: Operand.t} vector}
+ value: Operand.t} vector,
+ ty: Type.t,
+ tycon: PointerTycon.t}
| PrimApp of {args: Operand.t vector,
dst: (Var.t * Type.t) option,
prim: Prim.t}
@@ -173,8 +187,8 @@
Bind {oper, var, ...} =>
def (var, Operand.ty oper, useOperand (oper, a))
| Move {dst, src} => useOperand (src, useOperand (dst, a))
- | Object {dst, stores, ...} =>
- Vector.fold (stores, def (dst, Type.pointer, a),
+ | Object {dst, stores, ty, ...} =>
+ Vector.fold (stores, def (dst, ty, a),
fn ({value, ...}, a) => useOperand (value, a))
| PrimApp {dst, args, ...} =>
Vector.fold (args,
@@ -205,26 +219,42 @@
val layout =
let
open Layout
+ fun constrain ty =
+ if !Control.showTypes
+ then seq [str ": ", Type.layout ty]
+ else empty
in
fn Bind {oper, var, ...} =>
- seq [Var.layout var, str " = ", Operand.layout oper]
+ seq [Var.layout var, constrain (Operand.ty oper),
+ str " = ", Operand.layout oper]
| Move {dst, src} =>
- seq [Operand.layout dst, str " = ", Operand.layout src]
- | Object {dst, numPointers, numWordsNonPointers, stores, ...} =>
- seq [Var.layout dst, str " = Object ",
- tuple [Int.layout numWordsNonPointers,
- Int.layout numPointers],
- str " ",
- Vector.layout (fn {offset, value} =>
- record [("offset", Int.layout offset),
- ("value", Operand.layout value)])
- stores]
+ mayAlign [Operand.layout dst,
+ seq [str " = ", Operand.layout src]]
+ | Object {dst, size, stores, ty, tycon} =>
+ mayAlign
+ [seq [Var.layout dst, constrain ty],
+ seq [str " = Object ",
+ record
+ [("size", Int.layout size),
+ ("tycon", PointerTycon.layout tycon),
+ ("stores",
+ Vector.layout
+ (fn {offset, value} =>
+ record [("offset", Int.layout offset),
+ ("value", Operand.layout value)])
+ stores)]]]
| PrimApp {dst, prim, args, ...} =>
- seq [(case dst of
- NONE => empty
- | SOME (x, _) => seq [Var.layout x, str " = "]),
- Prim.layout prim, str " ",
- Vector.layout Operand.layout args]
+ let
+ val rest =
+ seq [Prim.layout prim, str " ",
+ Vector.layout Operand.layout args]
+ in
+ case dst of
+ NONE => rest
+ | SOME (x, t) =>
+ mayAlign [seq [Var.layout x, constrain t],
+ seq [str " = ", rest]]
+ end
| SetExnStackLocal => str "SetExnStackLocal"
| SetExnStackSlot => str "SetExnStackSlot "
| SetHandler l => seq [str "SetHandler ", Label.layout l]
@@ -254,12 +284,7 @@
args: Operand.t vector}
| Raise of Operand.t vector
| Return of Operand.t vector
- | Switch of {cases: Cases.t,
- default: Label.t option,
- test: Operand.t}
- | SwitchIP of {int: Label.t,
- pointer: Label.t,
- test: Operand.t}
+ | Switch of Switch.t
fun layout t =
let
@@ -305,17 +330,9 @@
| Goto {dst, args} =>
seq [Label.layout dst, str " ",
Vector.layout Operand.layout args]
- | Raise xs => seq [str "Raise", Vector.layout Operand.layout xs]
+ | Raise xs => seq [str "Raise ", Vector.layout Operand.layout xs]
| Return xs => seq [str "Return ", Vector.layout Operand.layout xs]
- | Switch {test, cases, default} =>
- seq [str "Switch ",
- tuple [Operand.layout test,
- Cases.layout cases,
- Option.layout Label.layout default]]
- | SwitchIP {test, int, pointer} =>
- seq [str "SwitchIP ", tuple [Operand.layout test,
- Label.layout int,
- Label.layout pointer]]
+ | Switch s => Switch.layout s
end
val bug =
@@ -325,9 +342,10 @@
func = CFunction.bug,
return = NONE}
- fun 'a foldDefLabelUse (t, a: 'a, {def: Var.t * Type.t * 'a -> 'a,
- label: Label.t * 'a -> 'a,
- use: Var.t * 'a -> 'a}): 'a =
+ fun 'a foldDefLabelUse (t, a: 'a,
+ z as {def: Var.t * Type.t * 'a -> 'a,
+ label: Label.t * 'a -> 'a,
+ use: Var.t * 'a -> 'a}): 'a =
let
fun useVars (xs: Var.t vector, a) =
Vector.fold (xs, a, use)
@@ -355,16 +373,8 @@
| Goto {args, dst, ...} => label (dst, useOperands (args, a))
| Raise zs => useOperands (zs, a)
| Return zs => useOperands (zs, a)
- | Switch {cases, default, test, ...} =>
- let
- val a = useOperand (test, a)
- val a = Option.fold (default, a, label)
- val a = Cases.fold (cases, a, label)
- in
- a
- end
- | SwitchIP {int, pointer, test, ...} =>
- label (int, label (pointer, useOperand (test, a)))
+ | Switch s => Switch.foldLabelUse (s, a, {label = label,
+ use = useOperand})
end
fun foreachDefLabelUse (t, {def, label, use}) =
@@ -394,10 +404,17 @@
fun clear (t: t): unit =
foreachDef (t, Var.clear o #1)
- fun iff (test, {falsee, truee}) =
- Switch {cases = Cases.Int [(0, falsee), (1, truee)],
- default = NONE,
- test = test}
+ fun ifBool (test, {falsee, truee}) =
+ Switch (Switch.Int
+ {cases = Vector.new2 ((0, falsee), (1, truee)),
+ default = NONE,
+ test = test})
+
+ fun ifInt (test, {falsee, truee}) =
+ Switch (Switch.Int
+ {cases = Vector.new1 (0, falsee),
+ default = SOME truee,
+ test = test})
end
structure Kind =
@@ -424,6 +441,18 @@
end
end
+local
+ open Layout
+in
+ fun layoutFormals (xts: (Var.t * Type.t) vector) =
+ Vector.layout (fn (x, t) =>
+ seq [Var.layout x,
+ if !Control.showTypes
+ then seq [str ": ", Type.layout t]
+ else empty])
+ xts
+end
+
structure Block =
struct
datatype t =
@@ -520,6 +549,8 @@
datatype t = T of {args: (Var.t * Type.t) vector,
blocks: Block.t vector,
name: Func.t,
+ raises: Type.t vector option,
+ returns: Type.t vector option,
start: Label.t}
local
@@ -542,18 +573,26 @@
fun hasPrim (T {blocks, ...}, pred) =
Vector.exists (blocks, fn b => Block.hasPrim (b, pred))
- fun layout (T {args, blocks, name, start}): Layout.t =
+ fun layoutHeader (T {args, name, start, ...}): Layout.t =
let
open Layout
in
- align
- [seq [Func.layout name,
- Vector.layout (Layout.tuple2 (Var.layout, Type.layout)) args,
- str " = ",
- Label.layout start,
- str " ()"],
- indent (align (Vector.toListMap (blocks, Block.layout)),
- 2)]
+ seq [str "fun ", Func.layout name,
+ str " ", layoutFormals args,
+ str " = ", Label.layout start, str " ()"]
+ end
+
+ fun layouts (f as T {blocks, ...}, output) =
+ (output (layoutHeader f)
+ ; Vector.foreach (blocks, fn b =>
+ output (Layout.indent (Block.layout b, 2))))
+
+ fun layout (f as T {blocks, ...}) =
+ let
+ open Layout
+ in
+ align [layoutHeader f,
+ indent (align (Vector.toListMap (blocks, Block.layout)), 2)]
end
fun dfs (T {blocks, start, ...}, v) =
@@ -630,9 +669,11 @@
structure Program =
struct
- datatype t = T of {functions: Function.t list,
- main: Function.t,
- profileAllocLabels: string vector}
+ datatype t =
+ T of {functions: Function.t list,
+ main: Function.t,
+ objectTypes: ObjectType.t vector,
+ profileAllocLabels: string vector}
fun clear (T {functions, main, ...}) =
(List.foreach (functions, Function.clear)
@@ -646,17 +687,23 @@
end
fun handlesSignals p =
- hasPrim (p, fn p => Prim.name p = Prim.Name.MLton_installSignalHandler)
+ hasPrim (p, fn p =>
+ Prim.name p = Prim.Name.MLton_installSignalHandler)
- fun layouts (T {functions, main, ...}, output': Layout.t -> unit): unit =
+ fun layouts (T {functions, main, objectTypes, ...},
+ output': Layout.t -> unit): unit =
let
open Layout
val output = output'
in
- output (str "Main:")
- ; output (Function.layout main)
- ; output (str "\n\nFunctions:")
- ; List.foreach (functions, output o Function.layout)
+ output (str "\nObjectTypes:")
+ ; Vector.foreachi (objectTypes, fn (i, ty) =>
+ output (seq [str "pt_", Int.layout i,
+ str " = ", ObjectType.layout ty]))
+ ; output (str "\nMain:")
+ ; Function.layouts (main, output)
+ ; output (str "\nFunctions:")
+ ; List.foreach (functions, fn f => Function.layouts (f, output))
end
fun checkScopes (program as T {functions, main, ...}): unit =
@@ -753,8 +800,16 @@
in ()
end
- fun typeCheck (p as T {functions, main, ...}) =
+ fun typeCheck (p as T {functions, main, objectTypes, ...}) =
let
+ val _ =
+ Vector.foreach
+ (objectTypes, fn ty =>
+ Err.check ("objectType",
+ fn () => ObjectType.isOk ty,
+ fn () => ObjectType.layout ty))
+ fun tyconTy (pt: PointerTycon.t): ObjectType.t =
+ Vector.sub (objectTypes, PointerTycon.index pt)
val _ = checkScopes p
val {get = labelBlock: Label.t -> Block.t,
set = setLabelBlock, ...} =
@@ -775,29 +830,89 @@
datatype z = datatype Operand.t
fun ok () =
case x of
- ArrayHeader {numBytesNonPointers = nbnp, numPointers = np} =>
- nbnp >= 0 andalso np >= 0
-
- | ArrayOffset {base, index, ty} =>
- Type.equals (varType base, Type.pointer)
- andalso Type.equals (varType index, Type.int)
- | CastInt z => Type.equals (Operand.ty z, Type.pointer)
- | CastWord z =>
- Type.equals (Operand.ty z, Type.pointer)
- orelse Type.equals (Operand.ty z, Type.int)
+ ArrayOffset z => arrayOffsetIsOk z
+ | Cast (z, ty) =>
+ (checkOperand z
+ ; (castIsOk
+ {from = Operand.ty z,
+ fromInt = (case z of
+ Const c =>
+ (case Const.node c of
+ Const.Node.Int n => SOME n
+ | _ => NONE)
+ | _ => NONE),
+ to = ty,
+ tyconTy = tyconTy}))
| Const _ => true
| EnsuresBytesFree => true
| File => true
| GCState => true
| Line => true
- | Offset {base, ...} =>
- Type.equals (varType base, Type.pointer)
- | Pointer n => 0 < Int.rem (n, Runtime.wordSize)
+ | Offset z => offsetIsOk z
+ | PointerTycon _ => true
| Runtime _ => true
+ | SmallIntInf _ => true
| Var {ty, var} => Type.equals (ty, varType var)
in
Err.check ("operand", ok, fn () => Operand.layout x)
end
+ and arrayOffsetIsOk {base, index, ty} =
+ let
+ val _ = checkOperand base
+ val _ = checkOperand index
+ in
+ Type.equals (Operand.ty index, Type.int)
+ andalso
+ case Operand.ty base of
+ Type.CPointer => true (* needed for card marking *)
+ | Type.EnumPointers {enum, pointers} =>
+ 0 = Vector.length enum
+ andalso
+ Vector.forall
+ (pointers, fn p =>
+ case tyconTy p of
+ ObjectType.Array
+ (MemChunk.T {components, ...}) =>
+ 1 = Vector.length components
+ andalso
+ let
+ val {offset, ty = ty', ...} =
+ Vector.sub (components, 0)
+ in
+ offset = 0
+ andalso Type.equals (ty, ty')
+ end
+ | _ => false)
+ | _ => false
+ end
+ and offsetIsOk {base, offset, ty} =
+ let
+ val _ = checkOperand base
+ fun memChunkIsOk (MemChunk.T {components, ...}) =
+ case Vector.peek (components, fn {offset = offset', ...} =>
+ offset = offset') of
+ NONE => false
+ | SOME {ty = ty', ...} => Type.equals (ty, ty')
+ in
+ case Operand.ty base of
+ Type.EnumPointers {enum, pointers} =>
+ 0 = Vector.length enum
+ andalso
+ ((* Vector_fromArray header update. *)
+ (offset = Runtime.headerOffset
+ andalso Type.equals (ty, Type.word))
+ orelse
+ Vector.forall
+ (pointers, fn p =>
+ case tyconTy p of
+ ObjectType.Normal m => memChunkIsOk m
+ | _ => false))
+ | Type.MemChunk m => memChunkIsOk m
+ | _ => false
+ end
+ val checkOperand =
+ Trace.trace ("checkOperand", Operand.layout, Unit.layout)
+ checkOperand
fun checkOperands v = Vector.foreach (v, checkOperand)
fun check' (x, name, isOk, layout) =
Err.check (name, fn () => isOk x, fn () => layout x)
@@ -817,11 +932,17 @@
; checkOperand src
; (Type.equals (Operand.ty dst, Operand.ty src)
andalso Operand.isLocation dst))
- | Object {dst, numPointers, numWordsNonPointers, stores} =>
- (Vector.foreach (stores, fn {offset, value} =>
- checkOperand value)
- ; (numPointers >= 0
- andalso numWordsNonPointers >= 0))
+ | Object {dst, size, stores, tycon, ...} =>
+ (Vector.foreach (stores, checkOperand o # value)
+ ; (case tyconTy tycon of
+ ObjectType.Normal mc =>
+ MemChunk.isValidInit
+ (mc,
+ Vector.map
+ (stores, fn {offset, value} =>
+ {offset = offset,
+ ty = Operand.ty value}))
+ | _ => false))
| PrimApp {args, ...} =>
(Vector.foreach (args, checkOperand)
; true)
@@ -833,111 +954,20 @@
| _ => false)
| SetSlotExnStack => true
end
- fun goto {dst, args} =
+ fun goto {args: Type.t vector,
+ dst: Label.t}: bool =
let
val Block.T {args = formals, kind, ...} = labelBlock dst
in
- Vector.equals (args, formals, fn (z, (_, t)) =>
- Type.equals (t, Operand.ty z))
+ Vector.equals (args, formals, fn (t, (_, t')) =>
+ Type.equals (t, t'))
andalso (case kind of
Kind.Jump => true
| _ => false)
end
fun labelIsNullaryJump l = goto {dst = l, args = Vector.new0 ()}
- fun transferOk (t: Transfer.t): bool =
- let
- datatype z = datatype Transfer.t
- in
- case t of
- Arith {args, dst, overflow, prim, success, ty} =>
- Prim.mayOverflow prim
- andalso labelIsNullaryJump overflow
- andalso labelIsNullaryJump success
- andalso
- Vector.forall (args, fn x =>
- Type.equals (ty, Operand.ty x))
- | CCall {args, func, return} =>
- let
- val _ = checkOperands args
- in
- CFunction.isOk func
- andalso
- case return of
- NONE => true
- | SOME l =>
- case labelKind l of
- Kind.CReturn {func = f} =>
- CFunction.equals (func, f)
- | _ => false
- end
- | Call {args, func, return} =>
- let
- val Function.T {args = formals, ...} = funcInfo func
- in
- Vector.equals (args, formals, fn (z, (_, t)) =>
- Type.equals (t, Operand.ty z))
- andalso
- (case return of
- Return.Dead => true
- | Return.HandleOnly => true
- | Return.NonTail {cont, handler = h} =>
- (case labelKind cont of
- Kind.Cont {handler = h'} =>
- (case (h, h') of
- (Handler.CallerHandler, NONE) =>
- true
- | (Handler.None, NONE) => true
- | (Handler.Handle l, SOME l') =>
- Label.equals (l, l')
- | _ => false)
- | _ => false)
- | Return.Tail => true)
- end
- | Goto z => goto z
- | Raise _ => true
- | Return _ => true
- | Switch {cases, default, test} =>
- (Cases.forall (cases, labelIsNullaryJump)
- andalso Option.forall (default, labelIsNullaryJump)
- andalso (Type.equals
- (Operand.ty test,
- case cases of
- Cases.Char _ => Type.char
- | Cases.Int _ => Type.int
- | Cases.Word _ => Type.uint)))
- | SwitchIP {int, pointer, test} =>
- (checkOperand test
- ; (labelIsNullaryJump pointer
- andalso labelIsNullaryJump int
- andalso Type.equals (Type.pointer,
- Operand.ty test)))
- end
- fun blockOk (Block.T {args, kind, label,
- statements, transfer, ...}): bool =
- let
- fun kindOk (k: Kind.t): bool =
- let
- datatype z = datatype Kind.t
- val _ =
- case k of
- Cont _ => true
- | CReturn _ => true
- | Handler => true
- | Jump => true
- in
- true
- end
- val _ = check' (kind, "kind", kindOk, Kind.layout)
- val _ =
- Vector.foreach
- (statements, fn s =>
- check' (s, "statement", statementOk, Statement.layout))
- val _ = check' (transfer, "transfer", transferOk,
- Transfer.layout)
- in
- true
- end
- fun checkFunction (Function.T {args, blocks, start, ...}) =
+ fun checkFunction (Function.T {args, blocks, raises, returns, start,
+ ...}) =
let
val _ = Vector.foreach (args, setVarType)
val _ =
@@ -951,9 +981,114 @@
(s, setVarType))
; Transfer.foreachDef (transfer, setVarType)))
val _ = labelIsNullaryJump start
+ fun transferOk (t: Transfer.t): bool =
+ let
+ datatype z = datatype Transfer.t
+ in
+ case t of
+ Arith {args, dst, overflow, prim, success, ty} =>
+ let
+ val _ = checkOperands args
+ in
+ Prim.mayOverflow prim
+ andalso labelIsNullaryJump overflow
+ andalso labelIsNullaryJump success
+ andalso
+ Vector.forall (args, fn x =>
+ Type.equals (ty, Operand.ty x))
+ end
+ | CCall {args, func, return} =>
+ let
+ val _ = checkOperands args
+ in
+ CFunction.isOk func
+ andalso
+ case return of
+ NONE => true
+ | SOME l =>
+ case labelKind l of
+ Kind.CReturn {func = f} =>
+ CFunction.equals (func, f)
+ | _ => false
+ end
+ | Call {args, func, return} =>
+ let
+ val _ = checkOperands args
+ val Function.T {args = formals, ...} = funcInfo func
+ in
+ Vector.equals (args, formals, fn (z, (_, t)) =>
+ Type.equals (t, Operand.ty z))
+ andalso
+ (case return of
+ Return.Dead => true
+ | Return.HandleOnly => true
+ | Return.NonTail {cont, handler = h} =>
+ (case labelKind cont of
+ Kind.Cont {handler = h'} =>
+ (case (h, h') of
+ (Handler.CallerHandler, NONE) =>
+ true
+ | (Handler.None, NONE) => true
+ | (Handler.Handle l, SOME l') =>
+ Label.equals (l, l')
+ | _ => false)
+ | _ => false)
+ | Return.Tail => true)
+ end
+ | Goto {args, dst} =>
+ (checkOperands args
+ ; goto {args = Vector.map (args, Operand.ty),
+ dst = dst})
+ | Raise zs =>
+ (checkOperands zs
+ ; (case raises of
+ NONE => false
+ | SOME ts =>
+ Vector.equals
+ (zs, ts, fn (z, t) =>
+ Type.equals (t, Operand.ty z))))
+ | Return zs =>
+ (checkOperands zs
+ ; (case returns of
+ NONE => false
+ | SOME ts =>
+ Vector.equals
+ (zs, ts, fn (z, t) =>
+ Type.equals (t, Operand.ty z))))
+ | Switch s =>
+ Switch.isOk (s, {labelIsOk = labelIsNullaryJump})
+ end
+ fun blockOk (Block.T {args, kind, label,
+ statements, transfer, ...}): bool =
+ let
+ fun kindOk (k: Kind.t): bool =
+ let
+ datatype z = datatype Kind.t
+ val _ =
+ case k of
+ Cont _ => true
+ | CReturn _ => true
+ | Handler => true
+ | Jump => true
+ in
+ true
+ end
+ val _ = check' (kind, "kind", kindOk, Kind.layout)
+ val _ =
+ Vector.foreach
+ (statements, fn s =>
+ check' (s, "statement", statementOk,
+ Statement.layout))
+ val _ = check' (transfer, "transfer", transferOk,
+ Transfer.layout)
+ in
+ true
+ end
+
val _ =
Vector.foreach
- (blocks, fn b => check' (b, "block", blockOk, Block.layout))
+ (blocks, fn b =>
+ check' (b, "block", blockOk, Block.layout))
in
()
end
1.17 +31 -32 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- rssa.sig 2 Nov 2002 03:37:38 -0000 1.16
+++ rssa.sig 7 Dec 2002 02:21:52 -0000 1.17
@@ -10,11 +10,10 @@
signature RSSA_STRUCTS =
sig
- include ATOMS
+ include MACHINE_ATOMS
- structure Cases: MACHINE_CASES
+ structure Const: CONST
structure Func: HASH_ID
- structure Label: HASH_ID
structure Handler:
sig
datatype t =
@@ -39,29 +38,27 @@
val foldLabel: t * 'a * (Label.t * 'a -> 'a) -> 'a
val foreachLabel: t * (Label.t -> unit) -> unit
end
- structure Runtime: RUNTIME
- structure Type: MTYPE
- sharing Label = Cases.Label
- sharing Type = Runtime.Type
+ structure Var: VAR
end
signature RSSA =
sig
include RSSA_STRUCTS
+ structure Switch: SWITCH
+ sharing Label = Switch.Label
+ sharing PointerTycon = Switch.PointerTycon
+ sharing Type = Switch.Type
structure CFunction: C_FUNCTION
sharing CFunction = Runtime.CFunction
-
+
structure Operand:
sig
datatype t =
- ArrayHeader of {numBytesNonPointers: int,
- numPointers: int}
- | ArrayOffset of {base: Var.t,
- index: Var.t,
+ ArrayOffset of {base: t,
+ index: t,
ty: Type.t}
- | CastInt of t
- | CastWord of t
+ | Cast of t * Type.t
| Const of Const.t
(* EnsuresBytesFree is a pseudo-op used by C functions (like
* GC_allocateArray) that take a number of bytes as an argument
@@ -73,17 +70,19 @@
| File (* expand by codegen into string constant *)
| GCState
| Line (* expand by codegen into int constant *)
- | Offset of {base: Var.t,
- bytes: int,
+ | Offset of {base: t,
+ offset: int,
ty: Type.t}
- | Pointer of int (* the int must be nonzero mod Runtime.wordSize. *)
+ | PointerTycon of PointerTycon.t
| Runtime of Runtime.GCField.t
+ | SmallIntInf of word
| Var of {var: Var.t,
ty: Type.t}
val bool: bool -> t
val caseBytes: t * {big: t -> 'a,
small: word -> 'a} -> 'a
+ val cast: t * Type.t -> t
val char: char -> t
val int: int -> t
val layout: t -> Layout.t
@@ -91,6 +90,7 @@
val ty: t -> Type.t
val word: word -> t
end
+ sharing Operand = Switch.Use
structure Statement:
sig
@@ -101,10 +101,12 @@
| Move of {dst: Operand.t,
src: Operand.t}
| Object of {dst: Var.t,
- numPointers: int,
- numWordsNonPointers: int,
+ size: int, (* in bytes, including header *)
+ (* The stores are in increasing order of offset. *)
stores: {offset: int, (* bytes *)
- value: Operand.t} vector}
+ value: Operand.t} vector,
+ ty: Type.t,
+ tycon: PointerTycon.t}
| PrimApp of {args: Operand.t vector,
dst: (Var.t * Type.t) option,
prim: Prim.t}
@@ -117,7 +119,7 @@
* If s defines a variable x, then return f (x, a), else return a.
*)
val foldDef: t * 'a * (Var.t * Type.t * 'a -> 'a) -> 'a
- (* forDef (s, f) = foldDef (s, (), fn (x, ()) => f x) *)
+ (* foreachDef (s, f) = foldDef (s, (), fn (x, ()) => f x) *)
val foreachDef: t * (Var.t * Type.t -> unit) -> unit
val foreachDefUse: t * {def: (Var.t * Type.t) -> unit,
use: Var.t -> unit} -> unit
@@ -154,12 +156,7 @@
*)
| Raise of Operand.t vector
| Return of Operand.t vector
- | Switch of {cases: Cases.t,
- default: Label.t option, (* Must be nullary. *)
- test: Operand.t}
- | SwitchIP of {int: Label.t,
- pointer: Label.t,
- test: Operand.t}
+ | Switch of Switch.t
val bug: t
(* foldDef (t, a, f)
@@ -173,7 +170,8 @@
use: Var.t -> unit} -> unit
val foreachLabel: t * (Label.t -> unit) -> unit
val foreachUse: t * (Var.t -> unit) -> unit
- val iff: Operand.t * {falsee: Label.t, truee: Label.t} -> t
+ val ifBool: Operand.t * {falsee: Label.t, truee: Label.t} -> t
+ val ifInt: Operand.t * {falsee: Label.t, truee: Label.t} -> t
val layout: t -> Layout.t
end
@@ -215,6 +213,8 @@
val dest: t -> {args: (Var.t * Type.t) vector,
blocks: Block.t vector,
name: Func.t,
+ raises: Type.t vector option,
+ returns: Type.t vector option,
start: Label.t}
(* dfs (f, v) visits the blocks in depth-first order, applying v b
* for block b to yield v', then visiting b's descendents,
@@ -225,6 +225,8 @@
val new: {args: (Var.t * Type.t) vector,
blocks: Block.t vector,
name: Func.t,
+ raises: Type.t vector option,
+ returns: Type.t vector option,
start: Label.t} -> t
val start: t -> Label.t
end
@@ -233,11 +235,8 @@
sig
datatype t =
T of {functions: Function.t list,
- (* main must be nullary and should not be called by other
- * functions. It defines global variables that are in scope
- * for the rest of the program.
- *)
main: Function.t,
+ objectTypes: ObjectType.t vector,
profileAllocLabels: string vector}
val clear: t -> unit
1.7 +6 -1 mlton/mlton/backend/runtime.fun
Index: runtime.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- runtime.fun 2 Nov 2002 03:37:39 -0000 1.6
+++ runtime.fun 7 Dec 2002 02:21:52 -0000 1.7
@@ -153,15 +153,20 @@
val arrayLengthOffset = ~ (2 * wordSize)
val allocTooLarge: word = 0wxFFFFFFFC
+val headerOffset = ~wordSize
+
fun normalSize {numPointers, numWordsNonPointers} =
wordSize * (numPointers + numWordsNonPointers)
-fun wordAlign (w: word): word =
+fun wordAlignWord (w: word): word =
let
open Word
in
andb (MLton.Word.addCheck (w, 0w3), notb 0w3)
end
+
+fun wordAlignInt (i: int): int =
+ Word.toInt (wordAlignWord (Word.fromInt i))
fun isWordAligned (n: int): bool =
0 = Int.rem (n, wordSize)
1.16 +4 -5 mlton/mlton/backend/runtime.sig
Index: runtime.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/runtime.sig,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- runtime.sig 2 Nov 2002 03:37:39 -0000 1.15
+++ runtime.sig 7 Dec 2002 02:21:52 -0000 1.16
@@ -32,7 +32,7 @@
| ProfileAllocIndex
| SignalIsPending
| StackBottom
- | StackLimit (* Must have StackTop <= StackLimit *)
+ | StackLimit (* Must have StackTop <= StackLimit *)
| StackTop (* Points at the next available word on the stack. *)
val layout: t -> Layout.t
@@ -60,9 +60,6 @@
| Normal of {numPointers: int,
numWordsNonPointers: int}
| Stack
-
- val equals: t * t -> bool
- val layout: t -> Layout.t
end
(* All sizes are in bytes, unless they explicitly say "pointers". *)
@@ -71,6 +68,7 @@
val arrayHeaderSize: int
val arrayLengthOffset: int
val array0Size: int
+ val headerOffset: int
val headerToTypeIndex: word -> int
val isWordAligned: int -> bool
val intInfOverheadSize: int
@@ -84,6 +82,7 @@
numWordsNonPointers: int} -> int
val pointerSize: int
val typeIndexToHeader: int -> word
- val wordAlign: word -> word (* Can raise Overflow. *)
+ val wordAlignInt: int -> int (* Can raise Overflow. *)
+ val wordAlignWord: word -> word (* Can raise Overflow. *)
val wordSize: int
end
1.11 +10 -6 mlton/mlton/backend/signal-check.fun
Index: signal-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/signal-check.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- signal-check.fun 2 Nov 2002 03:37:39 -0000 1.10
+++ signal-check.fun 7 Dec 2002 02:21:52 -0000 1.11
@@ -21,10 +21,10 @@
then p
else
let
- val Program.T {functions, main, profileAllocLabels} = p
+ val Program.T {functions, main, objectTypes, profileAllocLabels} = p
fun insert (f: Function.t): Function.t =
let
- val {args, blocks, name, start} = Function.dest f
+ val {args, blocks, name, raises, returns, start} = Function.dest f
val {get = labelIndex: Label.t -> int, set = setLabelIndex,
rem = remLabelIndex, ...} =
Property.getSetOnce
@@ -92,14 +92,15 @@
val compare =
Vector.new1
(Statement.PrimApp
- {args = Vector.new2 (Operand.CastInt
+ {args = Vector.new2 (Operand.Cast
(Operand.Runtime
- Runtime.GCField.Limit),
- Operand.int 0),
+ Runtime.GCField.Limit,
+ Type.Word),
+ Operand.word 0w0),
dst = SOME (res, Type.bool),
prim = Prim.eq})
val compareTransfer =
- Transfer.iff
+ Transfer.ifBool
(Operand.Var {var = res, ty = Type.bool},
{falsee = dontCollect,
truee = collect})
@@ -163,6 +164,8 @@
val f = Function.new {args = args,
blocks = blocks,
name = name,
+ raises = raises,
+ returns = returns,
start = start}
val _ = Function.clear f
in
@@ -171,6 +174,7 @@
in
Program.T {functions = List.revMap (functions, insert),
main = main,
+ objectTypes = objectTypes,
profileAllocLabels = profileAllocLabels}
end
1.12 +4 -4 mlton/mlton/backend/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- sources.cm 2 Nov 2002 03:37:39 -0000 1.11
+++ sources.cm 7 Dec 2002 02:21:52 -0000 1.12
@@ -12,7 +12,6 @@
functor Backend
functor Machine
-functor Runtime
is
@@ -38,10 +37,10 @@
limit-check.sig
live.fun
live.sig
-machine-cases.fun
-machine-cases.sig
machine.fun
machine.sig
+machine-atoms.fun
+machine-atoms.sig
mtype.fun
mtype.sig
parallel-move.fun
@@ -58,4 +57,5 @@
signal-check.sig
ssa-to-rssa.fun
ssa-to-rssa.sig
-
+switch.fun
+switch.sig
1.26 +414 -394 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.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- ssa-to-rssa.fun 24 Nov 2002 01:19:43 -0000 1.25
+++ ssa-to-rssa.fun 7 Dec 2002 02:21:52 -0000 1.26
@@ -9,10 +9,14 @@
struct
open S
+open Rssa
structure S = Ssa
-
-open Rssa
+local
+ open Ssa
+in
+ structure Con = Con
+end
local
open Runtime
in
@@ -160,20 +164,26 @@
datatype z = datatype Transfer.t
structure ImplementHandlers = ImplementHandlers (structure Ssa = Ssa)
-structure Representation = Representation (structure Ssa = Ssa
- structure Mtype = Type)
-
-local open Representation
+structure Representation = Representation (structure Rssa = Rssa
+ structure Ssa = Ssa)
+local
+ open Representation
in
- structure TyconRep = TyconRep
structure ConRep = ConRep
+ structure TupleRep = TupleRep
+ structure TyconRep = TyconRep
end
fun convert (p: S.Program.t): Rssa.Program.t =
let
val program as S.Program.T {datatypes, globals, functions, main} =
ImplementHandlers.doit p
- val {tyconRep, conRep, toMtype = toType} = Representation.compute program
+ val {conRep, objectTypes, refRep, toRtype, tupleRep, tyconRep} =
+ Representation.compute program
+ val conRep =
+ Trace.trace ("conRep", Con.layout, ConRep.layout) conRep
+ fun tyconTy (pt: PointerTycon.t): ObjectType.t =
+ Vector.sub (objectTypes, PointerTycon.index pt)
(* varInt is set for variables that are constant integers. It is used
* so that we can precompute array numBytes when numElts is known.
*)
@@ -200,140 +210,19 @@
setVarInfo
val varType = #ty o varInfo
fun varOp (x: Var.t): Operand.t =
- Var {var = x, ty = valOf (toType (varType x))}
+ Var {var = x, ty = valOf (toRtype (varType x))}
val varOp =
- Trace.trace
- ("SsaToRssa.varOp", Var.layout, Operand.layout)
- varOp
+ Trace.trace ("SsaToRssa.varOp", Var.layout, Operand.layout) varOp
fun varOps xs = Vector.map (xs, varOp)
- val _ =
- Control.diagnostics
- (fn display =>
- (display (Layout.str "Representations:")
- ; (Vector.foreach
- (datatypes, fn S.Datatype.T {tycon, cons} =>
- let open Layout
- in display (seq [Tycon.layout tycon,
- str " ",
- TyconRep.layout (tyconRep tycon)])
- ; display (indent
- (Vector.layout (fn {con, ...} =>
- seq [Con.layout con,
- str " ",
- ConRep.layout (conRep con)])
- cons,
- 2))
- end))))
- fun toTypes ts = Vector.map (ts, toType)
- val labelSize = Type.size Type.label
- val tagOffset = 0
- fun sortTypes (initialOffset: int,
- tys: Type.t option vector)
- : {numPointers: int,
- numWordsNonPointers: int,
- offsets: {offset: int, ty: Type.t} option vector,
- size: int} =
- let
- val bytes = ref []
- val doubleWords = ref []
- val words = ref []
- val pointers = ref []
- val numPointers = ref 0
- val _ =
- Vector.foreachi
- (tys, fn (i, t) =>
- case t of
- NONE => ()
- | SOME t =>
- let
- val r =
- if Type.isPointer t
- then (Int.inc numPointers
- ; pointers)
- else (case Type.size t of
- 1 => bytes
- | 4 => words
- | 8 => doubleWords
- | _ => Error.bug "strange size")
- in
- List.push (r, (i, t))
- end)
- fun build (r, size, accum) =
- List.fold (!r, accum, fn ((index, ty), (res, offset)) =>
- ({index = index, offset = offset, ty = ty} :: res,
- offset + size))
- val (accum, offset: int) =
- build (bytes, 1,
- build (words, 4,
- build (doubleWords, 8, ([], initialOffset))))
- val offset = Type.align (Type.pointer, offset)
- val numWordsNonPointers =
- (offset - initialOffset) div Runtime.wordSize
- val (components, size) = build (pointers, 4, (accum, offset))
- val offsets =
- Vector.mapi
- (tys, fn (i, ty) =>
- Option.map
- (ty, fn ty =>
- let
- val {offset, ty, ...} =
- List.lookup (components, fn {index, ...} => i = index)
- in
- {offset = offset, ty = ty}
- end))
- in
- {numPointers = !numPointers,
- numWordsNonPointers = numWordsNonPointers,
- offsets = offsets,
- size = size}
- end
- (* Compute layout for each con and associate it with the con. *)
- local
- val {get, set, ...} =
- Property.getSetOnce (Con.plist,
- Property.initRaise ("con info", Con.layout))
- in
- val _ =
- Vector.foreach
- (datatypes, fn S.Datatype.T {cons, ...} =>
- Vector.foreach (cons, fn {con, args} =>
- let
- fun doit n =
- let
- val mtypes = toTypes args
- val info = sortTypes (n, mtypes)
- in
- set (con, {info = info,
- mtypes = mtypes})
- end
- in
- case conRep con of
- ConRep.Tuple => doit 0
- | ConRep.TagTuple _ => doit 4
- | _ => ()
- end))
- val conInfo = get
- end
- (* Compute layout for each tuple type. *)
- val {get = tupleInfo, ...} =
- Property.get (S.Type.plist,
- Property.initFun
- (fn t => sortTypes (0, toTypes (S.Type.detuple t))))
- fun conSelects (variant: Var.t, con: Con.t): Operand.t vector =
- let
- val _ = Assert.assert ("conSelects", fn () =>
- case conRep con of
- ConRep.TagTuple _ => true
- | ConRep.Tuple => true
- | _ => false)
- val {info = {offsets, ...}, ...} = conInfo con
- in
- Vector.keepAllMap (offsets, fn off =>
- Option.map (off, fn {offset, ty} =>
- Offset {base = variant,
- bytes = offset,
- ty = ty}))
- end
+ fun toRtypes ts = Vector.map (ts, toRtype)
+ fun conSelects {rep = TupleRep.T {offsets, ...},
+ variant: Operand.t}: Operand.t vector =
+ Vector.keepAllMap
+ (offsets, fn off =>
+ Option.map (off, fn {offset, ty} =>
+ Offset {base = variant,
+ offset = offset,
+ ty = ty}))
val extraBlocks = ref []
val (resetAllocTooLarge, allocTooLarge) = Block.allocTooLarge extraBlocks
fun newBlock {args, kind, profileInfo,
@@ -351,57 +240,58 @@
in
l
end
+ val tagOffset = 0
fun genCase {cases: (Con.t * Label.t) vector,
default: Label.t option,
profileInfo,
- test: Var.t,
+ test: Operand.t,
testRep: TyconRep.t}: Transfer.t =
let
- fun switch {cases: Cases.t,
- default: Label.t option,
- numLeft: int,
- test: Operand.t}: Transfer.t =
+ fun enum (test: Operand.t): Transfer.t =
let
- datatype z = None | One of Label.t | Many
- val default = if numLeft = 0 then NONE else default
- val targets =
- Cases.fold
- (cases,
- case default of
- SOME l => One l
- | NONE => None,
- fn (l, Many) => Many
- | (l, One l') => if Label.equals (l, l')
- then One l'
- else Many
- | (l, None) => One l)
- in
- case targets of
- None => Error.bug "no targets"
- | One l => Goto {dst = l,
- args = Vector.new0 ()}
- | Many => Switch {test = test,
- cases = cases,
- default = default}
- end
- fun enum (test: Operand.t, numEnum: int): Transfer.t =
- let
- val (cases, numLeft) =
- Vector.fold
- (cases, ([], numEnum),
- fn ((c, j), (cases, numLeft)) =>
- let
- fun keep n = ((n, j) :: cases, numLeft - 1)
- in
- case conRep c of
- ConRep.Int n => keep n
- | ConRep.IntCast n => keep n
- | _ => (cases, numLeft)
- end)
- in switch {test = test,
- cases = Cases.Int cases,
- default = default,
- numLeft = numLeft}
+ val cases =
+ Vector.keepAllMap
+ (cases, fn (c, j) =>
+ case conRep c of
+ ConRep.IntAsTy {int, ...} => SOME (int, j)
+ | _ => NONE)
+ val numEnum =
+ case Operand.ty test of
+ Type.EnumPointers {enum, ...} => Vector.length enum
+ | _ => Error.bug "strage enum"
+ val default =
+ if numEnum = Vector.length cases
+ then NONE
+ else default
+ in
+ if 0 = Vector.length cases
+ then
+ (case default of
+ NONE => Error.bug "no targets"
+ | SOME l => Goto {dst = l,
+ args = Vector.new0 ()})
+ else
+ let
+ val l = #2 (Vector.sub (cases, 0))
+ in
+ if Vector.forall (cases, fn (_, l') =>
+ Label.equals (l, l'))
+ andalso (case default of
+ NONE => true
+ | SOME l' => Label.equals (l, l'))
+ then Goto {dst = l,
+ args = Vector.new0 ()}
+ else
+ let
+ val cases =
+ QuickSort.sortVector
+ (cases, fn ((i, _), (i', _)) => i <= i')
+ in
+ Switch (Switch.Int {test = test,
+ cases = cases,
+ default = default})
+ end
+ end
end
fun transferToLabel (transfer: Transfer.t): Label.t =
case transfer of
@@ -414,13 +304,43 @@
profileInfo = profileInfo,
statements = Vector.new0 (),
transfer = transfer}
- fun switchIP (numEnum, pointer: Label.t): Transfer.t =
- Transfer.SwitchIP
- {int = transferToLabel (enum (CastInt (Var {var = test,
- ty = Type.pointer}),
- numEnum)),
- pointer = pointer,
- test = varOp test}
+ fun switchEP (makePointersTransfer: Operand.t -> Transfer.t)
+ : Transfer.t =
+ let
+ val {enum = e, pointers = p} =
+ case Operand.ty test of
+ Type.EnumPointers ep => ep
+ | _ => Error.bug "strange switchEP"
+ val enumTy = Type.EnumPointers {enum = e,
+ pointers = Vector.new0 ()}
+ val enumVar = Var.newNoname ()
+ val enumOp = Operand.Var {var = enumVar,
+ ty = enumTy}
+ val pointersTy = Type.EnumPointers {enum = Vector.new0 (),
+ pointers = p}
+ val pointersVar = Var.newNoname ()
+ val pointersOp = Operand.Var {ty = pointersTy,
+ var = pointersVar}
+ fun block (var, ty, transfer) =
+ newBlock {args = Vector.new0 (),
+ kind = Kind.Jump,
+ profileInfo = profileInfo,
+ statements = (Vector.new1
+ (Statement.Bind
+ {isMutable = false,
+ oper = Operand.Cast (test, ty),
+ var = var})),
+ transfer = transfer}
+ val pointers =
+ block (pointersVar, pointersTy,
+ makePointersTransfer pointersOp)
+ val enum = block (enumVar, enumTy, enum enumOp)
+ in
+ Switch (Switch.EnumPointers
+ {enum = enum,
+ pointers = pointers,
+ test = test})
+ end
fun tail (l: Label.t, args: Operand.t vector): Label.t =
if 0 = Vector.length args
then l
@@ -434,40 +354,89 @@
statements = Vector.new0 (),
transfer = Goto {dst = l, args = args}}
end
- fun enumAndOne (numEnum: int): Transfer.t =
+ fun enumAndOne (): Transfer.t =
let
- val (l, args: Operand.t vector) =
- Vector.loop
- (cases, fn (c, j) =>
- case conRep c of
- ConRep.Transparent _ =>
- SOME (j, Vector.new1 (varOp test))
- | ConRep.Tuple => SOME (j, conSelects (test, c))
- | _ => NONE,
- fn () =>
- case default of
- NONE =>
- Error.bug "enumAndOne: no default"
- | SOME j => (j, Vector.new0 ()))
- in switchIP (numEnum, tail (l, args))
+ fun make (pointersOp: Operand.t): Transfer.t =
+ let
+ val (dst, args: Operand.t vector) =
+ case Vector.peekMap
+ (cases, fn (c, j) =>
+ case conRep c of
+ ConRep.Transparent _ =>
+ SOME (j, Vector.new1 pointersOp)
+ | ConRep.Tuple r =>
+ SOME (j, conSelects {rep = r,
+ variant = pointersOp})
+ | _ => NONE) of
+ NONE =>
+ (case default of
+ NONE => Error.bug "enumAndOne: no default"
+ | SOME j => (j, Vector.new0 ()))
+ | SOME z => z
+ in
+ Transfer.Goto {args = args,
+ dst = dst}
+ end
+ in
+ switchEP make
end
- fun indirectTag (numTag: int): Transfer.t =
+ fun indirectTag (test: Operand.t): Transfer.t =
let
- val (cases, numLeft) =
- Vector.fold
- (cases, ([], numTag),
- fn ((c, j), (cases, numLeft)) =>
+ val cases =
+ Vector.keepAllMap
+ (cases, fn (c, l) =>
case conRep c of
- ConRep.TagTuple n =>
- ((n, tail (j, conSelects (test, c))) :: cases,
- numLeft - 1)
- | _ => (cases, numLeft))
- in switch {test = Offset {base = test,
- bytes = tagOffset,
+ ConRep.TagTuple {rep, tag} =>
+ let
+ val tycon = TupleRep.tycon rep
+ val pointerVar = Var.newNoname ()
+ val pointerTy = Type.pointer tycon
+ val pointerOp =
+ Operand.Var {ty = pointerTy,
+ var = pointerVar}
+ val statements =
+ Vector.new1
+ (Statement.Bind
+ {isMutable = false,
+ oper = Operand.Cast (test, pointerTy),
+ var = pointerVar})
+ val dst =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.Jump,
+ profileInfo = profileInfo,
+ statements = statements,
+ transfer =
+ Goto {args = conSelects {rep = rep,
+ variant = pointerOp},
+ dst = l}}
+ in
+ SOME {dst = dst,
+ tag = tag,
+ tycon = tycon}
+ end
+ | _ => NONE)
+ val numTag =
+ case Operand.ty test of
+ Type.EnumPointers {pointers, ...} =>
+ Vector.length pointers
+ | _ => Error.bug "strange indirecTag"
+ val default =
+ if numTag = Vector.length cases
+ then NONE
+ else default
+ val cases =
+ QuickSort.sortVector
+ (cases, fn ({tycon = t, ...}, {tycon = t', ...}) =>
+ PointerTycon.<= (t, t'))
+ in
+ Switch (Switch.Pointer
+ {cases = cases,
+ default = default,
+ tag = Offset {base = test,
+ offset = tagOffset,
ty = Type.int},
- cases = Cases.Int cases,
- default = default,
- numLeft = numLeft}
+ test = test})
end
fun prim () =
case (Vector.length cases, default) of
@@ -484,23 +453,23 @@
args = Vector.new0 ()}
| ConRep.Transparent _ =>
Goto {dst = l,
- args = Vector.new1 (varOp test)}
- | ConRep.Tuple =>
+ args = Vector.new1 test}
+ | ConRep.Tuple r =>
Goto {dst = l,
- args = conSelects (test, c)}
+ args = conSelects {rep = r,
+ variant = test}}
| _ => Error.bug "strange conRep for Prim"
end
| (0, SOME l) => Goto {dst = l, args = Vector.new0 ()}
| _ => Error.bug "prim datatype with more than one case"
in
case testRep of
- TyconRep.Prim mtype => prim ()
- | TyconRep.Enum {numEnum} => enum (varOp test, numEnum)
- | TyconRep.EnumDirect {numEnum} => enumAndOne numEnum
- | TyconRep.EnumIndirect {numEnum} => enumAndOne numEnum
- | TyconRep.EnumIndirectTag {numEnum, numTag} =>
- switchIP (numEnum, transferToLabel (indirectTag numTag))
- | TyconRep.IndirectTag {numTag} => indirectTag numTag
+ TyconRep.Direct => prim ()
+ | TyconRep.Enum => enum test
+ | TyconRep.EnumDirect => enumAndOne ()
+ | TyconRep.EnumIndirect => enumAndOne ()
+ | TyconRep.EnumIndirectTag => switchEP indirectTag
+ | TyconRep.IndirectTag => indirectTag test
| TyconRep.Void => prim ()
end
fun translateCase (profileInfo,
@@ -509,17 +478,20 @@
default: Label.t option}): Transfer.t =
let
fun id x = x
- fun doit (l, f, branch) =
- Switch {test = varOp test,
- cases = f (Vector.toListMap
- (l, fn (i, j) => (branch i, j))),
- default = default}
+ fun simple (l, make, branch, le) =
+ Switch
+ (make {test = varOp test,
+ cases = (QuickSort.sortVector
+ (Vector.map (l, fn (i, j) => (branch i, j)),
+ fn ((i, _), (i', _)) => le (i, i'))),
+ default = default})
in
case cases of
- S.Cases.Char l => doit (l, Cases.Char, id)
- | S.Cases.Int l => doit (l, Cases.Int, id)
- | S.Cases.Word l => doit (l, Cases.Word, id)
- | S.Cases.Word8 l => doit (l, Cases.Char, Word8.toChar)
+ S.Cases.Char cs => simple (cs, Switch.Char, id, Char.<=)
+ | S.Cases.Int cs => simple (cs, Switch.Int, id, Int.<=)
+ | S.Cases.Word cs => simple (cs, Switch.Word, id, Word.<=)
+ | S.Cases.Word8 cs =>
+ simple (cs, Switch.Char, Word8.toChar, Char.<=)
| S.Cases.Con cases =>
(case (Vector.length cases, default) of
(0, NONE) => Transfer.bug
@@ -531,7 +503,7 @@
then genCase {cases = cases,
default = default,
profileInfo = profileInfo,
- test = test,
+ test = varOp test,
testRep = tyconRep tycon}
else Error.bug "strange type in case"
end)
@@ -547,7 +519,7 @@
let
val {args, ...} = labelInfo l
val args = Vector.keepAllMap (args, fn (x, t) =>
- Option.map (toType t, fn t =>
+ Option.map (toRtype t, fn t =>
(Var.new x, t)))
val l' = Label.new l
val _ =
@@ -611,13 +583,13 @@
labelCont
fun vos (xs: Var.t vector) =
Vector.keepAllMap (xs, fn x =>
- Option.map (toType (varType x), fn _ =>
+ Option.map (toRtype (varType x), fn _ =>
varOp x))
fun translateTransfer (profileInfo, t: S.Transfer.t): Transfer.t =
case t of
S.Transfer.Arith {args, overflow, prim, success, ty} =>
let
- val ty = valOf (toType ty)
+ val ty = valOf (toRtype ty)
val temp = Var.newNoname ()
val noOverflow =
newBlock
@@ -698,7 +670,25 @@
end
fun translateFormals v =
Vector.keepAllMap (v, fn (x, t) =>
- Option.map (toType t, fn t => (x, t)))
+ Option.map (toRtype t, fn t => (x, t)))
+ fun bogus (t: Type.t): Operand.t =
+ let
+ val c = Operand.Const
+ in
+ case t of
+ Type.Char =>
+ c (Const.fromChar #"\000")
+ | Type.CPointer =>
+ Error.bug "bogus CPointer"
+ | Type.EnumPointers (ep as {enum, ...}) =>
+ Operand.Cast (Operand.int 1, t)
+ | Type.Int => c (Const.fromInt 0)
+ | Type.IntInf => SmallIntInf 0wx1
+ | Type.Label => Error.bug "bogus Label"
+ | Type.MemChunk _ => Error.bug "bogus MemChunk"
+ | Type.Real => c (Const.fromReal "0.0")
+ | Type.Word => c (Const.fromWord 0w0)
+ end
fun translateStatementsTransfer (profileInfo, statements, transfer) =
let
fun loop (i, ss, t): Statement.t vector * Transfer.t =
@@ -706,7 +696,7 @@
then (Vector.fromList ss, t)
else
let
- val S.Statement.T {var, ty, exp} =
+ val s as S.Statement.T {var, ty, exp} =
Vector.sub (statements, i)
fun none () = loop (i - 1, ss, t)
fun add s = loop (i - 1, s :: ss, t)
@@ -724,39 +714,39 @@
loop (i - 1, ss, t)
end
fun makeStores (ys: Var.t vector, offsets) =
- Vector.keepAllMap2
- (ys, offsets, fn (y, offset) =>
- Option.map (offset, fn {offset, ty} =>
- {offset = offset,
- value = varOp y}))
+ QuickSort.sortVector
+ (Vector.keepAllMap2
+ (ys, offsets, fn (y, offset) =>
+ Option.map (offset, fn {offset, ty} =>
+ {offset = offset,
+ value = varOp y})),
+ fn ({offset = i, ...}, {offset = i', ...}) => i <= i')
fun allocate (ys: Var.t vector,
- {size, offsets, numPointers,
- numWordsNonPointers}) =
- let
- val (p, np) =
- if 0 = numPointers
- andalso 0 = numWordsNonPointers
- then (0, 1)
- else (numPointers, numWordsNonPointers)
- in
- add (Object {dst = valOf var,
- numPointers = p,
- numWordsNonPointers = np,
- stores = makeStores (ys, offsets)})
- end
+ TupleRep.T {size, offsets, ty, tycon, ...}) =
+ add (Object {dst = valOf var,
+ size = size + Runtime.normalHeaderSize,
+ stores = makeStores (ys, offsets),
+ ty = ty,
+ tycon = tycon})
+ val allocate =
+ Trace.trace2
+ ("allocate",
+ Vector.layout Var.layout,
+ TupleRep.layout,
+ Layout.ignore)
+ allocate
fun allocateTagged (n: int,
ys: Var.t vector,
- {size, offsets,
- numPointers, numWordsNonPointers}) =
+ TupleRep.T {size, offsets, ty, tycon}) =
add (Object
{dst = valOf var,
- numPointers = numPointers,
- numWordsNonPointers =
- (* for the tag *) 1 + numWordsNonPointers,
+ size = size + Runtime.normalHeaderSize,
stores = (Vector.concat
[Vector.new1 {offset = tagOffset,
value = Operand.int n},
- makeStores (ys, offsets)])})
+ makeStores (ys, offsets)]),
+ ty = ty,
+ tycon = tycon})
fun move (oper: Operand.t) =
add (Bind {isMutable = false,
oper = oper,
@@ -766,28 +756,33 @@
S.Exp.ConApp {con, args} =>
(case conRep con of
ConRep.Void => none ()
- | ConRep.Int n => move (Operand.int n)
- | ConRep.IntCast n => move (Operand.Pointer n)
- | ConRep.TagTuple n =>
- allocateTagged (n, args, #info (conInfo con))
+ | ConRep.IntAsTy {int, ty} =>
+ move (Operand.Cast (Operand.int int, ty))
+ | ConRep.TagTuple {rep, tag} =>
+ allocateTagged (tag, args, rep)
| ConRep.Transparent _ =>
- move (varOp (Vector.sub (args, 0)))
- | ConRep.Tuple =>
- allocate (args, #info (conInfo con)))
+ move (Operand.cast
+ (varOp (Vector.sub (args, 0)),
+ valOf (toRtype ty)))
+ | ConRep.Tuple rep =>
+ allocate (args, rep))
| S.Exp.Const c => move (Operand.Const c)
| S.Exp.PrimApp {prim, targs, args, ...} =>
let
fun a i = Vector.sub (args, i)
- fun targ () = toType (Vector.sub (targs, 0))
+ fun cast () =
+ move (Operand.cast (varOp (a 0),
+ valOf (toRtype ty)))
+ fun targ () = toRtype (Vector.sub (targs, 0))
fun arrayOffset (ty: Type.t): Operand.t =
- ArrayOffset {base = a 0,
- index = a 1,
+ ArrayOffset {base = varOp (a 0),
+ index = varOp (a 1),
ty = ty}
fun sub (ty: Type.t) = move (arrayOffset ty)
fun dst () =
case var of
SOME x =>
- Option.map (toType (varType x), fn t =>
+ Option.map (toRtype (varType x), fn t =>
(x, t))
| NONE => NONE
fun normal () =
@@ -868,119 +863,112 @@
fun simpleCCall (f: CFunction.t) =
ccall {args = vos args,
func = f}
- fun array0 (numElts: Operand.t) =
- add
- (PrimApp {args = Vector.new1 numElts,
- dst = dst (),
- prim = Prim.array0})
+ fun array (numElts: Operand.t) =
+ let
+ val pt =
+ case (Type.dePointer
+ (valOf (toRtype ty))) of
+ NONE => Error.bug "strange array"
+ | SOME pt => PointerTycon pt
+ val args =
+ Vector.new4 (Operand.GCState,
+ Operand.EnsuresBytesFree,
+ numElts,
+ pt)
+ in
+ ccall {args = args,
+ func = CFunction.gcArrayAllocate}
+ end
fun updateCard (addr: Operand.t, prefix, assign) =
let
val index = Var.newNoname ()
- val map = Var.newNoname ()
val ss =
(PrimApp
{args = (Vector.new2
- (Operand.CastWord addr,
+ (Operand.Cast (addr, Type.Word),
Operand.word
(Word.fromInt
(!Control.cardSizeLog2)))),
dst = SOME (index, Type.int),
prim = Prim.word32Rshift})
- :: (Bind {isMutable = false,
- oper = Operand.Runtime GCField.CardMap,
- var = map})
:: (Move
{dst = (Operand.ArrayOffset
- {base = map,
- index = index,
+ {base = (Operand.Runtime
+ GCField.CardMap),
+ index = Operand.Var {ty = Type.int,
+ var = index},
ty = Type.char}),
src = Operand.char #"\001"})
- :: assign
+ :: assign
:: ss
in
loop (i - 1, prefix ss, t)
end
- fun arrayUpdate (ty, src) =
+ fun arrayUpdate (ty: Type.t) =
if !Control.markCards andalso Type.isPointer ty
then let
+ val src = varOp (a 2)
+ val arrayOp = varOp (a 0)
val temp = Var.newNoname ()
val tempOp = Operand.Var {var = temp,
ty = Type.word}
val addr = Var.newNoname ()
- val addrOp = Operand.Var {var = addr,
- ty = Type.pointer}
+ val mc =
+ case Type.dePointer (Operand.ty arrayOp) of
+ NONE => Error.bug "strange array"
+ | SOME p =>
+ case tyconTy p of
+ ObjectType.Array mc => mc
+ | _ => Error.bug "strange array"
+ val addrOp =
+ Operand.Var {var = addr,
+ ty = Type.MemChunk mc}
fun prefix ss =
(PrimApp
{args = Vector.new2
- (Operand.CastWord (varOp (a 1)),
+ (Operand.Cast (varOp (a 1),
+ Type.Word),
Operand.word
(Word.fromInt (Type.size ty))),
dst = SOME (temp, Type.word),
prim = Prim.word32Mul})
:: (PrimApp
{args = (Vector.new2
- (Operand.CastWord
- (varOp (a 0)),
+ (Operand.Cast (arrayOp,
+ Type.Word),
tempOp)),
- dst = SOME (addr, Type.pointer),
+ dst = SOME (addr, Type.MemChunk mc),
prim = Prim.word32Add})
:: ss
- val assign = Move {dst = Operand.Offset
- {base = addr,
- bytes = 0,
- ty = ty},
- src = src}
+ val assign =
+ Move {dst = (Operand.Offset
+ {base = addrOp,
+ offset = 0,
+ ty = ty}),
+ src = varOp (a 2)}
in
updateCard (addrOp, prefix, assign)
end
else add (Move {dst = arrayOffset ty,
- src = src})
+ src = varOp (a 2)})
fun refAssign (ty, src) =
let
- val addr = a 0
+ val addr = varOp (a 0)
val assign = Move {dst = Operand.Offset {base = addr,
- bytes = 0,
+ offset = 0,
ty = ty},
src = src}
in
if !Control.markCards andalso Type.isPointer ty
- then updateCard (varOp addr, fn ss => ss, assign)
+ then updateCard (addr, fn ss => ss, assign)
else loop (i - 1, assign::ss, t)
end
-
-
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
Array_array =>
- let
- val numElts = a 0
- val numEltsOp = Operand.Var {var = numElts, ty = Type.int}
- in
- case targ () of
- NONE => array0 numEltsOp
- | SOME t =>
- let
- val (nbnp, np, bytesPerElt) =
- if Type.isPointer t
- then (0, 1, Runtime.pointerSize)
- else
- let val n = Type.size t
- in (n, 0, n)
- end
- in
- if 0 = np andalso 0 = nbnp
- then array0 numEltsOp
- else ccall {args = (Vector.new4
- (Operand.GCState,
- Operand.EnsuresBytesFree,
- numEltsOp,
- ArrayHeader {numBytesNonPointers = nbnp,
- numPointers = np})),
- func = CFunction.gcArrayAllocate}
- end
- end
- | Array_array0 => array0 (Operand.int 0)
+ array (Operand.Var {var = a 0,
+ ty = Type.int})
| Array_sub =>
(case targ () of
NONE => none ()
@@ -988,7 +976,10 @@
| Array_update =>
(case targ () of
NONE => none ()
- | SOME ty => arrayUpdate (ty, varOp (a 2)))
+ | SOME ty => arrayUpdate ty)
+ | Byte_byteToChar => cast ()
+ | Byte_charToByte => cast ()
+ | C_CS_charArrayToWord8Array => cast ()
| FFI name =>
if Option.isNone (Prim.numArgs prim)
then normal ()
@@ -998,7 +989,9 @@
{name = name,
returnTy =
Option.map
- (var, valOf o toType o varType)})
+ (var, fn x =>
+ Type.toRuntime
+ (valOf (toRtype (varType x))))})
| GC_collect =>
ccall
{args = Vector.new5 (Operand.GCState,
@@ -1016,13 +1009,17 @@
func = CFunction.unpack}
| IntInf_add => simpleCCall CFunction.intInfAdd
| IntInf_andb => simpleCCall CFunction.intInfAndb
- | IntInf_arshift => simpleCCall CFunction.intInfArshift
+ | IntInf_arshift =>
+ simpleCCall CFunction.intInfArshift
| IntInf_compare =>
simpleCCall CFunction.intInfCompare
| IntInf_equal =>
simpleCCall CFunction.intInfEqual
+ | IntInf_fromVector => cast ()
+ | IntInf_fromWord => cast ()
| IntInf_gcd => simpleCCall CFunction.intInfGcd
- | IntInf_lshift => simpleCCall CFunction.intInfLshift
+ | IntInf_lshift =>
+ simpleCCall CFunction.intInfLshift
| IntInf_mul => simpleCCall CFunction.intInfMul
| IntInf_neg => simpleCCall CFunction.intInfNeg
| IntInf_notb => simpleCCall CFunction.intInfNotb
@@ -1032,27 +1029,13 @@
| IntInf_sub => simpleCCall CFunction.intInfSub
| IntInf_toString =>
simpleCCall CFunction.intInfToString
+ | IntInf_toVector => cast ()
+ | IntInf_toWord => cast ()
| IntInf_xorb => simpleCCall CFunction.intInfXorb
| MLton_bogus =>
- (case toType ty of
+ (case toRtype ty of
NONE => none ()
- | SOME t =>
- let
- val c = Operand.Const
- in
- move
- (case Type.dest t of
- Type.Char =>
- c (Const.fromChar #"\000")
- | Type.Double =>
- c (Const.fromReal "0.0")
- | Type.Int =>
- c (Const.fromInt 0)
- | Type.Pointer =>
- Operand.Pointer 1
- | Type.Uint =>
- c (Const.fromWord 0w0))
- end)
+ | SOME t => move (bogus t))
| MLton_bug => simpleCCall CFunction.bug
| MLton_eq =>
(case targ () of
@@ -1074,19 +1057,15 @@
(case targ () of
NONE => none ()
| SOME ty =>
- move (Offset {base = a 0,
- bytes = 0,
+ move (Offset {base = varOp (a 0),
+ offset = 0,
ty = ty}))
| Ref_ref =>
- let
- val (ys, ts) =
- case targ () of
- NONE => (Vector.new0 (),
- Vector.new0 ())
- | SOME t => (Vector.new1 (a 0),
- Vector.new1 (SOME t))
- in allocate (ys, sortTypes (0, ts))
- end
+ allocate
+ (Vector.new1 (a 0),
+ refRep (Vector.sub (targs, 0)))
+ | String_fromWord8Vector => cast ()
+ | String_toWord8Vector => cast ()
| Thread_atomicBegin =>
(* assert (s->canHandle >= 0);
* s->canHandle++;
@@ -1107,8 +1086,9 @@
dst = SOME (tmp, Type.word),
prim = prim},
Statement.Move
- {dst = (Operand.CastWord
- (Operand.Runtime dst)),
+ {dst = (Operand.Cast
+ (Operand.Runtime dst,
+ Type.Word)),
src = (Operand.Var
{var = tmp,
ty = Type.word})})
@@ -1132,7 +1112,7 @@
dst = l})}
in
(bumpCanHandle 1,
- Transfer.iff
+ Transfer.ifInt
(Operand.Runtime SignalIsPending,
{falsee = l,
truee = l'}))
@@ -1151,8 +1131,9 @@
val statements =
Vector.new1
(Statement.Move
- {dst = (Operand.CastWord
- (Operand.Runtime Limit)),
+ {dst = (Operand.Cast
+ (Operand.Runtime Limit,
+ Type.Word)),
src = Operand.word 0w0})
val l'' =
newBlock
@@ -1171,13 +1152,13 @@
profileInfo = profileInfo,
statements = Vector.new0 (),
transfer =
- Transfer.iff
+ Transfer.ifInt
(Operand.Runtime CanHandle,
- {truee = l,
- falsee = l''})}
+ {falsee = l'',
+ truee = l})}
in
(bumpCanHandle ~1,
- Transfer.iff
+ Transfer.ifInt
(Operand.Runtime SignalIsPending,
{falsee = l,
truee = l'}))
@@ -1194,11 +1175,36 @@
(varOp (a 0),
Operand.EnsuresBytesFree)),
func = CFunction.threadSwitchTo}
- | Vector_fromArray => move (varOp (a 0))
+ | Vector_fromArray =>
+ let
+ val array = varOp (a 0)
+ val vecTy = valOf (toRtype ty)
+ val pt =
+ case Type.dePointer vecTy of
+ NONE => Error.bug "strange Vector_fromArray"
+ | SOME pt => pt
+ in
+ loop
+ (i - 1,
+ Move
+ {dst = (Offset
+ {base = array,
+ offset = Runtime.headerOffset,
+ ty = Type.word}),
+ src = PointerTycon pt}
+ :: Bind {isMutable = false,
+ oper = (Operand.Cast
+ (array, vecTy)),
+ var = valOf var}
+ :: ss,
+ t)
+ end
| Vector_sub =>
(case targ () of
NONE => none ()
| SOME t => sub t)
+ | Word32_toIntX => cast ()
+ | Word32_fromInt => cast ()
| World_save =>
ccall {args = (Vector.new2
(Operand.GCState,
@@ -1207,21 +1213,28 @@
| _ => normal ()
end
| S.Exp.Select {tuple, offset} =>
- (case Vector.sub (#offsets (tupleInfo (varType tuple)),
- offset) of
- NONE => none ()
- | SOME {offset, ty} =>
- move (Offset {base = tuple,
- bytes = offset,
- ty = ty}))
+ let
+ val TupleRep.T {offsets, ...} =
+ tupleRep (varType tuple)
+ in
+ case Vector.sub (offsets, offset) of
+ NONE => none ()
+ | SOME {offset, ty} =>
+ move (Offset {base = varOp tuple,
+ offset = offset,
+ ty = ty})
+ end
| S.Exp.SetExnStackLocal => add SetExnStackLocal
| S.Exp.SetExnStackSlot => add SetExnStackSlot
| S.Exp.SetHandler h =>
add (SetHandler (labelHandler (profileInfo, h)))
| S.Exp.SetSlotExnStack => add SetSlotExnStack
- | S.Exp.Tuple ys => allocate (ys, tupleInfo ty)
+ | S.Exp.Tuple ys =>
+ if 0 = Vector.length ys
+ then none ()
+ else allocate (ys, tupleRep ty)
| S.Exp.Var y =>
- (case toType ty of
+ (case toRtype ty of
NONE => none ()
| SOME _ => move (varOp y))
| _ => Error.bug "translateStatement saw strange PrimExp"
@@ -1250,7 +1263,8 @@
val _ = resetAllocTooLarge ()
val _ =
S.Function.foreachVar (f, fn (x, t) => setVarInfo (x, {ty = t}))
- val {args, blocks, name, start, ...} = S.Function.dest f
+ val {args, blocks, name, raises, returns, start, ...} =
+ S.Function.dest f
val _ =
Vector.foreach
(blocks, fn S.Block.T {label, args, ...} =>
@@ -1265,10 +1279,15 @@
translateBlock (profileInfo, block))
val blocks = Vector.concat [Vector.fromList (!extraBlocks), blocks]
val _ = extraBlocks := []
+ fun transTypes (ts : S.Type.t vector option)
+ : Type.t vector option =
+ Option.map (ts, fn ts => Vector.keepAllMap (ts, toRtype))
in
Function.new {args = translateFormals args,
blocks = blocks,
name = name,
+ raises = transTypes raises,
+ returns = transTypes returns,
start = start}
end
val main =
@@ -1294,6 +1313,7 @@
val functions = List.revMap (functions, translateFunction)
val p = Program.T {functions = functions,
main = main,
+ objectTypes = objectTypes,
profileAllocLabels = Vector.new0 ()}
val _ = Program.clear p
in
1.4 +4 -2 mlton/mlton/backend/ssa-to-rssa.sig
Index: ssa-to-rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/ssa-to-rssa.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- ssa-to-rssa.sig 16 Apr 2002 12:10:52 -0000 1.3
+++ ssa-to-rssa.sig 7 Dec 2002 02:21:52 -0000 1.4
@@ -12,11 +12,13 @@
sig
structure Rssa: RSSA
structure Ssa: SSA
- sharing Rssa.Atoms = Ssa.Atoms
+ sharing Rssa.Const = Ssa.Const
sharing Rssa.Func = Ssa.Func
+ sharing Rssa.Handler = Ssa.Handler
sharing Rssa.Label = Ssa.Label
+ sharing Rssa.Prim = Ssa.Prim
sharing Rssa.Return = Ssa.Return
- sharing Rssa.Handler = Ssa.Handler
+ sharing Rssa.Var = Ssa.Var
end
signature SSA_TO_RSSA =
1.1 mlton/mlton/backend/machine-atoms.fun
Index: machine-atoms.fun
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor MachineAtoms (S: MACHINE_ATOMS_STRUCTS): MACHINE_ATOMS =
struct
open S
structure PointerTycon =
struct
datatype t = T of {index: int,
plist: PropertyList.t}
local
fun make f (T r) = f r
in
val index = make #index
val plist = make #plist
end
fun equals (pt, pt') = PropertyList.equals (plist pt, plist pt')
val op <= = fn (pt, pt') => index pt <= index pt'
fun toString (T {index, ...}) =
concat ["pt_", Int.toString index]
val layout = Layout.str o toString
val c = Counter.new 0
fun new () =
T {index = Counter.next c,
plist = PropertyList.new ()}
(* These basic pointer tycons are hardwired into the runtime and are
* prefixed to every user program. See gc.h for the definitions of
* {STACK,STRING,THREAD,WORD_VECTOR}_TYPE_INDEX.
*)
val stack = new ()
val string = new ()
val thread = new ()
val wordVector = new ()
end
structure TypeAndMemChunk =
struct
datatype ty =
Char
| CPointer
| EnumPointers of {enum: int vector,
pointers: PointerTycon.t vector}
| Int
| IntInf
| Label
| MemChunk of memChunk
| Real
| Word
and memChunk =
T of {components: {mutable: bool,
offset: int,
ty: ty} vector,
size: int}
fun layoutTy (t: ty) =
let
open Layout
in
case t of
Char => str "char"
| CPointer => str "cpointer"
| EnumPointers {enum, pointers} =>
if 0 = Vector.length enum
andalso 1 = Vector.length pointers
then PointerTycon.layout (Vector.sub (pointers, 0))
else
Vector.layout (fn x => x)
(Vector.concat [Vector.map (enum, Int.layout),
Vector.map (pointers, PointerTycon.layout)])
| Int => str "int"
| IntInf => str "intInf"
| Label => str "Label"
| MemChunk m => seq [str "MemChunk ", layoutMemChunk m]
| Real => str "real"
| Word => str "word"
end
and layoutMemChunk (T {components, size}) =
Layout.record
[("components",
Vector.layout (fn {mutable, offset, ty} =>
Layout.record [("mutable", Bool.layout mutable),
("offset", Int.layout offset),
("ty", layoutTy ty)])
components),
("size", Int.layout size)]
fun equalsTy (t, t'): bool =
case (t, t') of
(Char, Char) => true
| (CPointer, CPointer) => true
| (EnumPointers {enum = e, pointers = p},
EnumPointers {enum = e', pointers = p'}) =>
e = e'
andalso (MLton.eq (p, p')
orelse Vector.equals (p, p', PointerTycon.equals))
| (Int, Int) => true
| (IntInf, IntInf) => true
| (Label, Label) => true
| (MemChunk m, MemChunk m') => equalsMemChunk (m, m')
| (Real, Real) => true
| (Word, Word) => true
| _ => false
and equalsMemChunk (T {components = cs, size = s},
T {components = cs', size = s'}) =
s = s'
andalso
Vector.equals (cs, cs', fn ({mutable = m, offset = i, ty = t},
{mutable = m', offset = i', ty = t'}) =>
m = m' andalso i = i' andalso equalsTy (t, t'))
local
val byte: int = 1
val word: int = 4
val double: int = 8
in
val size =
fn Char => byte
| CPointer => word
| EnumPointers _ => word
| Int => word
| IntInf => word
| Label => word
| MemChunk _ => word
| Real => double
| Word => word
end
fun isOkTy (t: ty): bool =
case t of
Char => true
| CPointer => true
| EnumPointers {enum, pointers} =>
Vector.isSorted (enum, op <=)
andalso Vector.isSorted (pointers, PointerTycon.<=)
andalso (0 = Vector.length pointers
orelse Vector.forall (enum, Int.isOdd))
| Int => true
| IntInf => true
| Label => true
| MemChunk m => isOkMemChunk m
| Real => true
| Word => true
and isOkMemChunk (T {components, size = s}) =
let
exception No
fun no () = raise No
fun doit () =
Vector.fold
(components, (0, false),
fn ({offset, ty, ...}, (prev, isPointer)) =>
if prev <= offset
andalso isOkTy ty
andalso (case ty of
(* Can't store pointers to MemChunks in other
* MemChunks.
*)
MemChunk _ => false
| _ => true)
then (offset + size ty,
let
fun nonPointer () =
if isPointer
then no ()
else false
in
case ty of
EnumPointers {pointers, ...} =>
if 0 = Vector.length pointers
then nonPointer ()
else true
| IntInf => true
| _ => nonPointer ()
end)
else no ())
in
#1 (doit ()) <= s
handle No => false
end
end
type memChunk = TypeAndMemChunk.memChunk
structure Type =
struct
local
open TypeAndMemChunk
in
datatype t = datatype ty
val equals = equalsTy
val layout = layoutTy
val size = size
end
val toString = Layout.toString o layout
val bool = EnumPointers {enum = Vector.new2 (0, 1),
pointers = Vector.new0 ()}
val char = Char
val cpointer = CPointer
val int = Int
val intInf = IntInf
val label = Label
val real = Real
val word = Word
fun pointer pt =
EnumPointers {enum = Vector.new0 (),
pointers = Vector.new1 pt}
val stack = pointer PointerTycon.stack
val string = pointer PointerTycon.string
val thread = pointer PointerTycon.thread
val wordVector = pointer PointerTycon.wordVector
fun containsPointer (t, pt): bool =
case t of
EnumPointers {pointers, ...} =>
Vector.exists (pointers, fn pt' => PointerTycon.equals (pt, pt'))
| _ => false
val isPointer =
fn EnumPointers {pointers, ...} => 0 < Vector.length pointers
| IntInf => true
| _ => false
fun split ({enum, pointers}) =
{enum = {enum = enum, pointers = Vector.new0 ()},
pointers = {enum = Vector.new0 (), pointers = pointers}}
local
structure R = Runtime.Type
in
val fromRuntime: Runtime.Type.t -> t =
fn t =>
case R.dest t of
R.Char => char
| R.Double => real
| R.Int => int
| R.Pointer => cpointer
| Uint => word
val toRuntime: t -> Runtime.Type.t =
fn Char => R.char
| CPointer => R.pointer
| EnumPointers {enum, pointers} =>
if 0 = Vector.length pointers
then R.int
else R.pointer
| Int => R.int
| IntInf => R.pointer
| Label => R.uint
| MemChunk _ => R.pointer
| Real => R.double
| Word => R.word
val name = R.name o toRuntime
fun align (t: t, n: int): int = R.align (toRuntime t, n)
end
val equals =
Trace.trace2 ("Rtype.equals", layout, layout, Bool.layout) equals
fun dePointer t =
case t of
EnumPointers {enum, pointers} =>
if 0 = Vector.length enum
andalso 1 = Vector.length pointers
then SOME (Vector.sub (pointers, 0))
else NONE
| _ => NONE
end
structure MemChunk =
struct
local
open TypeAndMemChunk
in
datatype t = datatype memChunk
val isOk = isOkMemChunk
val layout = layoutMemChunk
end
fun numBytesAndPointers (T {components, size}) =
let
val offset =
case Vector.peek (components, Type.isPointer o #ty) of
NONE => size
| SOME {offset, ...} => offset
in
(offset, Int.quot (size - offset, Runtime.pointerSize))
end
fun isValidInit (T {components, ...},
stores: {offset: int, ty: Type.t} vector): bool =
Vector.length stores = Vector.length components
andalso
Vector.isSorted
(stores, fn ({offset = off, ...}, {offset = off', ...}) =>
off <= off')
andalso
Vector.forall2
(components, stores, fn ({offset = off, ty, ...},
{offset = off', ty = ty'}) =>
off = off' andalso Type.equals (ty, ty'))
end
structure ObjectType =
struct
datatype t =
Array of MemChunk.t
| Normal of MemChunk.t
| Stack
fun layout (t: t) =
let
open Layout
in
case t of
Array mc => seq [str "Array ", MemChunk.layout mc]
| Normal mc => seq [str "Normal ", MemChunk.layout mc]
| Stack => str "Stack"
end
val wordSize = Runtime.wordSize
val stack = Stack
val string =
Array (MemChunk.T {components = Vector.new1 {mutable = true,
offset = 0,
ty = Type.char},
size = 1})
val thread =
let
val components =
Vector.new3 ({mutable = true,
offset = 0,
ty = Type.word},
{mutable = true,
offset = wordSize,
ty = Type.word},
{mutable = true,
offset = 2 * wordSize,
ty = Type.stack})
in
Normal (MemChunk.T {components = components,
size = 3 * wordSize})
end
val wordVector =
Array (MemChunk.T {components = Vector.new1 {mutable = false,
offset = 0,
ty = Type.word},
size = wordSize})
val isOk =
fn Array mc => MemChunk.isOk mc
| Normal mc => MemChunk.isOk mc
| Stack => true
local
structure R = Runtime.ObjectType
in
fun toRuntime t =
case t of
Array m => let
val (b, p) = MemChunk.numBytesAndPointers m
in
R.Array {numBytesNonPointers = b,
numPointers = p}
end
| Normal m => let
val (b, p) = MemChunk.numBytesAndPointers m
val w = Int.quot (b, Runtime.wordSize)
in
R.Normal {numWordsNonPointers = w,
numPointers = p}
end
| Stack => R.Stack
end
val basic =
Vector.fromList
[(PointerTycon.stack, stack),
(PointerTycon.string, string),
(PointerTycon.thread, thread),
(PointerTycon.wordVector, wordVector)]
end
fun castIsOk {from: Type.t,
fromInt: int option,
to: Type.t,
tyconTy: PointerTycon.t -> ObjectType.t}: bool =
let
fun castEnumIsOk ({enum = e, pointers = p},
{enum = e', pointers = p'}): bool =
(* Safe subtyping. *)
(Vector.isSubsequence (e, e', op =)
andalso Vector.isSubsequence (p, p', PointerTycon.equals))
orelse
(* Unsafe Vector_fromArray. *)
(0 = Vector.length e
andalso 0 = Vector.length e'
andalso 1 = Vector.length p
andalso 1 = Vector.length p'
andalso
(case (tyconTy (Vector.sub (p, 0)),
tyconTy (Vector.sub (p', 0))) of
(ObjectType.Array (MemChunk.T {components = cs, size = s}),
ObjectType.Array (MemChunk.T {components = cs', size = s'})) =>
s = s'
andalso
Vector.equals
(cs, cs', fn ({offset = off, ty, ...},
{offset = off', ty = ty', ...}) =>
off = off' andalso Type.equals (ty, ty'))
| _ => false))
orelse
(* Unsafe downcast, but we use it in SwitchEnumPointers
* and SwitchPointer. It should be made properly type safe
* by using dominators or somesuch.
*)
(if 0 = Vector.length e
then (0 = Vector.length e'
andalso 1 = Vector.length p'
andalso
let
val pt = Vector.sub (p', 0)
in
Vector.exists (p, fn pt' =>
PointerTycon.equals (pt, pt'))
end)
else
(e = e' andalso 0 = Vector.length p')
orelse
((MLton.eq (p, p')
orelse Vector.equals (p, p', PointerTycon.equals))
andalso 0 = Vector.length e'))
datatype z = datatype Type.t
in
case from of
CPointer =>
(case to of
Int => true
| Word => true
| _ => false)
| EnumPointers (ep as {enum, pointers}) =>
(case to of
EnumPointers ep' => castEnumIsOk (ep, ep')
| IntInf =>
(* IntInf_fromVector *)
0 = Vector.length enum
andalso 1 = Vector.length pointers
andalso PointerTycon.equals (PointerTycon.wordVector,
Vector.sub (pointers, 0))
| Word => true (* necessary for card marking *)
| _ => false)
| Int =>
(case to of
EnumPointers {enum, ...} =>
(case fromInt of
NONE => false
| SOME int => Vector.exists (enum, fn i => i = int))
orelse
(* MLton_bogus *)
(0 = Vector.length enum
andalso (case fromInt of
SOME 1 => true
| _ => false))
| Word => true (* Word32_fromInt *)
| _ => false)
| IntInf =>
(case to of
EnumPointers {enum, pointers} =>
(* IntInf_toVector *)
0 = Vector.length enum
andalso 1 = Vector.length pointers
andalso PointerTycon.equals (PointerTycon.wordVector,
Vector.sub (pointers, 0))
| Word => true (* IntInf_toWord *)
| _ => false)
| MemChunk _ =>
(case to of
Word => true (* needed for card marking of arrays *)
| _ => false)
| Word =>
(case to of
Int => true (* Word32_toIntX *)
| IntInf => true (* IntInf_fromWord *)
| _ => false)
| _ => false
end
end
1.1 mlton/mlton/backend/machine-atoms.sig
Index: machine-atoms.sig
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* 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 MACHINE_ATOMS_STRUCTS =
sig
structure Label: HASH_ID
structure Prim: PRIM
structure Runtime: RUNTIME
end
signature MACHINE_ATOMS =
sig
include MACHINE_ATOMS_STRUCTS
structure PointerTycon:
sig
type t
val <= : t * t -> bool
val equals: t * t -> bool
val index: t -> int (* index into pointerTypes array *)
val layout: t -> Layout.t
val new: unit -> t
val plist: t -> PropertyList.t
val stack: t
val string: t
val thread: t
val toString: t -> string
val wordVector: t
end
type memChunk
structure Type:
sig
datatype t =
Char
| CPointer
(* The ints in an enum are in increasing order without dups.
* The pointers are in increasing order (of index in pointerTypes
* vector) without dups.
*)
| EnumPointers of {enum: int vector,
pointers: PointerTycon.t vector}
| Int
| IntInf
| Label
| MemChunk of memChunk (* An internal pointer. *)
| Real
| Word
val align: t * int -> int (* align an address *)
val bool: t
val char: t
val containsPointer: t * PointerTycon.t -> bool
val cpointer: t
val dePointer: t -> PointerTycon.t option
val equals: t * t -> bool
val fromRuntime: Runtime.Type.t -> t
val int: t
val intInf: t
val isPointer: t -> bool
val label: t
val layout: t -> Layout.t
val name: t -> string (* simple one letter abbreviation *)
val pointer: PointerTycon.t -> t
val real: t
val size: t -> int
val stack: t
val string: t
val thread: t
val toRuntime: t -> Runtime.Type.t
val toString: t -> string
val word: t
val wordVector: t
end
structure MemChunk:
sig
(* The components are stored in increasing order of offset and are
* non-overlapping.
*)
datatype t =
T of {components: {mutable: bool,
offset: int,
ty: Type.t} vector,
size: int}
val isValidInit: t * {offset: int, ty: Type.t} vector -> bool
end where type t = memChunk
structure ObjectType:
sig
datatype t =
Array of MemChunk.t
| Normal of MemChunk.t
| Stack
val basic: (PointerTycon.t * t) vector
val isOk: t -> bool
val layout: t -> Layout.t
val stack: t
val string: t
val thread: t
val toRuntime: t -> Runtime.ObjectType.t
val wordVector: t
end
val castIsOk: {from: Type.t,
fromInt: int option,
to: Type.t,
tyconTy: PointerTycon.t -> ObjectType.t} -> bool
end
1.1 mlton/mlton/backend/switch.fun
Index: switch.fun
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
functor Switch (S: SWITCH_STRUCTS): SWITCH =
struct
open S
fun isRedundant {cases: 'a vector,
equals: 'a * 'a -> bool}: bool =
let
val nCases = Vector.length cases
in
0 < nCases
andalso let
fun loop (i: int, prev: 'a): bool =
i < nCases
andalso let
val cur = Vector.sub (cases, i)
in
equals (cur, prev)
orelse loop (i + 1, cur)
end
in
loop (1, Vector.sub (cases, 0))
end
end
fun exhaustiveAndIrredundant {all: 'a vector,
cases: 'a vector,
default: 'c option,
equals: 'a * 'a -> bool}: bool =
Vector.isSubsequence (cases, all, equals)
andalso (if Vector.length all = Vector.length cases
then Option.isNone default
else Option.isSome default)
andalso not (isRedundant {cases = cases, equals = equals})
datatype t =
Char of {cases: (char * Label.t) vector,
default: Label.t option,
test: Use.t}
| EnumPointers of {enum: Label.t,
pointers: Label.t,
test: Use.t}
| Int of {cases: (int * Label.t) vector,
default: Label.t option,
test: Use.t}
| Pointer of {cases: {dst: Label.t,
tag: int,
tycon: PointerTycon.t} vector,
default: Label.t option,
tag: Use.t,
test: Use.t} (* of type int*)
| Word of {cases: (word * Label.t) vector,
default: Label.t option,
test: Use.t}
fun layout s =
let
open Layout
fun simple ({cases, default, test}, name, lay) =
seq [str (concat ["switch", name, " "]),
record [("test", Use.layout test),
("default", Option.layout Label.layout default),
("cases",
Vector.layout
(Layout.tuple2 (lay, Label.layout))
cases)]]
in
case s of
Char z => simple (z, "Char", Char.layout)
| EnumPointers {enum, pointers, test} =>
seq [str "SwitchEP ",
record [("test", Use.layout test),
("enum", Label.layout enum),
("pointers", Label.layout pointers)]]
| Int z => simple (z, "Int", Int.layout)
| Pointer {cases, default, tag, test} =>
seq [str "SwitchPointer ",
record [("test", Use.layout test),
("tag", Use.layout tag),
("default", Option.layout Label.layout default),
("cases",
Vector.layout
(fn {dst, tag, tycon} =>
record [("dst", Label.layout dst),
("tag", Int.layout tag),
("tycon", PointerTycon.layout tycon)])
cases)]]
| Word z => simple (z, "Word", Word.layout)
end
val allChars = Vector.tabulate (Char.numChars, Char.fromInt)
fun isOk (s, {labelIsOk}): bool =
case s of
Char {cases, default, test} =>
(Type.equals (Use.ty test, Type.char)
andalso (case default of
NONE => true
| SOME l => labelIsOk l)
andalso Vector.forall (cases, labelIsOk o #2)
andalso Vector.isSorted (cases, fn ((c, _), (c', _)) => c <= c')
andalso exhaustiveAndIrredundant {all = allChars,
cases = Vector.map (cases, #1),
default = default,
equals = op =})
| EnumPointers {enum, pointers, test, ...} =>
labelIsOk enum
andalso labelIsOk pointers
andalso (case Use.ty test of
Type.EnumPointers _ => true
| _ => false)
| Int {cases, default, test} =>
(case default of
NONE => true
| SOME l => labelIsOk l)
andalso Vector.forall (cases, labelIsOk o #2)
andalso Vector.isSorted (cases, fn ((i, _), (i', _)) => i <= i')
andalso
(case Use.ty test of
Type.Int =>
Option.isSome default
andalso not (isRedundant
{cases = cases,
equals = fn ((i, _), (i', _)) => i = i'})
| Type.EnumPointers {enum, pointers} =>
0 = Vector.length pointers
andalso
exhaustiveAndIrredundant
{all = enum,
cases = Vector.map (cases, #1),
default = default,
equals = op =}
| _ => false)
| Pointer {cases, default, tag, test} =>
(Type.equals (Use.ty tag, Type.int)
andalso (case default of
NONE => true
| SOME l => labelIsOk l)
andalso Vector.forall (cases, labelIsOk o #dst)
andalso Vector.isSorted (cases,
fn ({tycon = t, ...}, {tycon = t', ...}) =>
PointerTycon.index t <= PointerTycon.index t')
andalso
case Use.ty test of
Type.EnumPointers {enum, pointers} =>
0 = Vector.length enum
andalso
exhaustiveAndIrredundant {all = pointers,
cases = Vector.map (cases, #tycon),
default = default,
equals = PointerTycon.equals}
| _ => false)
| Word {cases, default, test} =>
Type.equals (Use.ty test, Type.word)
andalso (case default of
NONE => false
| SOME l => labelIsOk l)
andalso Vector.forall (cases, labelIsOk o #2)
andalso Vector.isSorted (cases, fn ((w, _), (w', _)) => w <= w')
andalso
not (isRedundant
{cases = cases,
equals = fn ((w, _), (w', _)) => w = w'})
fun foldLabelUse (s: t, a: 'a, {label, use}): 'a =
let
fun simple {cases, default, test} =
let
val a = use (test, a)
val a = Option.fold (default, a, label)
val a = Vector.fold (cases, a, fn ((_, l), a) =>
label (l, a))
in
a
end
in
case s of
Char z => simple z
| EnumPointers {enum, pointers, test} =>
let
val a = use (test, a)
val a = label (enum, a)
val a = label (pointers, a)
in
a
end
| Int z => simple z
| Pointer {cases, default, tag, test} =>
let
val a = use (tag, a)
val a = use (test, a)
val a = Option.fold (default, a, label)
val a = Vector.fold (cases, a, fn ({dst, ...}, a) =>
label (dst, a))
in
a
end
| Word z => simple z
end
fun foreachLabel (s, f) =
foldLabelUse (s, (), {label = f o #1,
use = fn _ => ()})
end
1.1 mlton/mlton/backend/switch.sig
Index: switch.sig
===================================================================
(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* 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 SWITCH_STRUCTS =
sig
include MACHINE_ATOMS
structure Use: sig
type t
val layout: t -> Layout.t
val ty: t -> Type.t
end
end
signature SWITCH =
sig
include SWITCH_STRUCTS
datatype t =
Char of {(* Cases are in increasing order of char. *)
cases: (char * Label.t) vector,
default: Label.t option,
test: Use.t}
| EnumPointers of {enum: Label.t,
pointers: Label.t,
test: Use.t}
| Int of {(* Cases are in increasing order of int. *)
cases: (int * Label.t) vector,
default: Label.t option,
test: Use.t}
| Pointer of {(* Cases are in increasing order of tycon. *)
cases: {dst: Label.t,
tag: int,
tycon: PointerTycon.t} vector,
default: Label.t option,
tag: Use.t, (* of type int *)
test: Use.t}
| Word of {(* Cases are in increasing order of tycon *)
cases: (word * Label.t) vector,
default: Label.t option,
test: Use.t}
val foldLabelUse: t * 'a * {label: Label.t * 'a -> 'a,
use: Use.t * 'a -> 'a} -> 'a
val foreachLabel: t * (Label.t -> unit) -> unit
val isOk: t * {labelIsOk: Label.t -> bool} -> bool
val layout: t -> Layout.t
end
1.34 +135 -93 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.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- c-codegen.fun 22 Nov 2002 02:48:20 -0000 1.33
+++ c-codegen.fun 7 Dec 2002 02:21:52 -0000 1.34
@@ -14,18 +14,19 @@
open Machine
in
structure Block = Block
- structure Cases = Cases
structure Chunk = Chunk
structure ChunkLabel = ChunkLabel
structure FrameInfo = FrameInfo
structure Global = Global
structure Kind = Kind
structure Label = Label
+ structure ObjectType = ObjectType
structure Operand = Operand
structure Prim = Prim
structure Register = Register
structure Runtime = Runtime
structure Statement = Statement
+ structure Switch = Switch
structure Transfer = Transfer
structure Type = Type
end
@@ -35,7 +36,6 @@
in
structure CFunction = CFunction
structure GCField = GCField
- structure ObjectType = ObjectType
end
structure Kind =
@@ -92,10 +92,10 @@
fun word (w: Word.t) = "0x" ^ Word.toString w
- (* The only difference between SML floats and C floats is that
+ (* The only difference between SML reals and C floats/doubles is that
* SML uses "~" while C uses "-".
*)
- fun float s = String.translate (s, fn #"~" => "-" | c => String.fromChar c)
+ fun real s = String.translate (s, fn #"~" => "-" | c => String.fromChar c)
fun string s =
let val quote = "\""
@@ -126,26 +126,29 @@
fn ArrayOffset {base, index, ty} =>
concat ["X", Type.name ty,
C.args [toString base, toString index]]
- | CastInt oper => concat ["PointerToInt", C.args [toString oper]]
- | CastWord oper => concat ["(word)", C.args [toString oper]]
+ | Cast (z, ty) =>
+ concat ["(", Runtime.Type.toString (Type.toRuntime ty), ")",
+ toString z]
| Char c => C.char c
| Contents {oper, ty} =>
concat ["C", Type.name ty, "(", toString oper, ")"]
| File => "__FILE__"
- | Float s => C.float s
| GCState => "&gcState"
- | Global g => Global.toString g
- | GlobalPointerNonRoot n =>
- concat ["globalpointerNonRoot [", C.int n, "]"]
- | Int n => C.int n
- | IntInf w =>
- concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
+ | Global g =>
+ concat ["G", Type.name (Global.ty g),
+ if Global.isRoot g
+ then ""
+ else "NR",
+ "(", Int.toString (Global.index g), ")"]
+ | Int n => C.int n
| Label l => Label.toStringIndex l
| Line => "__LINE__"
| Offset {base, offset, ty} =>
concat ["O", Type.name ty, C.args [toString base, C.int offset]]
- | Pointer n => concat ["IntAsPointer", C.args [C.int n]]
- | Register r => Register.toString r
+ | Real s => C.real s
+ | Register r =>
+ concat ["R", Type.name (Register.ty r),
+ "(", Int.toString (Register.index r), ")"]
| Runtime r =>
let
datatype z = datatype GCField.t
@@ -164,14 +167,17 @@
| StackLimit => "gcState.stackLimit"
| StackTop => "stackTop"
end
+ | SmallIntInf w =>
+ concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
| StackOffset {offset, ty} =>
concat ["S", Type.name ty, "(", C.int offset, ")"]
- | Uint w => C.word w
+ | Word w => C.word w
val layout = Layout.str o toString
end
-fun creturn (t: Type.t): string = concat ["CReturn", Type.name t]
+fun creturn (t: Runtime.Type.t): string =
+ concat ["CReturn", Runtime.Type.name t]
fun outputDeclarations
{additionalMainArgs: string list,
@@ -180,8 +186,8 @@
name: string,
print: string -> unit,
program = (Machine.Program.T
- {chunks, frameOffsets, floats, globals, globalsNonRoot, intInfs,
- maxFrameSize, objectTypes, strings, ...}),
+ {chunks, frameOffsets, intInfs, maxFrameSize, objectTypes,
+ reals, strings, ...}),
rest: unit -> unit
}: unit =
let
@@ -192,23 +198,11 @@
; print "\n")
fun declareGlobals () =
C.call ("Globals",
- List.map (List.map (let open Type
+ List.map (List.map (let open Runtime.Type
in [char, double, int, pointer, uint]
end,
- globals) @ [globalsNonRoot],
- C.int),
- print)
- fun locals ty =
- List.fold (chunks, 0, fn (Machine.Chunk.T {regMax, ...}, max) =>
- if regMax ty > max
- then regMax ty
- else max)
- fun declareLocals () =
- C.call ("Locals",
- List.map (List.map (let open Type
- in [char, double, int, pointer, uint]
- end,
- locals),
+ Global.numberOfType)
+ @ [Global.numberOfNonRoot ()],
C.int),
print)
fun declareIntInfs () =
@@ -230,15 +224,15 @@
print)
; print "\n"))
; print "EndStrings\n")
- fun declareFloats () =
- (print "BeginFloats\n"
- ; List.foreach (floats, fn (g, f) =>
- (C.callNoSemi ("Float",
+ fun declareReals () =
+ (print "BeginReals\n"
+ ; List.foreach (reals, fn (g, f) =>
+ (C.callNoSemi ("Real",
[C.int (Global.index g),
- C.float f],
+ C.real f],
print)
; print "\n"))
- ; print "EndFloats\n")
+ ; print "EndReals\n")
fun declareFrameOffsets () =
Vector.foreachi
(frameOffsets, fn (i, v) =>
@@ -249,15 +243,16 @@
fun declareObjectTypes () =
(print (concat ["static GC_ObjectType objectTypes[] = {\n"])
; (Vector.foreach
- (objectTypes, fn t =>
+ (objectTypes, fn ty =>
let
+ datatype z = datatype Runtime.ObjectType.t
val (tag, nonPointers, pointers) =
- case t of
- ObjectType.Array {numBytesNonPointers, numPointers} =>
+ case ObjectType.toRuntime ty of
+ Array {numBytesNonPointers, numPointers} =>
(0, numBytesNonPointers, numPointers)
- | ObjectType.Normal {numPointers, numWordsNonPointers} =>
+ | Normal {numPointers, numWordsNonPointers} =>
(1, numWordsNonPointers, numPointers)
- | ObjectType.Stack =>
+ | Stack =>
(2, 0, 0)
in
print (concat ["\t{ ", Int.toString tag, ", ",
@@ -283,10 +278,9 @@
print (concat ["#define ", name, "CODEGEN\n\n"])
; outputIncludes ()
; declareGlobals ()
- ; declareLocals ()
; declareIntInfs ()
; declareStrings ()
- ; declareFloats ()
+ ; declareReals ()
; declareFrameOffsets ()
; declareObjectTypes ()
; rest ()
@@ -294,9 +288,7 @@
end
fun output {program as Machine.Program.T {chunks,
- frameOffsets,
- main = {chunkLabel, label},
- objectTypes, ...},
+ main = {chunkLabel, label}, ...},
includes,
outputC: unit -> {file: File.t,
print: string -> unit,
@@ -443,7 +435,7 @@
C.call ("SetSlotExnStack", [C.int offset], print)
))
end
- fun outputChunk (Chunk.T {chunkLabel, blocks, regMax, ...}) =
+ fun outputChunk (chunk as Chunk.T {chunkLabel, blocks, ...}) =
let
fun labelFrameSize (l: Label.t): int =
FrameInfo.size (valOf (labelFrameInfo l))
@@ -477,11 +469,7 @@
| Goto dst => jump dst
| Raise => ()
| Return _ => ()
- | Switch {cases, default, ...} =>
- (Cases.foreach (cases, jump)
- ; Option.app (default, jump))
- | SwitchIP {int, pointer, ...} =>
- (jump int; jump pointer)
+ | Switch s => Switch.foreachLabel (s, jump)
end)
fun push (return: Label.t, size: int) =
(C.push (size, print)
@@ -509,10 +497,13 @@
concat ["tmp",
Int.toString (Counter.next c)]
val _ =
- print (concat ["\t", Type.toString ty,
- " ", tmp,
- " = ", Operand.toString z,
- ";\n"])
+ print (concat
+ ["\t",
+ Runtime.Type.toString
+ (Type.toRuntime ty),
+ " ", tmp,
+ " = ", Operand.toString z,
+ ";\n"])
in
tmp
end
@@ -570,8 +561,10 @@
else ()
; (Option.app
(dst, fn x =>
- print (concat ["\t", Operand.toString x, " = ",
- creturn (Operand.ty x), ";\n"]))))
+ print (concat
+ ["\t", Operand.toString x, " = ",
+ creturn (Type.toRuntime (Operand.ty x)),
+ ";\n"]))))
| Kind.Func _ => ()
| Kind.Handler {offset} => C.push (~offset, print)
| Kind.Jump => ()
@@ -732,56 +725,105 @@
| Goto dst => gotoLabel dst
| Raise => C.call ("\tRaise", [], print)
| Return _ => C.call ("\tReturn", [], print)
- | Switch {test, cases, default} =>
+ | Switch switch =>
let
- val test = Operand.toString test
- fun bool (t, f) = iff (test, t, f)
- fun doit (cases, f) =
+ fun bool (test: Operand.t, t, f) =
+ iff (Operand.toString test, t, f)
+ fun doit {cases: (string * Label.t) vector,
+ default: Label.t option,
+ test: Operand.t}: unit =
let
- fun switch (cases, l) =
+ val test = Operand.toString test
+ fun switch (cases: (string * Label.t) vector,
+ default: Label.t): unit =
(print "switch ("
; print test
; print ") {\n"
- ; (List.foreach
+ ; (Vector.foreach
(cases, fn (n, l) => (print "case "
- ; print (f n)
+ ; print n
; print ":\n"
; gotoLabel l)))
; print "default:\n"
- ; gotoLabel l
+ ; gotoLabel default
; print "}\n")
in
- case (cases, default) of
- ([], NONE) =>
+ case (Vector.length cases, default) of
+ (0, NONE) =>
Error.bug "switch: empty cases"
- | ([(_, l)], NONE) => gotoLabel l
- | ([], SOME l) => gotoLabel l
- | ((_, l) :: cases', NONE) => switch (cases', l)
- | (_, SOME l) => switch (cases, l)
+ | (0, SOME l) => gotoLabel l
+ | (1, NONE) =>
+ gotoLabel (#2 (Vector.sub (cases, 0)))
+ | (_, NONE) =>
+ switch (Vector.dropPrefix (cases, 1),
+ #2 (Vector.sub (cases, 0)))
+ | (_, SOME l) => switch (cases, l)
end
+ fun simple ({cases, default, test}, f) =
+ doit {cases = Vector.map (cases, fn (c, l) =>
+ (f c, l)),
+ default = default,
+ test = test}
+ datatype z = datatype Switch.t
in
- case cases of
- Cases.Char l => doit (l, C.char)
- | Cases.Int l =>
- (case (l, default) of
- ([(0, f), (1, t)], NONE) => bool (t, f)
- | ([(1, t), (0, f)], NONE) => bool (t, f)
- | _ => doit (l, C.int))
- | Cases.Word l => doit (l, C.word)
+ case switch of
+ Char z => simple (z, C.char)
+ | EnumPointers {enum, pointers, test} =>
+ iff (concat
+ ["IsInt (", Operand.toString test, ")"],
+ enum, pointers)
+ | Int (z as {cases, default, test}) =>
+ let
+ fun normal () = simple (z, C.int)
+ in
+ if 2 = Vector.length cases
+ then
+ let
+ val c0 = Vector.sub (cases, 0)
+ val c1 = Vector.sub (cases, 1)
+ in
+ case (c0, c1, default) of
+ ((0, f), (1, t), NONE) =>
+ bool (test, t, f)
+ | ((1, t), (0, f), NONE) =>
+ bool (test, t, f)
+ | _ => normal ()
+ end
+ else normal ()
+ end
+ | Pointer {cases, default, tag, ...} =>
+ doit {cases = (Vector.map
+ (cases, fn {dst, tag, ...} =>
+ (Int.toString tag, dst))),
+ default = default,
+ test = tag}
+ | Word z => simple (z, C.word)
end
- | SwitchIP {test, int, pointer} =>
- iff (concat ["IsInt (", Operand.toString test, ")"],
- int, pointer)
+ end
+ fun declareRegisters () =
+ let
+ val {get = seen, rem, set = setSeen} =
+ Property.getSetOnce (Register.plist,
+ Property.initConst false)
+ val all =
+ Chunk.foldRegs
+ (chunk, [], fn (r, ac) =>
+ if seen r
+ then ac
+ else (setSeen (r, true)
+ ; r :: ac))
+ in
+ List.foreach
+ (all, fn r =>
+ (rem r
+ ; C.call (concat ["D", Type.name (Register.ty r)],
+ [C.int (Register.index r)],
+ print)))
end
in
C.callNoSemi ("Chunk", [ChunkLabel.toString chunkLabel], print)
+ ; declareRegisters ()
; print "\n"
- (* Declare registers. *)
- ; List.foreach (Type.all, fn ty =>
- Int.for (0, regMax ty,
- fn i => C.call (concat ["D", Type.name ty],
- [C.int i],
- print)))
; print "ChunkSwitch\n"
; Vector.foreach (blocks, fn Block.T {kind, label, ...} =>
if Kind.isEntry kind
1.30 +45 -15 mlton/mlton/codegen/x86-codegen/x86-codegen.fun
Index: x86-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- x86-codegen.fun 2 Nov 2002 03:37:40 -0000 1.29
+++ x86-codegen.fun 7 Dec 2002 02:21:53 -0000 1.30
@@ -78,20 +78,16 @@
open x86
structure Type = Machine.Type
- fun output {program as Machine.Program.T
- {chunks,
- floats,
- frameOffsets,
- globals,
- globalsNonRoot,
- handlesSignals,
- intInfs,
- main,
- maxFrameSize,
- profileAllocLabels,
- strings,
- ...}: Machine.Program.t,
- includes: string list,
+ fun output {program as Machine.Program.T {chunks,
+ frameOffsets,
+ handlesSignals,
+ intInfs,
+ main,
+ maxFrameSize,
+ profileAllocLabels,
+ strings,
+ ...},
+ includes: string list,
outputC,
outputS}: unit
= let
@@ -269,8 +265,42 @@
if reserveEsp then C.truee else C.falsee,
a1, a2, a3]
end
+ fun declareLocals () =
+ let
+ val tyMax = Runtime.Type.memo (fn _ => ref 0)
+ val {get = seen, rem, set = setSeen} =
+ Property.getSetOnce (Machine.Register.plist,
+ Property.initConst false)
+ val all =
+ Machine.Program.foldRegs
+ (program, [], fn (r, ac) =>
+ if seen r
+ then ac
+ else let
+ val _ = setSeen (r, true)
+ val m = tyMax (Machine.Type.toRuntime
+ (Machine.Register.ty r))
+ val n = Machine.Register.index r
+ val _ =
+ if n > !m
+ then m := n
+ else ()
+ in
+ r :: ac
+ end)
+ val _ = List.foreach (all, rem)
+ in
+ print
+ (concat ["Locals",
+ Layout.toString
+ (Layout.tuple (List.map
+ (Runtime.Type.all, fn t =>
+ Int.layout (! (tyMax t))))),
+ ";\n"])
+ end
fun rest () =
- (declareFrameLayouts()
+ (declareLocals ()
+ ; declareFrameLayouts ()
; print "extern uint profileAllocLabels;\n")
in
CCodegen.outputDeclarations
1.8 +7 -7 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun
Index: x86-mlton-basic.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- x86-mlton-basic.fun 2 Nov 2002 03:37:40 -0000 1.7
+++ x86-mlton-basic.fun 7 Dec 2002 02:21:53 -0000 1.8
@@ -29,7 +29,7 @@
val intInfOverheadBytes = Runtime.intInfOverheadSize
local
- open Machine.Type
+ datatype z = datatype Runtime.Type.dest
in
fun toX86Size' t
= case t
@@ -38,7 +38,7 @@
| Int => x86.Size.LONG
| Pointer => x86.Size.LONG
| Uint => x86.Size.LONG
- val toX86Size = fn t => toX86Size' (dest t)
+ val toX86Size = fn t => toX86Size' (Runtime.Type.dest t)
fun toX86Scale' t
= case t
of Char => x86.Scale.One
@@ -46,7 +46,7 @@
| Int => x86.Scale.Four
| Pointer => x86.Scale.Four
| Uint => x86.Scale.Four
- val toX86Scale = fn t => toX86Scale' (dest t)
+ val toX86Scale = fn t => toX86Scale' (Runtime.Type.dest t)
end
(*
@@ -242,15 +242,15 @@
= Operand.memloc fpswTempContents
local
- open Machine.Type
val localC_base = Label.fromString "localuchar"
val localD_base = Label.fromString "localdouble"
val localI_base = Label.fromString "localint"
val localP_base = Label.fromString "localpointer"
val localU_base = Label.fromString "localuint"
+ datatype z = datatype Runtime.Type.dest
in
fun local_base ty
- = case dest ty
+ = case Runtime.Type.dest ty
of Char => localC_base
| Double => localD_base
| Int => localI_base
@@ -259,7 +259,6 @@
end
local
- open Machine.Type
val globalC_base = Label.fromString "globaluchar"
val globalC_num = Label.fromString "num_globaluchar"
val globalD_base = Label.fromString "globaldouble"
@@ -270,9 +269,10 @@
val globalP_num = Label.fromString "num_globalpointer"
val globalU_base = Label.fromString "globaluint"
val globalU_num = Label.fromString "num_globaluint"
+ datatype z = datatype Runtime.Type.dest
in
fun global_base ty
- = case dest ty
+ = case Runtime.Type.dest ty
of Char => globalC_base
| Double => globalD_base
| Int => globalI_base
1.17 +4 -4 mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig
Index: x86-mlton-basic.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton-basic.sig,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- x86-mlton-basic.sig 2 Nov 2002 03:37:40 -0000 1.16
+++ x86-mlton-basic.sig 7 Dec 2002 02:21:53 -0000 1.17
@@ -35,8 +35,8 @@
val arrayHeaderBytes : int
val intInfOverheadBytes : int
- val toX86Size : Machine.Type.t -> x86.Size.t
- val toX86Scale : Machine.Type.t -> x86.Scale.t
+ val toX86Size : x86.Runtime.Type.t -> x86.Size.t
+ val toX86Scale : x86.Runtime.Type.t -> x86.Scale.t
(*
* Memory classes
@@ -86,8 +86,8 @@
val statusTempContentsOperand : x86.Operand.t
(* Static arrays defined in x86codegen.h *)
- val local_base : Machine.Type.t -> x86.Label.t
- val global_base : Machine.Type.t -> x86.Label.t
+ val local_base : x86.Runtime.Type.t -> x86.Label.t
+ val global_base : x86.Runtime.Type.t -> x86.Label.t
val globalPointerNonRoot_base : x86.Label.t
(* Static functions defined in x86codegen.h *)
1.38 +1 -11 mlton/mlton/codegen/x86-codegen/x86-mlton.fun
Index: x86-mlton.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-mlton.fun,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- x86-mlton.fun 24 Nov 2002 01:19:43 -0000 1.37
+++ x86-mlton.fun 7 Dec 2002 02:21:53 -0000 1.38
@@ -710,9 +710,7 @@
[comment_begin,
(case Prim.name prim of
Array_length => lengthArrayVectorString ()
- | Byte_byteToChar => mov ()
- | Byte_charToByte => mov ()
- | C_CS_charArrayToWord8Array => mov ()
+
| Char_lt => cmp Instruction.B
| Char_le => cmp Instruction.BE
| Char_gt => cmp Instruction.A
@@ -783,10 +781,6 @@
| Int_ge => cmp Instruction.GE
| Int_gtu => cmp Instruction.A
| Int_geu => cmp Instruction.AE
- | IntInf_fromVector => mov ()
- | IntInf_toVector => mov ()
- | IntInf_fromWord => mov ()
- | IntInf_toWord => mov ()
| MLton_eq => cmp Instruction.E
| MLton_serialize => unimplemented primName
| MLton_deserialize => unimplemented primName
@@ -1303,8 +1297,6 @@
end
| Real_neg => funa Instruction.FCHS
| Real_round => funa Instruction.FRNDINT
- | String_fromWord8Vector => mov ()
- | String_toWord8Vector => mov ()
| Vector_length => lengthArrayVectorString ()
| Word8_toInt => movx Instruction.MOVZX
| Word8_toIntX => movx Instruction.MOVSX
@@ -1334,8 +1326,6 @@
| Word8Array_subWord => subWord8ArrayVector ()
| Word8Array_updateWord => updateWord8Array ()
| Word8Vector_subWord => subWord8ArrayVector ()
- | Word32_toIntX => mov ()
- | Word32_fromInt => mov ()
| Word32_add => binal Instruction.ADD
| Word32_sub => binal Instruction.SUB
| Word32_andb => binal Instruction.AND
1.31 +208 -240 mlton/mlton/codegen/x86-codegen/x86-translate.fun
Index: x86-translate.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-translate.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- x86-translate.fun 4 Nov 2002 15:08:11 -0000 1.30
+++ x86-translate.fun 7 Dec 2002 02:21:53 -0000 1.31
@@ -28,213 +28,182 @@
structure Prim = Machine.Prim
structure Runtime = Machine.Runtime
- structure Type =
- struct
- open Machine.Type
- fun name t = case dest t
- of Char => "C"
- | Double => "D"
- | Int => "I"
- | Pointer => "P"
- | Uint => "U"
- end
+ structure Type = Machine.Type
structure Local =
- struct
- open Machine.Register
-
- fun toX86MemLoc (T{index, ty})
- = let
- val base
- = x86.Immediate.label (x86MLton.local_base ty)
- in
- x86.MemLoc.imm {base = base,
- index = x86.Immediate.const_int index,
- scale = x86MLton.toX86Scale ty,
- size = x86MLton.toX86Size ty,
- class = x86MLton.Classes.Locals}
- end
+ struct
+ open Machine.Register
- fun eq(T{index = index1, ty = ty1},T{index = index2, ty = ty2})
- = Type.equals(ty1, ty2)
- andalso index1 = index2
+ fun toX86MemLoc (r: t) =
+ let
+ val ty = Machine.Type.toRuntime (ty r)
+ val base = x86.Immediate.label (x86MLton.local_base ty)
+ in
+ x86.MemLoc.imm {base = base,
+ index = x86.Immediate.const_int (index r),
+ scale = x86MLton.toX86Scale ty,
+ size = x86MLton.toX86Size ty,
+ class = x86MLton.Classes.Locals}
+ end
- val toString = Layout.toString o layout
- end
+ val eq = equals
+ end
structure Global =
- struct
- open Machine.Global
+ struct
+ open Machine.Global
- fun toX86MemLoc (T{index, ty})
- = let
- val base
- = x86.Immediate.label (x86MLton.global_base ty)
- in
- x86.MemLoc.imm {base = base,
- index = x86.Immediate.const_int index,
- scale = x86MLton.toX86Scale ty,
- size = x86MLton.toX86Size ty,
- class = x86MLton.Classes.Globals}
- end
+ fun toX86MemLoc (g: t) =
+ let
+ val ty = Machine.Type.toRuntime (ty g)
+ val base =
+ x86.Immediate.label
+ (if isRoot g
+ then x86MLton.global_base ty
+ else x86MLton.globalPointerNonRoot_base)
+ in
+ x86.MemLoc.imm {base = base,
+ index = x86.Immediate.const_int (index g),
+ scale = x86MLton.toX86Scale ty,
+ size = x86MLton.toX86Size ty,
+ class = x86MLton.Classes.Globals}
+ end
- val toString = Layout.toString o layout
- end
+ val toString = Layout.toString o layout
+ end
structure Operand =
struct
open Machine.Operand
- val toX86Size = x86MLton.toX86Size o ty
+ val toX86Size = x86MLton.toX86Size o Type.toRuntime o ty
- val rec toX86Operand
- = fn Char c
- => x86.Operand.immediate_const_char c
- | Int i
- => x86.Operand.immediate_const_int i
- | Uint w
- => x86.Operand.immediate_const_word w
- | IntInf ii
- => x86.Operand.immediate_const_word ii
- | File => x86MLton.fileName
- | Float f
- => Error.bug "toX86Operand: Float, unimplemented"
- | GCState => x86.Operand.label x86MLton.gcState_label
- | Pointer i
- => x86.Operand.immediate_const_int i
- | Label l
- => x86.Operand.immediate_label l
- | Line => x86MLton.fileLine ()
- | CastInt p
- => toX86Operand p
- | CastWord p
- => toX86Operand p
- | Register l
- => x86.Operand.memloc (Local.toX86MemLoc l)
- | Global g
- => x86.Operand.memloc (Global.toX86MemLoc g)
- | GlobalPointerNonRoot i
- => let
- val base
- = x86.Immediate.label (x86MLton.globalPointerNonRoot_base)
- val memloc
- = x86.MemLoc.imm
- {base = base,
- index = x86.Immediate.const_int i,
- scale = x86MLton.pointerScale,
- size = x86MLton.pointerSize,
- class = x86MLton.Classes.Globals}
- in
- x86.Operand.memloc memloc
- end
- | Runtime oper
- => let
- datatype z = datatype Machine.Runtime.GCField.t
- open x86MLton
- in
- case oper of
- CanHandle => gcState_canHandleContentsOperand ()
- | CardMap => gcState_cardMapContentsOperand ()
- | CurrentThread => gcState_currentThreadContentsOperand ()
- | Frontier => gcState_frontierContentsOperand ()
- | Limit => gcState_limitContentsOperand ()
- | LimitPlusSlop => gcState_limitPlusSlopContentsOperand ()
- | MaxFrameSize => gcState_maxFrameSizeContentsOperand ()
- | ProfileAllocIndex => gcState_profileAllocIndexContentsOperand ()
- | SignalIsPending => gcState_signalIsPendingContentsOperand ()
- | StackBottom => gcState_stackBottomContentsOperand ()
- | StackLimit => gcState_stackLimitContentsOperand ()
- | StackTop => gcState_stackTopContentsOperand ()
- end
- | StackOffset {offset, ty}
- => let
- val memloc
- = x86.MemLoc.simple
- {base = x86MLton.gcState_stackTopContents (),
- index = x86.Immediate.const_int offset,
- scale = x86.Scale.One,
- size = x86MLton.toX86Size ty,
- class = x86MLton.Classes.Stack}
- in
- x86.Operand.memloc memloc
- end
- | Offset {base, offset, ty}
- => let
- val base = toX86Operand base
- val memloc
- = case x86.Operand.deMemloc base
- of SOME base
- => x86.MemLoc.simple
+ val rec toX86Operand =
+ fn ArrayOffset {base, index, ty} =>
+ let
+ val base = toX86Operand base
+ val index = toX86Operand index
+ val ty = Type.toRuntime ty
+ val memloc =
+ case (x86.Operand.deMemloc base,
+ x86.Operand.deImmediate index,
+ x86.Operand.deMemloc index) of
+ (SOME base, SOME index, _) =>
+ x86.MemLoc.simple
{base = base,
- index = x86.Immediate.const_int offset,
- scale = x86.Scale.One,
+ index = index,
+ scale = x86MLton.toX86Scale ty,
size = x86MLton.toX86Size ty,
class = x86MLton.Classes.Heap}
- | _
- => Error.bug ("toX86Operand: strange Offset:" ^
- " base: " ^
- (x86.Operand.toString base))
- in
- x86.Operand.memloc memloc
- end
- | ArrayOffset {base, index, ty}
- => let
- val base = toX86Operand base
- val index = toX86Operand index
-
- val memloc
- = case (x86.Operand.deMemloc base,
- x86.Operand.deImmediate index,
- x86.Operand.deMemloc index)
- of (SOME base, SOME index, _)
- => x86.MemLoc.simple
+ | (SOME base, _, SOME index) =>
+ x86.MemLoc.complex
{base = base,
index = index,
scale = x86MLton.toX86Scale ty,
size = x86MLton.toX86Size ty,
class = x86MLton.Classes.Heap}
- | (SOME base, _, SOME index)
- => x86.MemLoc.complex
+ | _ => Error.bug (concat ["toX86Operand: strange Offset:",
+ " base: ",
+ x86.Operand.toString base,
+ " index: ",
+ x86.Operand.toString index])
+ in
+ x86.Operand.memloc memloc
+ end
+ | Cast (z, _) => toX86Operand z
+ | Char c => x86.Operand.immediate_const_char c
+ | Contents {oper, ty} =>
+ let
+ val ty = Type.toRuntime ty
+ val base = toX86Operand oper
+ val offset = x86.Immediate.const_int 0
+ val size = x86MLton.toX86Size ty
+ val memloc =
+ case x86.Operand.deMemloc base of
+ SOME base =>
+ x86.MemLoc.simple
{base = base,
- index = index,
- scale = x86MLton.toX86Scale ty,
+ index = x86.Immediate.const_int 0,
+ scale = x86.Scale.One,
size = x86MLton.toX86Size ty,
class = x86MLton.Classes.Heap}
- | _
- => Error.bug ("toX86Operand: strange Offset:" ^
- " base: " ^
- (x86.Operand.toString base) ^
- " index: " ^
- (x86.Operand.toString index))
- in
- x86.Operand.memloc memloc
- end
- | Contents {oper, ty}
- => let
- val base = toX86Operand oper
- val offset = x86.Immediate.const_int 0
- val size = x86MLton.toX86Size ty
-
- val memloc
- = case x86.Operand.deMemloc base
- of SOME base
- => x86.MemLoc.simple
- {base = base,
- index = x86.Immediate.const_int 0,
- scale = x86.Scale.One,
- size = x86MLton.toX86Size ty,
- class = x86MLton.Classes.Heap}
- | _
- => Error.bug ("toX86Operand: strange Contents" ^
- " base: " ^
- (x86.Operand.toString base))
- in
- x86.Operand.memloc memloc
- end
- val toX86Operand
- = fn operand => (toX86Operand operand)
- handle exn
- => Error.reraise (exn, "x86Translate.Operand.toX86Operand")
+ | _ => Error.bug (concat
+ ["toX86Operand: strange Contents",
+ " base: ",
+ x86.Operand.toString base])
+ in
+ x86.Operand.memloc memloc
+ end
+ | File => x86MLton.fileName
+ | GCState => x86.Operand.label x86MLton.gcState_label
+ | Global g => x86.Operand.memloc (Global.toX86MemLoc g)
+ | Int i => x86.Operand.immediate_const_int i
+ | Label l => x86.Operand.immediate_label l
+ | Line => x86MLton.fileLine ()
+ | Offset {base, offset, ty} =>
+ let
+ val base = toX86Operand base
+ val ty = Type.toRuntime ty
+ val memloc =
+ case x86.Operand.deMemloc base of
+ SOME base =>
+ x86.MemLoc.simple
+ {base = base,
+ index = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = x86MLton.toX86Size ty,
+ class = x86MLton.Classes.Heap}
+ | _ => Error.bug (concat ["toX86Operand: strange Offset:",
+ " base: ",
+ x86.Operand.toString base])
+ in
+ x86.Operand.memloc memloc
+ end
+ | Real _ => Error.bug "toX86Operand: Real unimplemented"
+ | Register l => x86.Operand.memloc (Local.toX86MemLoc l)
+ | Runtime oper =>
+ let
+ datatype z = datatype Machine.Runtime.GCField.t
+ open x86MLton
+ in
+ case oper of
+ CanHandle => gcState_canHandleContentsOperand ()
+ | CardMap => gcState_cardMapContentsOperand ()
+ | CurrentThread => gcState_currentThreadContentsOperand ()
+ | Frontier => gcState_frontierContentsOperand ()
+ | Limit => gcState_limitContentsOperand ()
+ | LimitPlusSlop => gcState_limitPlusSlopContentsOperand ()
+ | MaxFrameSize => gcState_maxFrameSizeContentsOperand ()
+ | ProfileAllocIndex =>
+ gcState_profileAllocIndexContentsOperand ()
+ | SignalIsPending =>
+ gcState_signalIsPendingContentsOperand ()
+ | StackBottom => gcState_stackBottomContentsOperand ()
+ | StackLimit => gcState_stackLimitContentsOperand ()
+ | StackTop => gcState_stackTopContentsOperand ()
+ end
+ | SmallIntInf ii => x86.Operand.immediate_const_word ii
+ | StackOffset {offset, ty} =>
+ let
+ val ty = Type.toRuntime ty
+ val memloc =
+ x86.MemLoc.simple
+ {base = x86MLton.gcState_stackTopContents (),
+ index = x86.Immediate.const_int offset,
+ scale = x86.Scale.One,
+ size = x86MLton.toX86Size ty,
+ class = x86MLton.Classes.Stack}
+ in
+ x86.Operand.memloc memloc
+ end
+ | Word w => x86.Operand.immediate_const_word w
+
+ val toX86Operand =
+ fn operand =>
+ toX86Operand operand
+ handle exn => Error.reraise (exn, "x86Translate.Operand.toX86Operand")
+
+ fun convert x = (toX86Operand x, toX86Size x)
end
type transInfo = x86MLton.transInfo
@@ -320,11 +289,8 @@
transfer = NONE})
end
| Kind.CReturn {dst, frameInfo, func}
- => let
- fun convert x
- = (Operand.toX86Operand x,
- x86MLton.toX86Size (Operand.ty x))
- val dst = Option.map (dst, convert)
+ => let
+ val dst = Option.map (dst, Operand.convert)
in
x86MLton.creturn
{dst = dst,
@@ -408,15 +374,9 @@
end
| PrimApp {dst, prim, args}
=> let
- val (comment_begin,
- comment_end) = comments statement
- fun convert x
- = (Operand.toX86Operand x,
- x86MLton.toX86Size (Operand.ty x))
-
- val args = Vector.map(args, convert)
-
- val dst = Option.map(dst, convert)
+ val (comment_begin, comment_end) = comments statement
+ val args = Vector.map (args, Operand.convert)
+ val dst = Option.map (dst, Operand.convert)
in
AppendList.appends
[comment_begin,
@@ -563,7 +523,9 @@
fun stores_toX86Assembly ({offset, value}, l)
= let
- val size = x86MLton.toX86Size (Operand.ty value)
+ val size =
+ x86MLton.toX86Size
+ (Type.toRuntime (Operand.ty value))
val value = Operand.toX86Operand value
val dst
= let
@@ -781,15 +743,13 @@
end
else AppendList.empty
+
fun toX86Blocks {transfer, transInfo as {...} : transInfo}
= (case transfer
of Arith {prim, args, dst, overflow, success, ty}
=> let
- fun convert x
- = (Operand.toX86Operand x,
- x86MLton.toX86Size (Operand.ty x))
- val args = Vector.map(args, convert)
- val dst = convert dst
+ val args = Vector.map (args, Operand.convert)
+ val dst = Operand.convert dst
in
AppendList.append
(comments transfer,
@@ -802,10 +762,7 @@
end
| CCall {args, frameInfo, func, return}
=> let
- fun convert x
- = (Operand.toX86Operand x,
- x86MLton.toX86Size (Operand.ty x))
- val args = Vector.map (args, convert)
+ val args = Vector.map (args, Operand.convert)
in
AppendList.append
(comments transfer,
@@ -855,40 +812,51 @@
(x86.MemLocSet.empty,
x86MLton.gcState_stackBottomContents ()),
x86MLton.gcState_currentThread_exnStackContents ())})}))
- | Switch {test, cases, default}
- => AppendList.append
- (comments transfer,
- (case cases
- of Machine.Cases.Char cases
- => doSwitchChar (test,cases,default)
- | Machine.Cases.Int cases
- => doSwitchInt (test,cases,default)
- | Machine.Cases.Word cases
- => doSwitchWord (test,cases,default)))
- | SwitchIP {test, int, pointer}
- => let
- val size = Operand.toX86Size test
- val test = Operand.toX86Operand test
- in
- AppendList.append
- (comments transfer,
- AppendList.single
- ((* if (test & 0x3) goto int
- * goto pointer
- *)
- x86.Block.T'
- {entry = NONE,
- profileInfo = x86.ProfileInfo.none,
- statements
- = [x86.Assembly.instruction_test
- {src1 = test,
- src2 = x86.Operand.immediate_const_word 0wx3,
- size = size}],
- transfer
- = SOME (x86.Transfer.iff
- {condition = x86.Instruction.NZ,
- truee = int,
- falsee = pointer})}))
+ | Switch switch
+ => let
+ datatype z = datatype Machine.Switch.t
+ fun simple ({cases, default, test}, doSwitch) =
+ AppendList.append
+ (comments transfer,
+ doSwitch (test, Vector.toList cases, default))
+
+ in
+ case switch of
+ Char z => simple (z, doSwitchChar)
+ | EnumPointers {enum, pointers, test} =>
+ let
+ val size = Operand.toX86Size test
+ val test = Operand.toX86Operand test
+ in
+ AppendList.append
+ (comments transfer,
+ AppendList.single
+ ((* if (test & 0x3) goto int
+ * goto pointer
+ *)
+ x86.Block.T'
+ {entry = NONE,
+ profileInfo = x86.ProfileInfo.none,
+ statements
+ = [x86.Assembly.instruction_test
+ {src1 = test,
+ src2 = x86.Operand.immediate_const_word 0wx3,
+ size = size}],
+ transfer
+ = SOME (x86.Transfer.iff
+ {condition = x86.Instruction.NZ,
+ truee = enum,
+ falsee = pointers})}))
+ end
+ | Int z => simple (z, doSwitchInt)
+ | Pointer {cases, default, tag, ...} =>
+ simple ({cases = (Vector.map
+ (cases, fn {dst, tag, ...} =>
+ (tag, dst))),
+ default = default,
+ test = tag},
+ doSwitchInt)
+ | Word z => simple (z, doSwitchWord)
end
| Goto label
=> (AppendList.append
1.22 +1 -1 mlton/mlton/codegen/x86-codegen/x86.sig
Index: x86.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86.sig 2 Nov 2002 03:37:40 -0000 1.21
+++ x86.sig 7 Dec 2002 02:21:53 -0000 1.22
@@ -10,7 +10,7 @@
signature X86_STRUCTS =
sig
- structure Label : HASH_ID
+ structure Label: HASH_ID
structure Runtime: RUNTIME
end
1.57 +3 -0 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- control.sig 24 Nov 2002 01:19:43 -0000 1.56
+++ control.sig 7 Dec 2002 02:21:53 -0000 1.57
@@ -88,6 +88,9 @@
(* call count instrumentation *)
val instrument: bool ref
+ (* Save the RSSA to a file. *)
+ val keepRSSA: bool ref
+
(* Save the SSA to a file. *)
val keepSSA: bool ref
1.73 +5 -1 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -r1.72 -r1.73
--- control.sml 24 Nov 2002 23:15:10 -0000 1.72
+++ control.sml 7 Dec 2002 02:21:53 -0000 1.73
@@ -182,7 +182,11 @@
default = false,
toString = Bool.toString}
-val keepSSA = control {name = "keepSSA",
+val keepRSSA = control {name = "keep RSSA",
+ default = false,
+ toString = Bool.toString}
+
+val keepSSA = control {name = "keep SSA",
default = false,
toString = Bool.toString}
1.9 +10 -11 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- elaborate-env.fun 24 Nov 2002 01:19:44 -0000 1.8
+++ elaborate-env.fun 7 Dec 2002 02:21:53 -0000 1.9
@@ -543,11 +543,10 @@
handleVal = handleVal})
fun doit (elts, less) =
Info.T
- (Array.fromList
- (MergeSort.sort
- (!elts,
- fn ({values = v, ...}, {values = v', ...}) =>
- less (Values.domain v, Values.domain v'))))
+ (QuickSort.sortArray
+ (Array.fromList (!elts),
+ fn ({values = v, ...}, {values = v', ...}) =>
+ less (Values.domain v, Values.domain v')))
in
T {shapeId = SOME shapeId',
strs = doit (strs, Ast.Strid.<=),
@@ -621,10 +620,10 @@
end)
val _ = current := old
val a =
- Array.fromList
- (MergeSort.sort
- (elts, fn ({values = v, ...}, {values = v', ...}) =>
- le (Values.domain v, Values.domain v')))
+ QuickSort.sortArray
+ (Array.fromList elts,
+ fn ({values = v, ...}, {values = v', ...}) =>
+ le (Values.domain v, Values.domain v'))
in
Structure.Info.T a
end
@@ -747,7 +746,7 @@
case !ranges of
[] => ac
| {value, ...} :: _ => (domain, value) :: ac)
- in align (List.map (MergeSort.sort
+ in align (List.map (QuickSort.sortList
(l, fn ((d, _), (d', _)) => le (d, d')),
layout))
end
@@ -777,7 +776,7 @@
else ac)
in
align (List.map
- (MergeSort.sort
+ (QuickSort.sortList
(all, fn ((d, _), (d', _)) => le (d, d')),
#2))
end
1.40 +12 -14 mlton/mlton/main/compile.sml
Index: compile.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.sml,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- compile.sml 25 Nov 2002 15:13:47 -0000 1.39
+++ compile.sml 7 Dec 2002 02:21:53 -0000 1.40
@@ -19,10 +19,13 @@
structure Xml = Xml (open Atoms)
structure Sxml = Xml
structure Ssa = Ssa (open Atoms)
-structure Runtime = Runtime ()
structure Machine = Machine (structure Label = Ssa.Label
- structure Prim = Atoms.Prim
- structure Runtime = Runtime)
+ structure Prim = Atoms.Prim)
+local
+ open Machine
+in
+ structure Runtime = Runtime
+end
(*---------------------------------------------------*)
(* Compiler Passes *)
@@ -436,17 +439,12 @@
display = Control.Layouts Ssa.Program.layouts,
simplify = Ssa.simplify}
val _ =
- let open Control
- in if !keepSSA
- then
- File.withOut
- (concat [!inputFile, ".ssa"], fn out =>
- let
- fun disp l = Layout.outputl (l, out)
- in
- outputHeader (No, disp)
- ; Ssa.Program.layouts (ssa, disp)
- end)
+ let
+ open Control
+ in
+ if !keepSSA
+ then saveToFile ({suffix = "ssa"}, No, ssa,
+ Layouts Ssa.Program.layouts)
else ()
end
val machine =
1.101 +1 -0 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.100
retrieving revision 1.101
diff -u -r1.100 -r1.101
--- main.sml 24 Nov 2002 23:15:10 -0000 1.100
+++ main.sml 7 Dec 2002 02:21:53 -0000 1.101
@@ -170,6 +170,7 @@
| "g" => keepGenerated := 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",
1.16 +1 -1 mlton/mlton/ssa/analyze.fun
Index: analyze.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/analyze.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- analyze.fun 7 Jul 2002 21:41:51 -0000 1.15
+++ analyze.fun 7 Dec 2002 02:21:53 -0000 1.16
@@ -22,7 +22,7 @@
val unit = fromType Type.unit
fun coerces (from, to) =
Vector.foreach2 (from, to, fn (from, to) =>
- coerce {from = from, to = to})
+ coerce {from = from, to = to})
val {get = value: Var.t -> 'a, set = setValue, ...} =
Property.getSetOnce
(Var.plist,
1.12 +3 -8 mlton/mlton/ssa/constant-propagation.fun
Index: constant-propagation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/constant-propagation.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- constant-propagation.fun 24 Nov 2002 01:19:44 -0000 1.11
+++ constant-propagation.fun 7 Dec 2002 02:21:54 -0000 1.12
@@ -365,13 +365,9 @@
| Array {birth, length, ...} =>
unary (birth, fn _ => length,
fn {args, targs} =>
- if isZero length
- then Exp.PrimApp {args = Vector.new0 (),
- prim = Prim.array0,
- targs = targs}
- else Exp.PrimApp {args = args,
- prim = Prim.array,
- targs = targs},
+ Exp.PrimApp {args = args,
+ prim = Prim.array,
+ targs = targs},
Type.dearray ty)
| Vector _ => No
| Tuple vs =>
@@ -773,7 +769,6 @@
in
case Prim.name prim of
Array_array => array (arg 0, bear ())
- | Array_array0 => array (zero, bear ())
| Array_array0Const => array (zero, Birth.here ())
| Array_length => arrayLength (arg 0)
| Array_sub => dearray (arg 0)
1.46 +2 -1 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- ssa-tree.fun 24 Nov 2002 01:19:44 -0000 1.45
+++ ssa-tree.fun 7 Dec 2002 02:21:54 -0000 1.46
@@ -812,7 +812,8 @@
end
datatype z = datatype Transfer.t
-local open Layout
+local
+ open Layout
in
fun layoutFormals (xts: (Var.t * Type.t) vector) =
Vector.layout (fn (x, t) =>
1.39 +1 -1 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- ssa-tree.sig 24 Nov 2002 01:19:44 -0000 1.38
+++ ssa-tree.sig 7 Dec 2002 02:21:54 -0000 1.39
@@ -282,8 +282,8 @@
datatype t =
T of {
datatypes: Datatype.t vector,
- globals: Statement.t vector,
functions: Function.t list,
+ globals: Statement.t vector,
main: Func.t (* Must be nullary. *)
}
1.12 +0 -1 mlton/mlton/ssa/useless.fun
Index: useless.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/useless.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- useless.fun 21 Aug 2002 04:48:32 -0000 1.11
+++ useless.fun 7 Dec 2002 02:21:54 -0000 1.12
@@ -468,7 +468,6 @@
case Prim.name prim of
Array_array =>
coerce {from = arg 0, to = arrayLength result}
- | Array_array0 => ()
| Array_array0Const => ()
| Array_length => return (arrayLength (arg 0))
| Array_sub => sub ()
1.16 +2 -1 mlton/mlton/type-inference/infer.fun
Index: infer.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/infer.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- infer.fun 24 Nov 2002 01:19:44 -0000 1.15
+++ infer.fun 7 Dec 2002 02:21:54 -0000 1.16
@@ -221,7 +221,8 @@
end
fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector =
- Vector.map (Vector.sort (v, fn ((f, _), (f', _)) => Field.<= (f, f')),
+ Vector.map (QuickSort.sortVector (v, fn ((f, _), (f', _)) =>
+ Field.<= (f, f')),
#2)
(*---------------------------------------------------*)
1.10 +4 -7 mlton/mlton/type-inference/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/type-inference/type-env.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- type-env.fun 10 Apr 2002 07:02:21 -0000 1.9
+++ type-env.fun 7 Dec 2002 02:21:54 -0000 1.10
@@ -620,13 +620,10 @@
then Vector.sub (ts, 0)
else con (Tycon.tuple, ts)
fun sortFields (fields: (Field.t * 'a) list) =
- let
- val a = Array.fromList fields
- val _ = QuickSort.sort (a, fn ((f, _), (f', _)) =>
- Field.<= (f, f'))
- in
- Array.toVector a
- end
+ Array.toVector
+ (QuickSort.sortArray
+ (Array.fromList fields, fn ((f, _), (f', _)) =>
+ Field.<= (f, f')))
fun unsorted (fields: (Field.t * X.t) list, final: FinalRecordType.t) =
let
val v = sortFields fields
1.103 +11 -11 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.102
retrieving revision 1.103
diff -u -r1.102 -r1.103
--- gc.c 26 Nov 2002 19:42:52 -0000 1.102
+++ gc.c 7 Dec 2002 02:21:54 -0000 1.103
@@ -803,19 +803,19 @@
pointer max;
assert (ARRAY_TAG == tag);
- assert (0 == GC_arrayNumElements (p)
- ? 0 == numPointers
- : TRUE);
numBytes = arrayNumBytes (p, numPointers, numNonPointers);
max = p + numBytes;
if (numPointers == 0) {
/* There are no pointers, just update p. */
p = max;
} else if (numNonPointers == 0) {
- assert (0 < GC_arrayNumElements (p));
/* It's an array with only pointers. */
- for (; p < max; p += POINTER_SIZE)
- maybeCall (f, s, (pointer*)p);
+ if (0 == GC_arrayNumElements (p))
+ /* Skip the space for the forwarding pointer. */
+ p = max;
+ else
+ for (; p < max; p += POINTER_SIZE)
+ maybeCall (f, s, (pointer*)p);
} else {
uint numBytesPointers;
@@ -1410,7 +1410,7 @@
} else { /* Array. */
assert(ARRAY_TAG == tag);
headerBytes = GC_ARRAY_HEADER_SIZE;
- objectBytes = arrayNumBytes(p, numPointers, numNonPointers);
+ objectBytes = arrayNumBytes (p, numPointers, numNonPointers);
}
return headerBytes + objectBytes;
}
@@ -1815,13 +1815,10 @@
header = nextHeader;
goto markNext;
} else if (ARRAY_TAG == tag) {
- assert (0 == GC_arrayNumElements (cur)
- ? 0 == numPointers
- : TRUE);
numBytes = arrayNumBytes (cur, numPointers, numNonPointers);
size += GC_ARRAY_HEADER_SIZE + numBytes;
*headerp = header;
- if (0 == numBytes or 0 == numPointers)
+ if (0 == numPointers or 0 == GC_arrayNumElements (cur))
goto ret;
assert (0 == numNonPointers);
max = cur + numBytes;
@@ -2642,6 +2639,9 @@
die ("Out of memory: cannot allocate array with %s bytes.\n",
ullongToCommaString (arraySize64));
arraySize = (W32)arraySize64;
+ if (3 * WORD_SIZE == arraySize)
+ /* array is empty -- create space for forwarding pointer. */
+ arraySize = 4 * WORD_SIZE;
if (DEBUG_ARRAY)
fprintf (stderr, "array with %s elts of size %u and total size %s. ensure %s bytes free.\n",
uintToCommaString (numElts),
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel