[MLton] cvs commit: replaced type system in Rssa and Machine
Stephen Weeks
sweeks@mlton.org
Sat, 3 Apr 2004 22:50:28 -0800
sweeks 04/04/03 22:50:22
Modified: include c-chunk.h
mlton .cvsignore Makefile mlton-stubs.cm sources.cm
mlton/ast int-size.fun int-size.sig prim-tycons.fun
real-size.fun real-size.sig sources.cm
word-size.fun word-size.sig
mlton/atoms atoms.fun atoms.sig c-function.fun
c-function.sig c-type.fun c-type.sig const.sig
ffi.fun ffi.sig hash-type.fun hash-type.sig id.fun
id.sig int-x.fun prim.fun prim.sig profile-exp.fun
profile-exp.sig real-x.fun real-x.sig sources.cm
tycon.sig type-ops.fun word-x.fun word-x.sig
mlton/backend allocate-registers.fun allocate-registers.sig
backend.fun backend.sig chunkify.fun
limit-check.fun machine.fun machine.sig profile.fun
representation.fun representation.sig rssa.fun
rssa.sig sources.cm ssa-to-rssa.fun switch.fun
switch.sig
mlton/closure-convert sources.cm
mlton/codegen/c-codegen c-codegen.fun c-codegen.sig
sources.cm
mlton/codegen/x86-codegen sources.cm x86-codegen.fun
x86-codegen.sig x86-generate-transfers.fun
x86-live-transfers.fun x86-mlton-basic.fun
x86-mlton-basic.sig x86-pseudo.sig
x86-translate.fun x86.fun x86.sig
mlton/control sources.cm
mlton/core-ml sources.cm
mlton/defunctorize sources.cm
mlton/elaborate elaborate-core.fun elaborate-env.fun
sources.cm type-env.fun type-env.sig
mlton/main compile.fun main.fun sources.cm
mlton/match-compile match-compile.fun sources.cm
mlton/ssa shrink.fun sources.cm ssa-tree.fun ssa-tree.sig
type-check.fun
mlton/xml polyvariance.sig sources.cm type-check.fun
Added: mlton mlton.cm
mlton/atoms func.sig label.sig object-type.fun
object-type.sig pointer-tycon.fun pointer-tycon.sig
profile-label.fun profile-label.sig rep-type.fun
rep-type.sig runtime.fun runtime.sig
mlton/control bits.sml
Removed: mlton/backend machine-atoms.fun machine-atoms.sig
profile-label.fun profile-label.sig runtime.fun
runtime.sig
Log:
MAIL replaced type system in Rssa and Machine
The new type language, RepType (see atoms/rep-type.sig), is aimed
expressing bit-level control over layout and associated packing of
data representations. There are singleton types that denote
constants, other atomic types for things like integers and reals, and
arbitrary sum types and sequence (tuple) types. The big change to the
type system is that type checking is now based on subtyping, not type
equality. So, for example, the singleton type 0xFFFFEEBB whose only
inhabitant is the eponymous constant is a subtype of the type Word32.
The type system makes lots of things cleaner than they used to be.
For example, we used have a magical IntInf type and coercions between
it and word vectors or integers. Now, we can express IntInf as a sum
type of a pointer to a word vector and a sequence type that requires
the low bit to be one and the high 31 bits as an integer. From the
code,
val intInf: t =
sum (Vector.new2
(wordVector,
seq (Vector.new2
(constant (WordX.fromIntInf
(1, WordSize.fromBits (Bits.fromInt 1))),
int (IntSize.I (Bits.fromInt 31))))))
Now, the subtyping rules mean that we don't need anything special to
handle WordVector_toIntInf, since wordVector is a subtype of intInf.
Similarly, the special purpose EnumPointers type and rules that we
used to have now falls out as a sum type and the usual subtyping
rules.
Calls to C functions are now type checked in all ILs (they used to be
checked nowhere). In order to do this, I needed to change the type
language for C functions to express their arguments and results as
RepTypes. This caused some reorganization of code, moving stuff from
backend/ to atoms/, since C functions (and now hence RepTypes) are
used from the first IL. One nice effect of all this is that the types
of C functions are now more clear. For example, GC_copyThread now
takes gcState * thread instead of word * pointer.
Primapps are also now type checked more than they used to be. See the
typeCheck function in atoms/prim.fun. Most of the time, this does the
obvious thing (e.g. Int_add has the type int * int -> int). However,
typeCheck is clever when performing word operations (andb, lshift,
orb, rshift,...) on types where some part of the argument is known
(because it is a singleton type). This is to properly type check when
multiple objects are packed into a word and word operations are used
to construct/destruct the word. As a side benefit, these rules check
other things that we used to not check, like the right shift that we
do to the header word of a heap object in order to do a case on the
tag.
There are a couple of drawbacks to the new type system. First, type
checking of the Machine program can be rather slow. It's slow enough
that I've turned it off for now. I'm pretty sure that the speed
problems are due to the newness of the code and will be pretty easy to
fix. A more serious problem is that the implementation of subtyping
is messy and is certainly incomplete, meaning that there are times
when it will say that t1 is not a subtype of t2 even though the set of
values denoted by a type t1 is a subset of the set of values denoted
by t2. The type checker works for everything that SsaToRssa is
producing now, but it would be nice to make it complete (but not too
slow), or at least have a clearer understanding of its boundaries.
The plan going forward is to fix the speed problems and then to start
experimenting with packed tuple and datatype representations. Now
that all the infrastructure is in place and the representation pass
has been refactored and well-isolated, it should be pretty easy to do
so.
Now for some minor points.
Simplified case statements in Rssa and Machine so there are only
cases on words. Also, the exhaustivity check is now a simple call to
RepType.isSubtype.
Updated the copyright notice to read 2004 whenever I saw an old
date. Please do the same in files whenever you modify them and they
still have an old date.
Cleaned up atoms/prim.fun so that prims really are just represented
by their name and there are no more linear lookups in the list of all
prims.
Simplified CTypes (c-type.fun) so that they don't depend on the integer,
real, or word size used for SML. Now, CType is a simlpe datatype.
datatype t = Pointer | Real32 | Real64 | Word8 | Word16 | Word32 | Word64
I eliminated the distinction between integers and words, since there
isn't much of a difference from the codegen's point of view. It did
require me to make a few changes to c-chunk.h of the C codegen to
ensure that macros used to implement integer primtives treated
arguments as the right type.
Created the structures Bits, Bytes, and Words to help keep the units
straight when talking about memory amounts.
The type preThread is replaced by thread in the defunctorizer. This
is so that calls to C functions can type check, as they only know
about threads.
Reworked the CM files with appropriate #ifdefs so that MLton and
SML/NJ use the same files. So, cmcat is no longer needed to develop
with MLton. This means that order now matters in the CM files.
Revision Changes Path
1.22 +11 -3 mlton/include/c-chunk.h
Index: c-chunk.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/c-chunk.h,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- c-chunk.h 16 Mar 2004 06:38:26 -0000 1.21
+++ c-chunk.h 4 Apr 2004 06:50:13 -0000 1.22
@@ -206,6 +206,7 @@
#endif
#if (defined (INT_NO_CHECK))
+
#define Int_addCheck(dst, n1, n2, l) dst = n1 + n2
#define Int_mulCheck(dst, n1, n2, l) dst = n1 * n2
#define Int_negCheck(dst, n, l) dst = -n
@@ -218,6 +219,7 @@
#define Int_subCheckXC Int_subCheck
#define Word32_addCheckCX Word32_addCheck
#define Word32_addCheckXC Word32_addCheck
+
#endif
#if (defined (INT_TEST))
@@ -235,8 +237,10 @@
#define Word32_max (Word32)0xFFFFFFFF
#define Word64_max (Word64)0xFFFFFFFFFFFFFFFF
-#define Int_addCheckXC(size, dst, x, c, l) \
+#define Int_addCheckXC(size, dst, xW, cW, l) \
do { \
+ Int##size x = xW; \
+ Int##size c = cW; \
if (c >= 0) { \
if (x > Int##size##_max - c) \
goto l; \
@@ -271,9 +275,11 @@
#define Int32_negCheck(dst, n, l) Int_negCheck(32, dst, n, l)
#define Int64_negCheck(dst, n, l) Int_negCheck(64, dst, n, l)
-#define Int_subCheckCX(size, dst, c, x, l) \
+#define Int_subCheckCX(size, dst, cW, xW, l) \
do { \
if (c >= 0) { \
+ Int##size c = cW; \
+ Int##size x = xW; \
if (x < c - Int##size##_max) \
goto l; \
} else if (x > c - Int##size##_min) \
@@ -285,8 +291,10 @@
#define Int32_subCheckCX(dst, c, x, l) Int_subCheckCX(32, dst, c, x, l)
#define Int64_subCheckCX(dst, c, x, l) Int_subCheckCX(64, dst, c, x, l)
-#define Int_subCheckXC(size, dst, x, c, l) \
+#define Int_subCheckXC(size, dst, xW, cW, l) \
do { \
+ Int##size c = cW; \
+ Int##size x = xW; \
if (c <= 0) { \
if (x > Int##size##_max + c) \
goto l; \
1.7 +0 -1 mlton/mlton/.cvsignore
Index: .cvsignore
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/.cvsignore,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- .cvsignore 24 Sep 2003 17:54:02 -0000 1.6
+++ .cvsignore 4 Apr 2004 06:50:13 -0000 1.7
@@ -1,4 +1,3 @@
mlton-compile
-mlton.cm
mlton.sml
upgrade-basis.sml
1.89 +0 -19 mlton/mlton/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/Makefile,v
retrieving revision 1.88
retrieving revision 1.89
diff -u -r1.88 -r1.89
--- Makefile 4 Mar 2004 22:36:31 -0000 1.88
+++ Makefile 4 Apr 2004 06:50:13 -0000 1.89
@@ -63,25 +63,6 @@
$(UP):
$(SRC)/bin/upgrade-basis "$(PATH)" >$(UP)
-mlton.cm: mlton-stubs.cm
- grep -v mlton-stubs mlton-stubs.cm >mlton.cm
-
-# This makes a version of MLton that can be compiled in the standard basis
-# library. I.E. it doesn't require a MLton structure.
-.PHONY: mlton-stubs_cm
-mlton-stubs_cm:
- ( \
- echo 'Group is' && \
- cmcat sources.cm | grep -v 'basis-stubs' | \
- grep -v 'mlton-stubs-in-smlnj' | \
- grep mlyacc && \
- echo '$(UP)' && \
- cmcat sources.cm | grep -v 'basis-stubs' | \
- grep -v 'mlton-stubs-in-smlnj' | \
- grep -v mlyacc && \
- echo 'call-main.sml'; \
- ) >mlton-stubs.cm
-
mlton.sml: $(SOURCES)
rm -f mlton.sml && mlton -stop sml mlton.cm && chmod -w mlton.sml
1.45 +3 -512 mlton/mlton/mlton-stubs.cm
Index: mlton-stubs.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/mlton-stubs.cm,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- mlton-stubs.cm 5 Mar 2004 03:50:51 -0000 1.44
+++ mlton-stubs.cm 4 Apr 2004 06:50:13 -0000 1.45
@@ -1,513 +1,4 @@
Group is
-../lib/mlyacc/base.sig
-../lib/mlyacc/stream.sml
-../lib/mlyacc/lrtable.sml
-../lib/mlyacc/parser2.sml
-../lib/mlyacc/join.sml
-upgrade-basis.sml
-../lib/mlton-stubs/thread.sig
-../lib/mlton-stubs/thread.sml
-../lib/mlton-stubs/world.sig
-../lib/mlton-stubs/word.sig
-../lib/mlton-stubs/weak.sig
-../lib/mlton-stubs/vector.sig
-../lib/mlton-stubs/io.sig
-../lib/mlton-stubs/text-io.sig
-../lib/mlton-stubs/syslog.sig
-../lib/mlton-stubs/socket.sig
-../lib/mlton-stubs/signal.sig
-../lib/mlton-stubs/rusage.sig
-../lib/mlton-stubs/rlimit.sig
-../lib/mlton-stubs/random.sig
-../lib/mlton-stubs/profile.sig
-../lib/mlton-stubs/process.sig
-../lib/mlton-stubs/proc-env.sig
-../lib/mlton-stubs/pointer.sig
-../lib/mlton-stubs/platform.sig
-../lib/mlton-stubs/itimer.sig
-../lib/mlton-stubs/int-inf.sig
-../lib/mlton-stubs/gc.sig
-../lib/mlton-stubs/finalizable.sig
-../lib/mlton-stubs/exn.sig
-../lib/mlton-stubs/cont.sig
-../lib/mlton-stubs/bin-io.sml
-../lib/mlton-stubs/bin-io.sig
-../lib/mlton-stubs/array.sig
-../lib/mlton-stubs/mlton.sig
-../lib/mlton-stubs/random.sml
-../lib/mlton-stubs/mlton.sml
-../lib/mlton-stubs/real.sml
-../lib/mlton/pervasive/pervasive.sml
-../lib/mlton/basic/dynamic-wind.sig
-../lib/mlton/basic/dynamic-wind.sml
-../lib/mlton/basic/error.sig
-../lib/mlton/basic/error.sml
-../lib/mlton/basic/outstream0.sml
-../lib/mlton/basic/layout.sig
-../lib/mlton/basic/relation0.sml
-../lib/mlton/basic/char0.sml
-../lib/mlton/basic/string0.sml
-../lib/mlton/basic/layout.sml
-../lib/mlton/basic/substring.sig
-../lib/mlton/basic/assert.sig
-../lib/mlton/basic/assert.sml
-../lib/mlton/basic/list.sig
-../lib/mlton/basic/fold.sig
-../lib/mlton/basic/fold.fun
-../lib/mlton/basic/list.sml
-../lib/mlton/basic/word.sig
-../lib/mlton/basic/word8.sml
-../lib/mlton/basic/word32.sig
-../lib/mlton/basic/word.sml
-../lib/mlton/basic/string1.sml
-../lib/mlton/basic/substring.sml
-../lib/mlton/basic/outstream.sig
-../lib/mlton/basic/outstream.sml
-../lib/mlton/basic/relation.sig
-../lib/mlton/basic/relation.sml
-../lib/mlton/basic/order0.sig
-../lib/mlton/basic/order.sig
-../lib/mlton/basic/time.sig
-../lib/mlton/basic/time.sml
-../lib/mlton/basic/instream.sig
-../lib/mlton/basic/char.sig
-../lib/mlton/basic/computation.sig
-../lib/mlton/basic/trace.sig
-../lib/mlton/basic/exn.sig
-../lib/mlton/basic/exn.sml
-../lib/mlton/basic/date.sig
-../lib/mlton/basic/date.sml
-../lib/mlton/basic/pid.sig
-../lib/mlton/basic/option.sig
-../lib/mlton/basic/option.sml
-../lib/mlton/basic/pid.sml
-../lib/mlton/basic/intermediate-computation.sig
-../lib/mlton/basic/instream0.sml
-../lib/mlton/basic/intermediate-computation.sml
-../lib/mlton/basic/string-map.sig
-../lib/mlton/basic/string-map.sml
-../lib/mlton/basic/t.sig
-../lib/mlton/basic/unit.sig
-../lib/mlton/basic/unit.sml
-../lib/mlton/basic/trace.sml
-../lib/mlton/basic/bool.sig
-../lib/mlton/basic/bool.sml
-../lib/mlton/basic/char.sml
-../lib/mlton/basic/string.sig
-../lib/mlton/basic/stream.sig
-../lib/mlton/basic/promise.sig
-../lib/mlton/basic/promise.sml
-../lib/mlton/basic/stream.sml
-../lib/mlton/basic/ring.sig
-../lib/mlton/basic/ring-with-identity.sig
-../lib/mlton/basic/euclidean-ring.sig
-../lib/mlton/basic/integer.sig
-../lib/mlton/basic/euclidean-ring.fun
-../lib/mlton/basic/ring.fun
-../lib/mlton/basic/ordered-ring.sig
-../lib/mlton/basic/ordered-ring.fun
-../lib/mlton/basic/power.sml
-../lib/mlton/basic/ring-with-identity.fun
-../lib/mlton/basic/integer.fun
-../lib/mlton/basic/int.sml
-../lib/mlton/basic/vector.sig
-../lib/mlton/basic/vector.fun
-../lib/mlton/basic/vector.sml
-../lib/mlton/basic/random.sig
-../lib/mlton/basic/real.sig
-../lib/mlton/basic/field.sig
-../lib/mlton/basic/field.fun
-../lib/mlton/basic/ordered-field.sig
-../lib/mlton/basic/ordered-field.fun
-../lib/mlton/basic/real.sml
-../lib/mlton/basic/random.sml
-../lib/mlton/basic/array.sig
-../lib/mlton/basic/array.fun
-../lib/mlton/basic/array.sml
-../lib/mlton/basic/binary-search.sig
-../lib/mlton/basic/binary-search.sml
-../lib/mlton/basic/hash-set.sig
-../lib/mlton/basic/hash-set.sml
-../lib/mlton/basic/string.sml
-../lib/mlton/basic/instream.sml
-../lib/mlton/basic/file.sig
-../lib/mlton/basic/file.sml
-../lib/mlton/basic/signal.sml
-../lib/mlton/basic/process.sig
-../lib/mlton/basic/dir.sig
-../lib/mlton/basic/dir.sml
-../lib/mlton/basic/function.sig
-../lib/mlton/basic/function.sml
-../lib/mlton/basic/file-desc.sig
-../lib/mlton/basic/file-desc.sml
-../lib/mlton/basic/process.sml
-../lib/mlton/basic/append-list.sig
-../lib/mlton/basic/append-list.sml
-../lib/mlton/basic/property-list.sig
-../lib/mlton/basic/ref.sig
-../lib/mlton/basic/ref.sml
-../lib/mlton/basic/het-container.sig
-../lib/mlton/basic/property-list.fun
-../lib/mlton/basic/het-container.fun
-../lib/mlton/basic/property.sig
-../lib/mlton/basic/property.fun
-../lib/mlton/basic/dot-color.sml
-../lib/mlton/basic/dot.sig
-../lib/mlton/basic/dot.sml
-../lib/mlton/basic/tree.sig
-../lib/mlton/basic/counter.sig
-../lib/mlton/basic/counter.sml
-../lib/mlton/basic/tree.sml
-../lib/mlton/basic/int-inf.sig
-../lib/mlton/basic/int-inf.sml
-../lib/mlton/basic/control.sig
-../lib/mlton/basic/control.fun
-../lib/mlton/basic/queue.sig
-../lib/mlton/basic/two-list-queue.sml
-../lib/mlton/basic/array2.sig
-../lib/mlton/basic/array2.sml
-../lib/mlton/basic/env.sig
-../lib/mlton/basic/env.fun
-../lib/mlton/basic/unique-id.sig
-../lib/mlton/basic/unique-id.fun
-../lib/mlton/basic/clearable-promise.sig
-../lib/mlton/basic/clearable-promise.sml
-../lib/mlton/basic/justify.sig
-../lib/mlton/basic/justify.sml
-../lib/mlton/basic/directed-graph.sig
-../lib/mlton/basic/directed-graph.sml
-../lib/mlton/basic/large-word.sml
-../lib/mlton/basic/quick-sort.sig
-../lib/mlton/basic/insertion-sort.sig
-../lib/mlton/basic/insertion-sort.sml
-../lib/mlton/basic/quick-sort.sml
-../lib/mlton/basic/unique-set.sig
-../lib/mlton/basic/unique-set.fun
-../lib/mlton/basic/fixed-point.sig
-../lib/mlton/basic/fixed-point.sml
-../lib/mlton/basic/mono-vector.fun
-../lib/mlton/basic/result.sig
-../lib/mlton/basic/result.sml
-../lib/mlton/basic/regexp.sig
-../lib/mlton/basic/regexp.sml
-../lib/mlton/basic/popt.sig
-../lib/mlton/basic/popt.sml
-../lib/smlnj/ord-key-sig.sml
-../lib/smlnj/ord-map-sig.sml
-../lib/smlnj/lib-base-sig.sml
-../lib/smlnj/lib-base.sml
-../lib/smlnj/splaytree-sig.sml
-../lib/smlnj/splaytree.sml
-../lib/smlnj/splay-map-fn.sml
-../lib/mlton/env/mono-env.sig
-../lib/mlton/env/basic-env-to-env.fun
-../lib/mlton/env/mono-env.fun
-../lib/mlton/env/finite-function.sig
-../lib/mlton/env/poly-cache.sig
-../lib/mlton/env/poly-cache.fun
-../lib/mlton/set/disjoint.sig
-../lib/mlton/set/disjoint.fun
-../lib/mlton/set/set.sig
-../lib/mlton/set/unordered.fun
-../lib/mlton/set/ordered-unique-set.fun
-control/source-pos.sig
-control/source-pos.sml
-control/region.sig
-control/region.sml
-control/control.sig
-control/control.sml
-control/system.sig
-control/system.sml
-cm/cm.sig
-cm/parse.sig
-cm/lexer.sig
-cm/lexer.sml
-cm/parse.sml
-cm/cm.sml
-ast/word-size.sig
-ast/real-size.sig
-ast/int-size.sig
-atoms/c-type.sig
-backend/runtime.sig
-backend/profile-label.sig
-atoms/id.sig
-atoms/c-function.sig
-codegen/x86-codegen/x86.sig
-codegen/x86-codegen/x86-validate.sig
-codegen/x86-codegen/x86-validate.fun
-atoms/word-x.sig
-atoms/real-x.sig
-atoms/source-info.sig
-atoms/int-x.sig
-atoms/const.sig
-ast/prim-cons.sig
-atoms/con-.sig
-atoms/prim.sig
-backend/machine-atoms.sig
-backend/switch.sig
-backend/machine.sig
-codegen/x86-codegen/x86-pseudo.sig
-codegen/x86-codegen/x86-mlton-basic.sig
-codegen/x86-codegen/x86-liveness.sig
-codegen/x86-codegen/x86-mlton.sig
-codegen/x86-codegen/x86-allocate-registers.sig
-codegen/x86-codegen/x86-allocate-registers.fun
-codegen/x86-codegen/x86-loop-info.sig
-codegen/x86-codegen/x86-jump-info.sig
-codegen/x86-codegen/x86-live-transfers.sig
-codegen/x86-codegen/x86-live-transfers.fun
-codegen/x86-codegen/x86-entry-transfer.sig
-codegen/x86-codegen/x86-generate-transfers.sig
-codegen/x86-codegen/x86-generate-transfers.fun
-codegen/x86-codegen/peephole.sig
-codegen/x86-codegen/peephole.fun
-codegen/x86-codegen/x86-simplify.sig
-codegen/x86-codegen/x86-simplify.fun
-codegen/x86-codegen/x86-translate.sig
-codegen/x86-codegen/x86-translate.fun
-codegen/x86-codegen/x86-mlton.fun
-codegen/x86-codegen/x86-entry-transfer.fun
-codegen/x86-codegen/x86-loop-info.fun
-codegen/x86-codegen/x86-jump-info.fun
-codegen/x86-codegen/x86-liveness.fun
-codegen/x86-codegen/x86-mlton-basic.fun
-codegen/x86-codegen/x86.fun
-atoms/ffi.sig
-codegen/c-codegen/c-codegen.sig
-codegen/x86-codegen/x86-codegen.sig
-codegen/x86-codegen/x86-codegen.fun
-codegen/c-codegen/c-codegen.fun
-ast/tycon-kind.sig
-ast/admits-equality.sig
-ast/prim-tycons.sig
-atoms/tycon.sig
-atoms/type-ops.sig
-ast/wrapped.sig
-ast/tyvar.sig
-ast/symbol.sig
-ast/field.sig
-ast/record.sig
-atoms/var.sig
-atoms/profile-exp.sig
-atoms/atoms.sig
-atoms/hash-type.sig
-ssa/ssa-tree.sig
-ssa/direct-exp.sig
-ssa/analyze.sig
-ssa/type-check.sig
-ssa/shrink.sig
-ssa/restore.sig
-ssa/simplify.sig
-ssa/ssa.sig
-backend/rssa.sig
-backend/representation.sig
-backend/representation.fun
-backend/ssa-to-rssa.sig
-backend/ssa-to-rssa.fun
-backend/signal-check.sig
-backend/signal-check.fun
-backend/profile.sig
-backend/profile.fun
-backend/parallel-move.sig
-backend/parallel-move.fun
-backend/limit-check.sig
-backend/limit-check.fun
-ssa/flat-lattice.sig
-ssa/flat-lattice.fun
-backend/implement-handlers.sig
-backend/implement-handlers.fun
-backend/equivalence-graph.sig
-backend/equivalence-graph.fun
-backend/chunkify.sig
-backend/chunkify.fun
-backend/live.sig
-backend/live.fun
-backend/allocate-registers.sig
-backend/allocate-registers.fun
-backend/err.sml
-backend/switch.fun
-backend/rssa.fun
-backend/backend.sig
-backend/backend.fun
-xml/xml-type.sig
-xml/xml-tree.sig
-xml/xml.sig
-xml/sxml.sig
-closure-convert/lambda-free.sig
-closure-convert/lambda-free.fun
-closure-convert/abstract-value.sig
-closure-convert/abstract-value.fun
-closure-convert/globalize.sig
-closure-convert/globalize.fun
-closure-convert/closure-convert.sig
-closure-convert/closure-convert.fun
-xml/sxml-exns.sig
-xml/monomorphise.sig
-xml/monomorphise.fun
-atoms/use-name.fun
-ast/ast-id.sig
-ast/longid.sig
-ast/ast-const.sig
-ast/ast-atoms.sig
-ast/ast-core.sig
-ast/ast.sig
-elaborate/scope.sig
-elaborate/scope.fun
-core-ml/core-ml.sig
-elaborate/interface.sig
-elaborate/decs.sig
-elaborate/type-env.sig
-elaborate/elaborate-env.sig
-elaborate/precedence-parse.sig
-elaborate/precedence-parse.fun
-elaborate/const-type.sig
-elaborate/elaborate-core.sig
-elaborate/elaborate-core.fun
-elaborate/elaborate-sigexp.sig
-elaborate/elaborate-sigexp.fun
-control/pretty.sig
-control/pretty.sml
-atoms/generic-scheme.sig
-atoms/generic-scheme.fun
-elaborate/interface.fun
-elaborate/decs.fun
-elaborate/elaborate-env.fun
-elaborate/elaborate.sig
-elaborate/elaborate.fun
-match-compile/nested-pat.sig
-match-compile/match-compile.sig
-match-compile/match-compile.fun
-match-compile/nested-pat.fun
-defunctorize/defunctorize.sig
-defunctorize/defunctorize.fun
-core-ml/dead-code.sig
-core-ml/dead-code.fun
-control/source.sig
-control/source.sml
-front-end/ml.grm.sig
-front-end/ml.lex.sml
-front-end/ml.grm.sml
-front-end/front-end.sig
-front-end/front-end.fun
-atoms/id.fun
-backend/profile-label.fun
-backend/machine-atoms.fun
-backend/runtime.fun
-backend/machine.fun
-ssa/two-point-lattice.sig
-ssa/two-point-lattice.fun
-ssa/useless.sig
-ssa/useless.fun
-ssa/simplify-types.sig
-ssa/simplify-types.fun
-ssa/remove-unused.sig
-ssa/remove-unused.fun
-ssa/redundant-tests.sig
-ssa/redundant-tests.fun
-ssa/redundant.sig
-ssa/redundant.fun
-ssa/poly-equal.sig
-ssa/poly-equal.fun
-ssa/loop-invariant.sig
-ssa/loop-invariant.fun
-ssa/multi.sig
-ssa/multi.fun
-ssa/local-ref.sig
-ssa/local-ref.fun
-ssa/local-flatten.sig
-ssa/local-flatten.fun
-ssa/known-case.sig
-ssa/known-case.fun
-ssa/introduce-loops.sig
-ssa/introduce-loops.fun
-ssa/inline.sig
-ssa/inline.fun
-ssa/flatten.sig
-ssa/flatten.fun
-ssa/contify.sig
-ssa/contify.fun
-ssa/global.sig
-ssa/global.fun
-ssa/constant-propagation.sig
-ssa/constant-propagation.fun
-ssa/common-subexp.sig
-ssa/common-subexp.fun
-ssa/common-block.sig
-ssa/common-block.fun
-ssa/common-arg.sig
-ssa/common-arg.fun
-ssa/simplify.fun
-ssa/n-point-lattice.sig
-ssa/n-point-lattice.fun
-ssa/three-point-lattice.sig
-ssa/three-point-lattice.fun
-ssa/restore.fun
-ssa/shrink.fun
-ssa/type-check.fun
-ssa/analyze.fun
-ssa/direct-exp.fun
-atoms/type-ops.fun
-atoms/hash-type.fun
-ssa/ssa-tree.fun
-ssa/ssa.fun
-xml/type-check.sig
-xml/shrink.sig
-xml/polyvariance.sig
-xml/polyvariance.fun
-xml/sxml-tree.sig
-xml/implement-exceptions.sig
-xml/implement-exceptions.fun
-xml/sxml-simplify.sig
-xml/sxml-simplify.fun
-xml/sxml.fun
-xml/simplify-types.sig
-xml/simplify-types.fun
-xml/xml-simplify.sig
-xml/xml-simplify.fun
-xml/scc-funs.sig
-xml/scc-funs.fun
-xml/shrink.fun
-xml/type-check.fun
-xml/xml-tree.fun
-xml/xml.fun
-core-ml/core-ml.fun
-elaborate/type-env.fun
-atoms/prim.fun
-atoms/const.fun
-atoms/word-x.fun
-atoms/real-x.fun
-atoms/int-x.fun
-atoms/ffi.fun
-atoms/c-function.fun
-atoms/c-type.fun
-ast/prim-cons.fun
-atoms/con-.fun
-ast/prim-tycons.fun
-ast/tycon-kind.fun
-ast/admits-equality.fun
-atoms/tycon.fun
-atoms/var.fun
-atoms/profile-exp.fun
-atoms/source-info.fun
-atoms/atoms.fun
-ast/ast-core.fun
-ast/longid.fun
-ast/ast-id.fun
-ast/word-size.fun
-ast/real-size.fun
-ast/int-size.fun
-ast/ast-const.fun
-ast/ast-atoms.fun
-ast/ast.fun
-ast/tyvar.fun
-ast/record.fun
-ast/field.fun
-ast/symbol.fun
-main/lookup-constant.sig
-main/lookup-constant.fun
-main/compile.sig
-main/compile.fun
-main/main.sig
-main/main.fun
-main/main.sml
-call-main.sml
+
+../lib/mlton-stubs/sources.cm
+mlton.cm
1.3 +1 -1 mlton/mlton/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/sources.cm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.2
+++ sources.cm 4 Apr 2004 06:50:14 -0000 1.3
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.74 +3 -472 mlton/mlton/mlton.cm
1.8 +66 -52 mlton/mlton/ast/int-size.fun
Index: int-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/int-size.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- int-size.fun 5 Mar 2004 03:50:51 -0000 1.7
+++ int-size.fun 4 Apr 2004 06:50:14 -0000 1.8
@@ -3,56 +3,101 @@
open S
-datatype t = T of {precision: int}
+datatype t = T of {bits: Bits.t}
-fun bits (T {precision = p, ...}) = p
+fun bits (T {bits, ...}) = bits
-val equals: t * t -> bool = op =
+val toString = Bits.toString o bits
-val sizes: int list =
- List.tabulate (31, fn i => i + 2)
- @ [64]
+val layout = Layout.str o toString
+
+fun compare (s, s') = Bits.compare (bits s, bits s')
+
+val {equals, ...} = Relation.compare compare
fun isValidSize (i: int) =
(2 <= i andalso i <= 32) orelse i = 64
-fun make i = T {precision = i}
+val sizes: Bits.t list =
+ Vector.toList
+ (Vector.keepAllMap
+ (Vector.tabulate (65, fn i => if isValidSize i
+ then SOME (Bits.fromInt i)
+ else NONE),
+ fn i => i))
+
+fun make i = T {bits = i}
+
+val byte = make (Bits.fromInt 8)
val allVector = Vector.tabulate (65, fn i =>
if isValidSize i
- then SOME (make i)
+ then SOME (make (Bits.fromInt i))
else NONE)
-
-fun I i =
- case Vector.sub (allVector, i) handle Subscript => NONE of
- NONE => Error.bug (concat ["strange int size: ", Int.toString i])
+
+fun I (b: Bits.t): t =
+ case Vector.sub (allVector, Bits.toInt b) handle Subscript => NONE of
+ NONE => Error.bug (concat ["strange int size: ", Bits.toString b])
| SOME s => s
-
+
val all = List.map (sizes, I)
-val prims = [I 8, I 16, I 32, I 64]
+val prims = List.map ([8, 16, 32, 64], I o Bits.fromInt)
+
+val default = I Bits.inWord
+
+fun pointer () = I Bits.inWord
-val default = I 32
-
val memoize: (t -> 'a) -> t -> 'a =
fn f =>
let
val v = Vector.map (allVector, fn opt => Option.map (opt, f))
in
- fn T {precision = i, ...} => valOf (Vector.sub (v, i))
+ fn T {bits = b, ...} => valOf (Vector.sub (v, Bits.toInt b))
end
-val toString = Int.toString o bits
+fun roundUpToPrim s =
+ let
+ val bits = Bits.toInt (bits s)
+ val bits =
+ if bits <= 8
+ then 8
+ else if bits <= 16
+ then 16
+ else if bits <= 32
+ then 32
+ else if bits = 64
+ then 64
+ else Error.bug "IntSize.roundUpToPrim"
+ in
+ I (Bits.fromInt bits)
+ end
-val layout = Layout.str o toString
+val bytes: t -> Bytes.t = Bits.toBytes o bits
+
+val max: t -> IntInf.t =
+ memoize (fn s => IntInf.<< (1, Bits.toWord (bits s)) - 1)
+
+val cardinality = memoize (fn s => IntInf.pow (2, Bits.toInt (bits s)))
+
+datatype prim = I8 | I16 | I32 | I64
-val cardinality = memoize (fn s => IntInf.pow (2, bits s))
+val primOpt =
+ memoize (fn T {bits, ...} =>
+ List.peekMap ([(8, I8), (16, I16), (32, I32), (64, I64)],
+ fn (b, p) =>
+ if b = Bits.toInt bits then SOME p else NONE))
+
+fun prim s =
+ case primOpt s of
+ NONE => Error.bug "IntSize.prim"
+ | SOME p => p
val range =
memoize
(fn s =>
let
- val pow = IntInf.pow (2, bits s - 1)
+ val pow = IntInf.pow (2, Bits.toInt (bits s) - 1)
in
(~ pow, pow - 1)
end)
@@ -67,36 +112,5 @@
val min = #1 o range
val max = #2 o range
-
-datatype prim = I8 | I16 | I32 | I64
-
-val primOpt = memoize (fn T {precision = i, ...} =>
- List.peekMap ([(8, I8), (16, I16), (32, I32), (64, I64)],
- fn (i', p) =>
- if i = i' then SOME p else NONE))
-
-fun prim s =
- case primOpt s of
- NONE => Error.bug "IntSize.prim"
- | SOME p => p
-
-fun roundUpToPrim s =
- let
- val bits = bits s
- val bits =
- if bits <= 8
- then 8
- else if bits <= 16
- then 16
- else if bits <= 32
- then 32
- else if bits = 64
- then 64
- else Error.bug "IntSize.roundUpToPrim"
- in
- I bits
- end
-
-val bytes: t -> int = memoize (fn s => bits (roundUpToPrim s) div 8)
end
1.5 +5 -4 mlton/mlton/ast/int-size.sig
Index: int-size.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/int-size.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- int-size.sig 3 Mar 2004 17:54:42 -0000 1.4
+++ int-size.sig 4 Apr 2004 06:50:14 -0000 1.5
@@ -8,15 +8,16 @@
sig
include INT_SIZE_STRUCTS
- eqtype t
+ type t
val all: t list
- val bits: t -> int
- val bytes: t -> int
+ val bits: t -> Bits.t
+ val bytes: t -> Bytes.t
val cardinality: t -> IntInf.t
+ val compare: t * t -> Relation.t
val default: t
val equals: t * t -> bool
- val I : int -> t
+ val I : Bits.t -> t
val isInRange: t * IntInf.t -> bool
val layout: t -> Layout.t
val max: t -> IntInf.t
1.21 +2 -2 mlton/mlton/ast/prim-tycons.fun
Index: prim-tycons.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/prim-tycons.fun,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- prim-tycons.fun 18 Mar 2004 03:22:21 -0000 1.20
+++ prim-tycons.fun 4 Apr 2004 06:50:14 -0000 1.21
@@ -37,7 +37,7 @@
local
fun 'a make (prefix: string,
all: 'a list,
- bits: 'a -> int,
+ bits: 'a -> Bits.t,
default: 'a,
equalsA: 'a * 'a -> bool,
memo: ('a -> t) -> ('a -> t),
@@ -46,7 +46,7 @@
val all =
Vector.fromListMap
(all, fn s =>
- (fromString (concat [prefix, Int.toString (bits s)]), s))
+ (fromString (concat [prefix, Bits.toString (bits s)]), s))
val fromSize =
memo
(fn s =>
1.4 +11 -7 mlton/mlton/ast/real-size.fun
Index: real-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/real-size.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- real-size.fun 5 Mar 2004 03:50:51 -0000 1.3
+++ real-size.fun 4 Apr 2004 06:50:14 -0000 1.4
@@ -9,6 +9,12 @@
val default = R64
+val compare =
+ fn (R32, R32) => EQUAL
+ | (R32, _) => LESS
+ | (R64, R64) => EQUAL
+ | _ => GREATER
+
val equals: t * t -> bool = op =
val memoize: (t -> 'a) -> t -> 'a =
@@ -27,12 +33,10 @@
val layout = Layout.str o toString
-val bytes: t -> int =
- fn R32 => 4
- | R64 => 8
-
-val bits: t -> int =
- fn R32 => 32
- | R64 => 64
+val bytes: t -> Bytes.t =
+ fn R32 => Bytes.fromInt 4
+ | R64 => Bytes.fromInt 8
+
+val bits: t -> Bits.t = Bytes.toBits o bytes
end
1.5 +3 -2 mlton/mlton/ast/real-size.sig
Index: real-size.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/real-size.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- real-size.sig 18 Mar 2004 03:22:21 -0000 1.4
+++ real-size.sig 4 Apr 2004 06:50:14 -0000 1.5
@@ -11,8 +11,9 @@
datatype t = R32 | R64
val all: t list
- val bits: t -> int
- val bytes: t -> int
+ val bits: t -> Bits.t
+ val bytes: t -> Bytes.t
+ val compare: t * t -> Relation.t
val default: t
val equals: t * t -> bool
val layout: t -> Layout.t
1.9 +25 -25 mlton/mlton/ast/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/sources.cm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- sources.cm 5 Feb 2004 06:11:40 -0000 1.8
+++ sources.cm 4 Apr 2004 06:50:14 -0000 1.9
@@ -37,38 +37,38 @@
../../lib/mlton/sources.cm
../control/sources.cm
-admits-equality.fun
admits-equality.sig
-ast-atoms.fun
-ast-atoms.sig
-ast-const.fun
+admits-equality.fun
+wrapped.sig
ast-const.sig
-ast-core.fun
-ast-core.sig
-ast-id.fun
+ast-const.fun
+symbol.sig
+symbol.fun
ast-id.sig
-ast.fun
-ast.sig
-field.fun
+ast-id.fun
field.sig
-int-size.fun
+field.fun
int-size.sig
-longid.fun
+int-size.fun
longid.sig
-prim-cons.fun
+longid.fun
prim-cons.sig
-prim-tycons.fun
-prim-tycons.sig
-real-size.fun
+prim-cons.fun
real-size.sig
-record.fun
-record.sig
-symbol.fun
-symbol.sig
-tycon-kind.fun
+real-size.fun
+word-size.sig
+word-size.fun
tycon-kind.sig
-tyvar.fun
+tycon-kind.fun
+prim-tycons.sig
+prim-tycons.fun
+record.sig
+record.fun
tyvar.sig
-word-size.fun
-word-size.sig
-wrapped.sig
+tyvar.fun
+ast-atoms.sig
+ast-atoms.fun
+ast-core.sig
+ast-core.fun
+ast.sig
+ast.fun
1.9 +43 -33 mlton/mlton/ast/word-size.fun
Index: word-size.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/word-size.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- word-size.fun 16 Mar 2004 01:05:51 -0000 1.8
+++ word-size.fun 4 Apr 2004 06:50:14 -0000 1.9
@@ -3,54 +3,60 @@
open S
-datatype t = T of {bits: int}
+datatype t = T of Bits.t
-fun bits (T {bits, ...}) = bits
+fun bits (T b) = b
-val toString = Int.toString o bits
+val toString = Bits.toString o bits
val layout = Layout.str o toString
-val equals: t * t -> bool = op =
+fun compare (s, s') = Bits.compare (bits s, bits s')
-val sizes: int list =
- List.tabulate (31, fn i => i + 2)
- @ [64]
+val {equals, ...} = Relation.compare compare
+
+fun fromBits (b: Bits.t): t =
+ if Bits.>= (b, Bits.zero)
+ then T b
+ else Error.bug (concat ["strange word size: ", Bits.toString b])
fun isValidSize (i: int) =
- (2 <= i andalso i <= 32) orelse i = 64
+ (1 <= i andalso i <= 32) orelse i = 64
+
+val all: t list =
+ Vector.toList
+ (Vector.keepAllMap
+ (Vector.tabulate (65, fn i => if isValidSize i
+ then SOME (fromBits (Bits.fromInt i))
+ else NONE),
+ fn so => so))
-fun make i = T {bits = i}
+val one = fromBits (Bits.fromInt 1)
+
+val byte = fromBits (Bits.fromInt 8)
val allVector = Vector.tabulate (65, fn i =>
if isValidSize i
- then SOME (make i)
+ then SOME (fromBits (Bits.fromInt i))
else NONE)
-fun W i =
- case Vector.sub (allVector, i) handle Subscript => NONE of
- NONE => Error.bug (concat ["strange word size: ", Int.toString i])
- | SOME s => s
+val prims = List.map ([8, 16, 32, 64], fromBits o Bits.fromInt)
-val all = List.map (sizes, W)
+val default = fromBits Bits.inWord
-val prims = [W 8, W 16, W 32, W 64]
-
-val default = W 32
-
-fun pointer () = W 32
+fun pointer () = fromBits Bits.inWord
val memoize: (t -> 'a) -> t -> 'a =
fn f =>
let
val v = Vector.map (allVector, fn opt => Option.map (opt, f))
in
- fn T {bits = i, ...} => valOf (Vector.sub (v, i))
+ fn s => valOf (Vector.sub (v, Bits.toInt (bits s)))
end
fun roundUpToPrim s =
let
- val bits = bits s
+ val bits = Bits.toInt (bits s)
val bits =
if bits <= 8
then 8
@@ -60,28 +66,32 @@
then 32
else if bits = 64
then 64
- else Error.bug "IntSize.roundUpToPrim"
+ else Error.bug "WordSize.roundUpToPrim"
in
- W bits
+ fromBits (Bits.fromInt bits)
end
-val bytes: t -> int = memoize (fn s => bits (roundUpToPrim s) div 8)
+val bytes: t -> Bytes.t = Bits.toBytes o bits
-val max: t -> IntInf.t =
- memoize (fn s => IntInf.<< (1, Word.fromInt (bits s)) - 1)
-
-val cardinality = memoize (fn s => IntInf.pow (2, bits s))
+fun cardinality s = IntInf.<< (1, Bits.toWord (bits s))
+fun max s = cardinality s - 1
+
datatype prim = W8 | W16 | W32 | W64
-val primOpt = memoize (fn T {bits, ...} =>
- List.peekMap ([(8, W8), (16, W16), (32, W32), (64, W64)],
- fn (b, p) =>
- if b = bits then SOME p else NONE))
+fun primOpt (s: t): prim option =
+ let
+ val b = Bits.toInt (bits s)
+ in
+ List.peekMap ([(8, W8), (16, W16), (32, W32), (64, W64)],
+ fn (b', p) => if b = b' then SOME p else NONE)
+ end
fun prim s =
case primOpt s of
NONE => Error.bug "WordSize.prim"
| SOME p => p
+fun s + s' = fromBits (Bits.+ (bits s, bits s'))
+
end
1.8 +10 -6 mlton/mlton/ast/word-size.sig
Index: word-size.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/word-size.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- word-size.sig 18 Mar 2004 03:22:21 -0000 1.7
+++ word-size.sig 4 Apr 2004 06:50:14 -0000 1.8
@@ -8,22 +8,26 @@
sig
include WORD_SIZE_STRUCTS
- eqtype t
-
+ type t
+
+ val + : t * t -> t
val all: t list
- val bits: t -> int
- val bytes: t -> int
+ val bits: t -> Bits.t
+ val bytes: t -> Bytes.t
+ val byte: t
val cardinality: t -> IntInf.t
+ val compare: t * t -> Relation.t
val default: t
- val equals: t * t -> bool
+ val equals: t * t -> bool
+ val fromBits: Bits.t -> t
val layout: t -> Layout.t
val max: t -> IntInf.t
val memoize: (t -> 'a) -> t -> 'a
+ val one: t
val pointer: unit -> t
datatype prim = W8 | W16 | W32 | W64
val prim: t -> prim
val prims: t list
val roundUpToPrim: t -> t
val toString: t -> string
- val W: int -> t
end
1.14 +29 -4 mlton/mlton/atoms/atoms.fun
Index: atoms.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- atoms.fun 6 Feb 2004 23:55:36 -0000 1.13
+++ atoms.fun 4 Apr 2004 06:50:14 -0000 1.14
@@ -1,10 +1,11 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+
functor Atoms (S: ATOMS_STRUCTS): ATOMS =
struct
@@ -12,6 +13,8 @@
struct
open S
+ structure PointerTycon = PointerTycon ()
+ structure ProfileLabel = ProfileLabel ()
structure SourceInfo = SourceInfo ()
structure ProfileExp = ProfileExp (structure SourceInfo = SourceInfo)
structure Var = Var ()
@@ -22,22 +25,44 @@
structure CType = CType (structure IntSize = IntSize
structure RealSize = RealSize
structure WordSize = WordSize)
- structure CFunction = CFunction (structure CType = CType)
- structure Ffi = Ffi (structure CFunction = CFunction
- structure CType = CType)
structure IntX = IntX (structure IntSize = IntSize)
structure RealX = RealX (structure RealSize = RealSize)
structure WordX = WordX (structure WordSize = WordSize)
+ structure Runtime = Runtime (structure CType = CType)
+ structure Func =
+ struct
+ open Var
+ fun newNoname () = newString "F"
+ end
+ structure Label =
+ struct
+ open Func
+ fun newNoname () = newString "L"
+ end
structure Const = Const (structure IntX = IntX
structure RealX = RealX
structure WordX = WordX)
+ structure RepType = RepType (structure CType = CType
+ structure IntSize = IntSize
+ structure IntX = IntX
+ structure Label = Label
+ structure PointerTycon = PointerTycon
+ structure RealSize = RealSize
+ structure Runtime = Runtime
+ structure WordSize = WordSize
+ structure WordX = WordX)
+ structure CFunction = CFunction (structure RepType = RepType)
structure Prim = Prim (structure CFunction = CFunction
structure CType = CType
structure Con = Con
structure Const = Const
structure IntSize = IntSize
structure RealSize = RealSize
+ structure RepType = RepType
structure WordSize = WordSize)
+ structure Ffi = Ffi (structure CFunction = CFunction
+ structure CType = CType)
+ structure ObjectType = RepType.ObjectType
structure Tyvars = UnorderedSet (Tyvar)
structure Vars = UnorderedSet (Var)
structure Cons = UnorderedSet (Con)
1.15 +36 -15 mlton/mlton/atoms/atoms.sig
Index: atoms.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/atoms.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- atoms.sig 6 Feb 2004 23:55:36 -0000 1.14
+++ atoms.sig 4 Apr 2004 06:50:14 -0000 1.15
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -27,10 +27,17 @@
structure Cons: SET
structure Const: CONST
structure Ffi: FFI
+ structure Func: FUNC
structure IntX: INT_X
- structure Prim: PRIM
+ structure Label: LABEL
+ structure ObjectType: OBJECT_TYPE
+ structure PointerTycon: POINTER_TYCON
+ structure Prim: PRIM
+ structure ProfileLabel: PROFILE_LABEL
+ structure RepType: REP_TYPE
structure ProfileExp: PROFILE_EXP
structure RealX: REAL_X
+ structure Runtime: RUNTIME
structure SourceInfo: SOURCE_INFO
structure Tycon: TYCON
structure Tycons: SET
@@ -40,24 +47,24 @@
structure WordX: WORD_X
sharing CFunction = Ffi.CFunction = Prim.CFunction
- sharing CFunction.CType = CType = Ffi.CType = Prim.CType
+ sharing CType = Ffi.CType = Prim.CType = RepType.CType
sharing Con = Prim.Con
sharing Const = Prim.Const
- sharing Field = Record.Field = SortedRecord.Field
- sharing IntSize = CType.IntSize = IntX.IntSize = Prim.IntSize =
- Tycon.IntSize
- sharing IntX = Const.IntX
- sharing RealSize = CType.RealSize = Prim.RealSize = RealX.RealSize
+ sharing IntSize = IntX.IntSize = Prim.IntSize = RepType.IntSize
+ = Tycon.IntSize
+ sharing IntX = Const.IntX = RepType.IntX
+ sharing Label = RepType.Label
+ sharing ObjectType = RepType.ObjectType
+ sharing PointerTycon = ObjectType.PointerTycon = RepType.PointerTycon
+ sharing RealSize = Prim.RealSize = RealX.RealSize = RepType.RealSize
= Tycon.RealSize
+ sharing RepType = CFunction.RepType = Prim.RepType
sharing RealX = Const.RealX
+ sharing Runtime = ObjectType.Runtime = RepType.Runtime
sharing SourceInfo = ProfileExp.SourceInfo
- sharing WordSize = CType.WordSize = Prim.WordSize = Tycon.WordSize
+ sharing WordSize = Prim.WordSize = RepType.WordSize = Tycon.WordSize
= WordX.WordSize
- sharing WordX = Const.WordX
- sharing type Con.t = Cons.Element.t
- sharing type Tycon.t = Tycons.Element.t
- sharing type Tyvar.t = Tyvars.Element.t
- sharing type Var.t = Vars.Element.t
+ sharing WordX = Const.WordX = RepType.WordX
end
signature ATOMS =
@@ -66,6 +73,14 @@
include ATOMS'
+ (* For each structure, like CFunction, I would like to write two sharing
+ * constraints
+ * sharing Atoms = CFunction
+ * sharing CFunction = Atoms.CFunction
+ * but I can't because of a bug in SML/NJ that reports "Sharing structure
+ * with a descendent substructure". So, I am forced to write out lots
+ * of individual sharing constraints. Blech.
+ *)
sharing CFunction = Atoms.CFunction
sharing CType = Atoms.CType
sharing Con = Atoms.Con
@@ -73,16 +88,22 @@
sharing Const = Atoms.Const
sharing Ffi = Atoms.Ffi
sharing Field = Atoms.Field
+ sharing Func = Atoms.Func
sharing IntSize = Atoms.IntSize
sharing IntX = Atoms.IntX
+ sharing Label = Atoms.Label
+ sharing ObjectType = Atoms.ObjectType
+ sharing PointerTycon = Atoms.PointerTycon
sharing Prim = Atoms.Prim
+ sharing ProfileLabel = Atoms.ProfileLabel
sharing ProfileExp = Atoms.ProfileExp
sharing RealSize = Atoms.RealSize
sharing RealX = Atoms.RealX
sharing Record = Atoms.Record
+ sharing RepType = Atoms.RepType
+ sharing Runtime = Atoms.Runtime
sharing SortedRecord = Atoms.SortedRecord
sharing SourceInfo = Atoms.SourceInfo
-(* sharing Symbol = Con.Symbol = Tycon.Symbol = Var.Symbol *)
sharing Tycon = Atoms.Tycon
sharing Tycons = Atoms.Tycons
sharing Tyvar = Atoms.Tyvar
1.5 +49 -36 mlton/mlton/atoms/c-function.fun
Index: c-function.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- c-function.fun 5 Mar 2004 03:50:52 -0000 1.4
+++ c-function.fun 4 Apr 2004 06:50:14 -0000 1.5
@@ -3,6 +3,17 @@
open S
+structure Type = RepType
+structure CType = Type.CType
+
+local
+ open Type
+in
+ structure IntSize = IntSize
+ structure RealSize = RealSize
+ structure WordSize = WordSize
+end
+
structure Convention =
struct
datatype t =
@@ -16,7 +27,7 @@
val layout = Layout.str o toString
end
-datatype t = T of {args: CType.t vector,
+datatype t = T of {args: Type.t vector,
bytesNeeded: int option,
convention: Convention.t,
ensuresBytesFree: bool,
@@ -25,13 +36,13 @@
modifiesFrontier: bool,
modifiesStackTop: bool,
name: string,
- return: CType.t option}
+ return: Type.t}
fun layout (T {args, bytesNeeded, convention, ensuresBytesFree, mayGC,
maySwitchThreads, modifiesFrontier, modifiesStackTop, name,
- return}) =
+ return, ...}) =
Layout.record
- [("args", Vector.layout CType.layout args),
+ [("args", Vector.layout Type.layout args),
("bytesNeeded", Option.layout Int.layout bytesNeeded),
("convention", Convention.layout convention),
("ensuresBytesFree", Bool.layout ensuresBytesFree),
@@ -40,8 +51,8 @@
("modifiesFrontier", Bool.layout modifiesFrontier),
("modifiesStackTop", Bool.layout modifiesStackTop),
("name", String.layout name),
- ("return", Option.layout CType.layout return)]
-
+ ("return", Type.layout return)]
+
local
fun make f (T r) = f r
in
@@ -61,7 +72,7 @@
fun isOk (T {ensuresBytesFree, mayGC, maySwitchThreads, modifiesFrontier,
modifiesStackTop, return, ...}): bool =
(if maySwitchThreads
- then mayGC andalso Option.isNone return
+ then mayGC andalso RepType.isUnit return
else true)
andalso
(if ensuresBytesFree orelse maySwitchThreads
@@ -77,23 +88,28 @@
val equals =
Trace.trace2 ("CFunction.equals", layout, layout, Bool.layout) equals
-datatype z = datatype CType.t
datatype z = datatype Convention.t
+
local
- open CType
+ open Type
in
- val Int32 = Int (IntSize.I 32)
- val Word32 = Word (WordSize.W 32)
+ val Int32 = int (IntSize.I (Bits.fromInt 32))
+ val Word32 = word (Bits.fromInt 32)
+ val bool = bool
+ val cPointer = cPointer
+ val gcState = gcState
+ val string = word8Vector
+ val unit = unit
end
-
+
local
fun make b =
T {args = let
- open CType
+ open Type
in
- Vector.new5 (Pointer, Word32, Int32, Pointer, Int32)
+ Vector.new5 (gcState, Word32, bool, cPointer (), Int32)
end,
- bytesNeeded = NONE,
+ bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = true,
mayGC = true,
@@ -101,7 +117,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_gc",
- return = NONE}
+ return = unit}
val t = make true
val f = make false
in
@@ -123,30 +139,26 @@
val allocTooLarge =
vanilla {args = Vector.new0 (),
name = "MLton_allocTooLarge",
- return = NONE}
+ return = unit}
-val bug = vanilla {args = Vector.new1 Pointer,
+val bug = vanilla {args = Vector.new1 string,
name = "MLton_bug",
- return = NONE}
-
+ return = unit}
+
val profileEnter =
- vanilla {args = Vector.new1 Pointer,
+ vanilla {args = Vector.new1 gcState,
name = "GC_profileEnter",
- return = NONE}
+ return = unit}
+
val profileInc =
- vanilla {args = Vector.new2 (Pointer, Word32),
+ vanilla {args = Vector.new2 (gcState, Word32),
name = "GC_profileInc",
- return = NONE}
+ return = unit}
val profileLeave =
- vanilla {args = Vector.new1 Pointer,
+ vanilla {args = Vector.new1 gcState,
name = "GC_profileLeave",
- return = NONE}
-
-val size =
- vanilla {args = Vector.new1 Pointer,
- name = "MLton_size",
- return = SOME CType.defaultInt}
+ return = unit}
val returnToC =
T {args = Vector.new0 (),
@@ -158,16 +170,17 @@
mayGC = true,
maySwitchThreads = true,
name = "Thread_returnToC",
- return = NONE}
+ return = unit}
fun prototype (T {args, convention, name, return, ...}) =
let
val c = Counter.new 0
- fun arg t = concat [CType.toString t, " x", Int.toString (Counter.next c)]
+ fun arg t = concat [CType.toString (Type.toCType t),
+ " x", Int.toString (Counter.next c)]
in
- concat [case return of
- NONE => "void"
- | SOME t => CType.toString t,
+ concat [if Type.isUnit return
+ then "void"
+ else CType.toString (Type.toCType return),
if convention <> Convention.Cdecl
then concat [" __attribute__ ((",
Convention.toString convention,
1.2 +14 -9 mlton/mlton/atoms/c-function.sig
Index: c-function.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-function.sig,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- c-function.sig 19 Jul 2003 01:23:26 -0000 1.1
+++ c-function.sig 4 Apr 2004 06:50:14 -0000 1.2
@@ -1,8 +1,15 @@
+(* Copyright (C) 2004 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
signature C_FUNCTION_STRUCTS =
sig
- structure CType: C_TYPE
+ structure RepType: REP_TYPE
end
signature C_FUNCTION =
@@ -17,8 +24,7 @@
val toString: t -> string
end
- datatype t = T of {
- args: CType.t vector,
+ datatype t = T of {args: RepType.t vector,
(* bytesNeeded = SOME i means that the i'th
* argument to the function is a word that
* specifies the number of bytes that must be
@@ -34,10 +40,10 @@
modifiesFrontier: bool,
modifiesStackTop: bool,
name: string,
- return: CType.t option}
+ return: RepType.t}
val allocTooLarge: t
- val args: t -> CType.t vector
+ val args: t -> RepType.t vector
val bug: t
val bytesNeeded: t -> int option
val ensuresBytesFree: t -> bool
@@ -54,15 +60,14 @@
val profileInc: t
val profileLeave: t
val prototype: t -> string
+ val return: t -> RepType.t
(* returnToC is not really a C function. Calls to it must be handled
* specially by each codegen to ensure that the C stack is handled
* correctly. However, for the purposes of everything up to the
* backend it looks like a call to C.
*)
val returnToC: t
- val return: t -> CType.t option
- val size: t
- val vanilla: {args: CType.t vector,
+ val vanilla: {args: RepType.t vector,
name: string,
- return: CType.t option} -> t
+ return: RepType.t} -> t
end
1.4 +49 -65 mlton/mlton/atoms/c-type.fun
Index: c-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- c-type.fun 5 Mar 2004 03:50:52 -0000 1.3
+++ c-type.fun 4 Apr 2004 06:50:14 -0000 1.4
@@ -4,85 +4,69 @@
open S
datatype t =
- Int of IntSize.t
- | Pointer
- | Real of RealSize.t
- | Word of WordSize.t
-
-val bool = Int (IntSize.I 32)
-val char = Word (WordSize.W 8)
-val defaultInt = Int IntSize.default
-val defaultReal = Real RealSize.default
-val defaultWord = Word WordSize.default
-val pointer = Pointer
-
-val all =
- List.map (IntSize.prims, Int)
- @ [Pointer]
- @ List.map (RealSize.all, Real)
- @ List.map (WordSize.prims, Word)
-
-val equals: t * t -> bool =
- fn (Int s, Int s') => IntSize.equals (s, s')
- | (Pointer, Pointer) => true
- | (Real s, Real s') => RealSize.equals (s, s')
- | (Word s, Word s') => WordSize.equals (s, s')
- | _ => false
-
-val isPointer: t -> bool =
- fn Pointer => true
- | _ => false
+ Pointer
+ | Real32
+ | Real64
+ | Word8
+ | Word16
+ | Word32
+ | Word64
+
+val all = [Pointer, Real32, Real64, Word8, Word16, Word32, Word64]
+
+val equals: t * t -> bool = op =
fun memo (f: t -> 'a): t -> 'a =
let
- val int = IntSize.memoize (f o Int)
val pointer = f Pointer
- val real = RealSize.memoize (f o Real)
- val word = WordSize.memoize (f o Word)
+ val real32 = f Real32
+ val real64 = f Real64
+ val word8 = f Word8
+ val word16 = f Word16
+ val word32 = f Word32
+ val word64 = f Word64
in
- fn Int s => int s
- | Pointer => pointer
- | Real s => real s
- | Word s => word s
+ fn Pointer => pointer
+ | Real32 => real32
+ | Real64 => real64
+ | Word8 => word8
+ | Word16 => word16
+ | Word32 => word32
+ | Word64 => word64
end
val toString =
- memo
- (fn u =>
- case u of
- Int s => concat ["Int", IntSize.toString s]
- | Pointer => "Pointer"
- | Real s => concat ["Real", RealSize.toString s]
- | Word s => concat ["Word", WordSize.toString s])
+ fn Pointer => "Pointer"
+ | Real32 => "Real32"
+ | Real64 => "Real64"
+ | Word8 => "Word8"
+ | Word16 => "Word16"
+ | Word32 => "Word32"
+ | Word64 => "Word64"
val layout = Layout.str o toString
-fun size (t: t): int =
+fun size (t: t): Bytes.t =
case t of
- Int s => IntSize.bytes s
- | Pointer => 4
- | Real s => RealSize.bytes s
- | Word s => WordSize.bytes s
+ Pointer => Bytes.inPointer
+ | Real32 => Bytes.fromInt 4
+ | Real64 => Bytes.fromInt 8
+ | Word8 => Bytes.fromInt 1
+ | Word16 => Bytes.fromInt 2
+ | Word32 => Bytes.fromInt 4
+ | Word64 => Bytes.fromInt 8
fun name t =
case t of
- Int s => concat ["I", IntSize.toString s]
- | Pointer => "P"
- | Real s => concat ["R", RealSize.toString s]
- | Word s => concat ["W", WordSize.toString s]
-
-local
- fun align a b =
- let
- open Word
- val a = fromInt a - 0w1
- in
- toInt (andb (notb a, a + fromInt b))
- end
-in
- val align4 = align 4
- val align8 = align 8
- val align: t * int -> int = fn (ty, n) => align (size ty) n
-end
+ Pointer => "P"
+ | Real32 => "R32"
+ | Real64 => "R64"
+ | Word8 => "W8"
+ | Word16 => "W16"
+ | Word32 => "W32"
+ | Word64 => "W64"
+
+fun align (t: t, b: Bytes.t): Bytes.t =
+ Bytes.align (b, {alignment = size t})
end
1.4 +11 -20 mlton/mlton/atoms/c-type.sig
Index: c-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/c-type.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- c-type.sig 9 Oct 2003 18:17:31 -0000 1.3
+++ c-type.sig 4 Apr 2004 06:50:14 -0000 1.4
@@ -2,37 +2,28 @@
signature C_TYPE_STRUCTS =
sig
- structure IntSize: INT_SIZE
- structure RealSize: REAL_SIZE
- structure WordSize: WORD_SIZE
end
signature C_TYPE =
sig
include C_TYPE_STRUCTS
-
+
datatype t =
- Int of IntSize.t
- | Pointer
- | Real of RealSize.t
- | Word of WordSize.t
+ Pointer
+ | Real32
+ | Real64
+ | Word8
+ | Word16
+ | Word32
+ | Word64
- val align4: int -> int
- val align8: int -> int
- val align: t * int -> int (* align an address *)
+ val align: t * Bytes.t -> Bytes.t
val all: t list
- val bool: t
- val char: t
- val defaultInt: t
- val defaultReal: t
- val defaultWord: t
val equals: t * t -> bool
- val isPointer: t -> bool
val memo: (t -> 'a) -> t -> 'a
- (* name: R{32,64} I[8,16,32,64] P W[8,16,32,64] *)
+ (* name: R{32,64} W{8,16,32,64} *)
val name: t -> string
- val pointer: t
val layout: t -> Layout.t
- val size: t -> int (* bytes *)
+ val size: t -> Bytes.t
val toString: t -> string
end
1.11 +1 -1 mlton/mlton/atoms/const.sig
Index: const.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/const.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- const.sig 18 Mar 2004 03:22:22 -0000 1.10
+++ const.sig 4 Apr 2004 06:50:14 -0000 1.11
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.7 +7 -0 mlton/mlton/atoms/ffi.fun
Index: ffi.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.fun,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ffi.fun 2 Dec 2003 03:59:07 -0000 1.6
+++ ffi.fun 4 Apr 2004 06:50:14 -0000 1.7
@@ -1,3 +1,10 @@
+(* Copyright (C) 2004 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 Ffi (S: FFI_STRUCTS): FFI =
struct
1.5 +8 -1 mlton/mlton/atoms/ffi.sig
Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ffi.sig 18 Mar 2004 03:22:22 -0000 1.4
+++ ffi.sig 4 Apr 2004 06:50:14 -0000 1.5
@@ -1,10 +1,17 @@
+(* Copyright (C) 2004 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
signature FFI_STRUCTS =
sig
structure CFunction: C_FUNCTION
structure CType: C_TYPE
- sharing CFunction.CType = CType
+ sharing CType = CFunction.RepType.CType
end
signature FFI =
1.11 +133 -1 mlton/mlton/atoms/hash-type.fun
Index: hash-type.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- hash-type.fun 19 Feb 2004 22:42:09 -0000 1.10
+++ hash-type.fun 4 Apr 2004 06:50:14 -0000 1.11
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -204,5 +204,137 @@
var = fn _ => false,
con = fn (tycon', bs) => (Tycon.equals (tycon, tycon')
orelse Vector.exists (bs, fn b => b))}
+
+structure P = PointerTycon
+
+fun fromRepType (t: RepType.t): t =
+ let
+ fun bug () = Error.bug (concat ["Type.fromRepType: ", RepType.toString t])
+ datatype z = datatype RepType.dest
+ in
+ case RepType.dest t of
+ Int s => int s
+ | Real s => real s
+ | Pointer p =>
+ (case List.peek ([(P.thread, thread),
+ (P.word8Vector, word8Vector)],
+ fn (p', _) => P.equals (p, p')) of
+ NONE => bug ()
+ | SOME (_, t) => t)
+ | Seq ts => if 0 = Vector.length ts then unit else bug ()
+ | Sum _ => if RepType.isBool t then bool else bug ()
+ | Word s => word (WordSize.fromBits s)
+ | _ => bug ()
+ end
+
+val fromRepType =
+ Trace.trace ("Type.fromRepType", RepType.layout, layout) fromRepType
+
+local
+ val {get, set, ...} =
+ Property.getSetOnce (Tycon.plist, Property.initConst NONE)
+ val () =
+ List.foreach ([Tycon.array, Tycon.reff, Tycon.vector], fn t =>
+ set (t, SOME (RepType.cPointer ())))
+ fun doit (ts, f) = Vector.foreach (ts, fn (c, s) => set (c, SOME (f s)))
+ val () = doit (Tycon.ints, RepType.int)
+ val () = doit (Tycon.reals, RepType.real)
+ val () = set (Tycon.thread, SOME RepType.thread)
+ val () = doit (Tycon.words, RepType.word o WordSize.bits)
+in
+ fun toRepType (t: t): RepType.t =
+ let
+ fun bug () = Error.bug (concat ["Type.toRepType: ", toString t])
+ in
+ case dest t of
+ Con (c, _) =>
+ (case get c of
+ NONE => bug ()
+ | SOME t => t)
+ | Var _ => bug ()
+ end
+end
+
+fun checkPrimApp {args, prim, result}: bool =
+ let
+ fun check () =
+ case Prim.typeCheck (prim, Vector.map (args, toRepType)) of
+ NONE => false
+ | SOME t => equals (result, fromRepType t)
+ datatype z = datatype Prim.Name.t
+ in
+ case Prim.name prim of
+ Array_array => true
+ | Array_array0Const => true
+ | Array_length => true
+ | Array_sub => true
+ | Array_toVector => true
+ | Array_update => true
+ | Exn_extra => true
+ | Exn_name => true
+ | Exn_setExtendExtra => true
+ | Exn_setInitExtra => true
+ | Exn_setTopLevelHandler => true
+ | GC_collect => true
+ | GC_pack => true
+ | GC_unpack => true
+ | IntInf_add => true
+ | IntInf_andb => true
+ | IntInf_arshift => true
+ | IntInf_compare => true
+ | IntInf_equal => true
+ | IntInf_gcd => true
+ | IntInf_lshift => true
+ | IntInf_mul => true
+ | IntInf_neg => true
+ | IntInf_notb => true
+ | IntInf_orb => true
+ | IntInf_quot => true
+ | IntInf_rem => true
+ | IntInf_sub => true
+ | IntInf_toString => true
+ | IntInf_toVector => true
+ | IntInf_toWord => true
+ | IntInf_xorb => true
+ | MLton_bogus => true
+ | MLton_bug => true
+ | MLton_eq => true
+ | MLton_equal => true
+ | MLton_halt => true
+ | MLton_handlesSignals => true
+ | MLton_installSignalHandler => true
+ | MLton_size => true
+ | MLton_touch => true
+ | Pointer_getInt _ => true
+ | Pointer_getPointer => true
+ | Pointer_getReal _ => true
+ | Pointer_getWord _ => true
+ | Pointer_setInt _ => true
+ | Pointer_setPointer => true
+ | Pointer_setReal _ => true
+ | Pointer_setWord _ => true
+ | Ref_assign => true
+ | Ref_deref => true
+ | Ref_ref => true
+ | Thread_atomicBegin => true
+ | Thread_atomicEnd => true
+ | Thread_canHandle => true
+ | Thread_copy => true
+ | Thread_copyCurrent => true
+ | Thread_returnToC => true
+ | Thread_switchTo => true
+ | Vector_length => true
+ | Vector_sub => true
+ | Weak_canGet => true
+ | Weak_get => true
+ | Weak_new => true
+ | Word_toIntInf => true
+ | WordVector_toIntInf => true
+ | Word8Array_subWord => true
+ | Word8Array_updateWord => true
+ | Word8Vector_subWord => true
+ | World_save => true
+ | _ => check ()
+ end
end
1.6 +6 -3 mlton/mlton/atoms/hash-type.sig
Index: hash-type.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/hash-type.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- hash-type.sig 9 Oct 2003 18:17:31 -0000 1.5
+++ hash-type.sig 4 Apr 2004 06:50:14 -0000 1.6
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -22,11 +22,14 @@
structure Dest:
sig
datatype dest =
- Var of Tyvar.t
- | Con of Tycon.t * t vector
+ Con of Tycon.t * t vector
+ | Var of Tyvar.t
val dest: t -> dest
end
+ val checkPrimApp: {args: t vector,
+ prim: Prim.t,
+ result: t} -> bool
val containsTycon: t * Tycon.t -> bool
(* O(1) time *)
val equals: t * t -> bool
1.12 +1 -1 mlton/mlton/atoms/id.fun
Index: id.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.fun,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- id.fun 6 Feb 2004 23:00:30 -0000 1.11
+++ id.fun 4 Apr 2004 06:50:14 -0000 1.12
@@ -48,7 +48,7 @@
val hash = make #hash
val originalName = make #originalName
val plist = make #plist
- val printName= make #printName
+ val printName = make #printName
end
fun clearPrintName x = printName x := NONE
1.10 +1 -1 mlton/mlton/atoms/id.sig
Index: id.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- id.sig 18 Mar 2004 03:22:22 -0000 1.9
+++ id.sig 4 Apr 2004 06:50:14 -0000 1.10
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.6 +1 -1 mlton/mlton/atoms/int-x.fun
Index: int-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/int-x.fun,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- int-x.fun 3 Mar 2004 02:08:59 -0000 1.5
+++ int-x.fun 4 Apr 2004 06:50:14 -0000 1.6
@@ -15,7 +15,7 @@
fun equals (T {int = i, size = s, ...},
T {int = i', size = s', ...}) =
- i = i' andalso s = s'
+ i = i' andalso IntSize.equals (s, s')
fun toString (T {int = i, ...}) = IntInf.toString i
1.75 +1170 -579 mlton/mlton/atoms/prim.fun
Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -r1.74 -r1.75
--- prim.fun 16 Mar 2004 01:06:49 -0000 1.74
+++ prim.fun 4 Apr 2004 06:50:14 -0000 1.75
@@ -1,22 +1,22 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+
(*
- * If you add new primitives, you may need to modify backend/machine.fun.
- * If you add new polymorphic primitives, you should also modify the
- * extractTargs function.
+ * If you add new polymorphic primitives, you must modify extractTargs.
*)
+
functor Prim (S: PRIM_STRUCTS): PRIM =
struct
open S
-datatype z = datatype RealSize.t
-
+type word = Word.t
+
local
open Const
in
@@ -33,573 +33,982 @@
| SideEffect
end
-structure Name =
- struct
- datatype t =
- Array_array (* backend *)
- | Array_array0Const (* constant propagation *)
- | Array_length (* ssa to rssa *)
- | Array_sub (* backend *)
- | Array_toVector (* backend *)
- | Array_update (* backend *)
- | Char_toWord8 (* type inference *)
- | Exn_extra (* implement exceptions *)
- | Exn_keepHistory (* a compile-time boolean *)
- | Exn_name (* implement exceptions *)
- | Exn_setExtendExtra (* implement exceptions *)
- | Exn_setInitExtra (* implement exceptions *)
- | Exn_setTopLevelHandler (* implement exceptions *)
- | FFI of CFunction.t (* ssa to rssa *)
- | FFI_Symbol of {name: string,
- ty: CType.t} (* codegen *)
- | GC_collect (* ssa to rssa *)
- | GC_pack (* ssa to rssa *)
- | GC_unpack (* ssa to rssa *)
- | Int_add of IntSize.t (* codegen *)
- | Int_addCheck of IntSize.t (* codegen *)
- | Int_equal of IntSize.t (* ssa to rssa / codegen *)
- | Int_ge of IntSize.t (* codegen *)
- | Int_gt of IntSize.t (* codegen *)
- | Int_le of IntSize.t (* codegen *)
- | Int_lt of IntSize.t (* codegen *)
- | Int_mul of IntSize.t (* codegen *)
- | Int_mulCheck of IntSize.t (* codegen *)
- | Int_neg of IntSize.t (* codegen *)
- | Int_negCheck of IntSize.t (* codegen *)
- | Int_quot of IntSize.t (* codegen *)
- | Int_rem of IntSize.t (* codegen *)
- | Int_sub of IntSize.t (* codegen *)
- | Int_subCheck of IntSize.t (* codegen *)
- | Int_toInt of IntSize.t * IntSize.t (* codegen *)
- | Int_toReal of IntSize.t * RealSize.t (* codegen *)
- | Int_toWord of IntSize.t * WordSize.t (* codegen *)
- | IntInf_add (* ssa to rssa *)
- | IntInf_andb (* ssa to rssa *)
- | IntInf_arshift (* ssa to rssa *)
- | IntInf_compare (* ssa to rssa *)
- | IntInf_equal (* ssa to rssa *)
- | IntInf_gcd (* ssa to rssa *)
- | IntInf_lshift (* ssa to rssa *)
- | IntInf_mul (* ssa to rssa *)
- | IntInf_neg (* ssa to rssa *)
- | IntInf_notb (* ssa to rssa *)
- | IntInf_orb (* ssa to rssa *)
- | IntInf_quot (* ssa to rssa *)
- | IntInf_rem (* ssa to rssa *)
- | IntInf_sub (* ssa to rssa *)
- | IntInf_toString (* ssa to rssa *)
- | IntInf_toVector (* ssa to rssa *)
- | IntInf_toWord (* ssa to rssa *)
- | IntInf_xorb (* ssa to rssa *)
- | MLton_bogus (* ssa to rssa *)
- (* of type unit -> 'a.
- * Makes a bogus value of any type.
- *)
- | MLton_bug (* ssa to rssa *)
- | MLton_deserialize (* unused *)
- | MLton_eq (* codegen *)
- | MLton_equal (* polymorphic equality *)
- | MLton_halt (* ssa to rssa *)
- (* MLton_handlesSignals and MLton_installSignalHandler work together
- * to inform the optimizer and basis library whether or not the
- * program uses signal handlers.
- *
- * MLton_installSignalHandler is called by MLton.Signal.setHandler,
- * and is effectively a noop, but is left in the program until the
- * end of the backend, so that the optimizer can test whether or
- * not the program installs signal handlers.
- *
- * MLton_handlesSignals is translated by closure conversion into
- * a boolean, and is true iff MLton_installsSignalHandler is called.
- *)
- | MLton_handlesSignals (* closure conversion *)
- | MLton_installSignalHandler (* backend *)
- | MLton_serialize (* unused *)
- | MLton_size (* ssa to rssa *)
- | MLton_touch (* backend *)
- | Pointer_getInt of IntSize.t (* backend *)
- | Pointer_getPointer (* backend *)
- | Pointer_getReal of RealSize.t (* backend *)
- | Pointer_getWord of WordSize.t (* backend *)
- | Pointer_setInt of IntSize.t (* backend *)
- | Pointer_setPointer (* backend *)
- | Pointer_setReal of RealSize.t (* backend *)
- | Pointer_setWord of WordSize.t (* backend *)
- | Real_Math_acos of RealSize.t (* codegen *)
- | Real_Math_asin of RealSize.t (* codegen *)
- | Real_Math_atan of RealSize.t (* codegen *)
- | Real_Math_atan2 of RealSize.t (* codegen *)
- | Real_Math_cos of RealSize.t (* codegen *)
- | Real_Math_exp of RealSize.t (* codegen *)
- | Real_Math_ln of RealSize.t (* codegen *)
- | Real_Math_log10 of RealSize.t (* codegen *)
- | Real_Math_sin of RealSize.t (* codegen *)
- | Real_Math_sqrt of RealSize.t (* codegen *)
- | Real_Math_tan of RealSize.t (* codegen *)
- | Real_abs of RealSize.t (* codegen *)
- | Real_add of RealSize.t (* codegen *)
- | Real_div of RealSize.t (* codegen *)
- | Real_equal of RealSize.t (* codegen *)
- | Real_ge of RealSize.t (* codegen *)
- | Real_gt of RealSize.t (* codegen *)
- | Real_ldexp of RealSize.t (* codegen *)
- | Real_le of RealSize.t (* codegen *)
- | Real_lt of RealSize.t (* codegen *)
- | Real_mul of RealSize.t (* codegen *)
- | Real_muladd of RealSize.t (* codegen *)
- | Real_mulsub of RealSize.t (* codegen *)
- | Real_neg of RealSize.t (* codegen *)
- | Real_qequal of RealSize.t (* codegen *)
- | Real_round of RealSize.t (* codegen *)
- | Real_sub of RealSize.t (* codegen *)
- | Real_toInt of RealSize.t * IntSize.t (* codegen *)
- | Real_toReal of RealSize.t * RealSize.t (* codegen *)
- | Ref_assign (* backend *)
- | Ref_deref (* backend *)
- | Ref_ref (* backend *)
- | String_toWord8Vector (* type inference *)
- | Thread_atomicBegin (* backend *)
- | Thread_atomicEnd (* backend *)
- | Thread_canHandle (* backend *)
- | Thread_copy (* ssa to rssa *)
- | Thread_copyCurrent (* ssa to rssa *)
- | Thread_returnToC (* codegen *)
- (* switchTo has to be a _prim because we have to know that it
- * enters the runtime -- because everything must be saved
- * on the stack.
- *)
- | Thread_switchTo (* ssa to rssa *)
- | Vector_length (* ssa to rssa *)
- | Vector_sub (* backend *)
- | Weak_canGet (* ssa to rssa *)
- | Weak_get (* ssa to rssa *)
- | Weak_new (* ssa to rssa *)
- | Word_add of WordSize.t (* codegen *)
- | Word_addCheck of WordSize.t (* codegen *)
- | Word_andb of WordSize.t (* codegen *)
- | Word_arshift of WordSize.t (* codegen *)
- | Word_div of WordSize.t (* codegen *)
- | Word_equal of WordSize.t (* codegen *)
- | Word_ge of WordSize.t (* codegen *)
- | Word_gt of WordSize.t (* codegen *)
- | Word_le of WordSize.t (* codegen *)
- | Word_lshift of WordSize.t (* codegen *)
- | Word_lt of WordSize.t (* codegen *)
- | Word_mod of WordSize.t (* codegen *)
- | Word_mul of WordSize.t (* codegen *)
- | Word_mulCheck of WordSize.t (* codegen *)
- | Word_neg of WordSize.t (* codegen *)
- | Word_notb of WordSize.t (* codegen *)
- | Word_orb of WordSize.t (* codegen *)
- | Word_rol of WordSize.t (* codegen *)
- | Word_ror of WordSize.t (* codegen *)
- | Word_rshift of WordSize.t (* codegen *)
- | Word_sub of WordSize.t (* codegen *)
- | Word_toInt of WordSize.t * IntSize.t (* codegen *)
- | Word_toIntInf (* ssa to rssa *)
- | Word_toIntX of WordSize.t * IntSize.t (* codegen *)
- | Word_toWord of WordSize.t * WordSize.t (* codegen *)
- | Word_toWordX of WordSize.t * WordSize.t (* codegen *)
- | Word_xorb of WordSize.t (* codegen *)
- | WordVector_toIntInf (* ssa to rssa *)
- | Word8_toChar (* type inference *)
- | Word8Array_subWord (* ssa to rssa *)
- | Word8Array_updateWord (* ssa to rssa *)
- | Word8Vector_subWord (* ssa to rssa *)
- | Word8Vector_toString (* type inference *)
- | World_save (* ssa to rssa *)
-
- val equals: t * t -> bool = op =
-
- val isCommutative =
- fn Int_add _ => true
- | Int_addCheck _ => true
- | Int_equal _ => true
- | Int_mul _ => true
- | Int_mulCheck _ => true
- | IntInf_equal => true
- | MLton_eq => true
- | MLton_equal => true
- | Real_add _ => true
- | Real_mul _ => true
- | Real_qequal _ => true
- | Word_add _ => true
- | Word_addCheck _ => true
- | Word_andb _ => true
- | Word_equal _ => true
- | Word_mul _ => true
- | Word_mulCheck _ => true
- | Word_orb _ => true
- | Word_xorb _ => true
- | _ => false
-
- val mayOverflow =
- fn Int_addCheck _ => true
- | Int_mulCheck _ => true
- | Int_negCheck _ => true
- | Int_subCheck _ => true
- | Word_addCheck _ => true
- | Word_mulCheck _ => true
- | _ => false
-
- val mayRaise = mayOverflow
-
- datatype z = datatype Kind.t
- (* The values of these strings are important since they are referred to
- * in the basis library code. See basis-library/misc/primitive.sml.
- *)
- fun ints (s: IntSize.t) =
- List.map
- ([(Int_add, Functional, "add"),
- (Int_addCheck, SideEffect, "addCheck"),
- (Int_equal, Functional, "equal"),
- (Int_ge, Functional, "ge"),
- (Int_gt, Functional, "gt"),
- (Int_le, Functional, "le"),
- (Int_lt, Functional, "lt"),
- (Int_mul, Functional, "mul"),
- (Int_mulCheck, SideEffect, "mulCheck"),
- (Int_neg, Functional, "neg"),
- (Int_negCheck, SideEffect, "negCheck"),
- (Int_quot, Functional, "quot"),
- (Int_rem, Functional, "rem"),
- (Int_sub, Functional, "sub"),
- (Int_subCheck, SideEffect, "subCheck")],
- fn (makeName, kind, str) =>
- (makeName s, kind, concat ["Int", IntSize.toString s, "_", str]))
-
- fun reals (s: RealSize.t) =
- List.map
- ([(Real_Math_acos, Functional, "Math_acos"),
- (Real_Math_asin, Functional, "Math_asin"),
- (Real_Math_atan, Functional, "Math_atan"),
- (Real_Math_atan2, Functional, "Math_atan2"),
- (Real_Math_cos, Functional, "Math_cos"),
- (Real_Math_exp, Functional, "Math_exp"),
- (Real_Math_ln, Functional, "Math_ln"),
- (Real_Math_log10, Functional, "Math_log10"),
- (Real_Math_sin, Functional, "Math_sin"),
- (Real_Math_sqrt, Functional, "Math_sqrt"),
- (Real_Math_tan, Functional, "Math_tan"),
- (Real_abs, Functional, "abs"),
- (Real_add, Functional, "add"),
- (Real_div, Functional, "div"),
- (Real_equal, Functional, "equal"),
- (Real_ge, Functional, "ge"),
- (Real_gt, Functional, "gt"),
- (Real_ldexp, Functional, "ldexp"),
- (Real_le, Functional, "le"),
- (Real_lt, Functional, "lt"),
- (Real_mul, Functional, "mul"),
- (Real_muladd, Functional, "muladd"),
- (Real_mulsub, Functional, "mulsub"),
- (Real_neg, Functional, "neg"),
- (Real_qequal, Functional, "qequal"),
- (Real_round, DependsOnState, "round"), (* depends on rounding mode *)
- (Real_sub, Functional, "sub")],
- fn (makeName, kind, str) =>
- (makeName s, kind, concat ["Real", RealSize.toString s, "_", str]))
-
- fun words (s: WordSize.t) =
- List.map
- ([(Word_add, Functional, "add"),
- (Word_addCheck, SideEffect, "addCheck"),
- (Word_andb, Functional, "andb"),
- (Word_arshift, Functional, "arshift"),
- (Word_div, Functional, "div"),
- (Word_equal, Functional, "equal"),
- (Word_ge, Functional, "ge"),
- (Word_gt, Functional, "gt"),
- (Word_le, Functional, "le"),
- (Word_lshift, Functional, "lshift"),
- (Word_lt, Functional, "lt"),
- (Word_mod, Functional, "mod"),
- (Word_mul, Functional, "mul"),
- (Word_mulCheck, SideEffect, "mulCheck"),
- (Word_neg, Functional, "neg"),
- (Word_notb, Functional, "notb"),
- (Word_orb, Functional, "orb"),
- (Word_rol, Functional, "rol"),
- (Word_ror, Functional, "ror"),
- (Word_rshift, Functional, "rshift"),
- (Word_sub, Functional, "sub"),
- (Word_xorb, Functional, "xorb")],
- fn (makeName, kind, str) =>
- (makeName s, kind, concat ["Word", WordSize.toString s, "_", str]))
-
- val strings =
- [
- (Array_array, Moveable, "Array_array"),
- (Array_array0Const, Moveable, "Array_array0Const"),
- (Array_length, Functional, "Array_length"),
- (Array_sub, DependsOnState, "Array_sub"),
- (Array_toVector, DependsOnState, "Array_toVector"),
- (Array_update, SideEffect, "Array_update"),
- (Char_toWord8, Functional, "Char_toWord8"),
- (Exn_extra, Functional, "Exn_extra"),
- (Exn_name, Functional, "Exn_name"),
- (Exn_setExtendExtra, SideEffect, "Exn_setExtendExtra"),
- (Exn_setInitExtra, SideEffect, "Exn_setInitExtra"),
- (Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
- (Exn_setTopLevelHandler, SideEffect, "Exn_setTopLevelHandler"),
- (GC_collect, SideEffect, "GC_collect"),
- (GC_pack, SideEffect, "GC_pack"),
- (GC_unpack, SideEffect, "GC_unpack"),
- (IntInf_add, Functional, "IntInf_add"),
- (IntInf_andb, Functional, "IntInf_andb"),
- (IntInf_arshift, Functional, "IntInf_arshift"),
- (IntInf_compare, Functional, "IntInf_compare"),
- (IntInf_equal, Functional, "IntInf_equal"),
- (IntInf_gcd, Functional, "IntInf_gcd"),
- (IntInf_lshift, Functional, "IntInf_lshift"),
- (IntInf_mul, Functional, "IntInf_mul"),
- (IntInf_notb, Functional, "IntInf_notb"),
- (IntInf_neg, Functional, "IntInf_neg"),
- (IntInf_orb, Functional, "IntInf_orb"),
- (IntInf_quot, Functional, "IntInf_quot"),
- (IntInf_rem, Functional, "IntInf_rem"),
- (IntInf_sub, Functional, "IntInf_sub"),
- (IntInf_toString, Functional, "IntInf_toString"),
- (IntInf_toVector, Functional, "IntInf_toVector"),
- (IntInf_toWord, Functional, "IntInf_toWord"),
- (IntInf_xorb, Functional, "IntInf_xorb"),
- (MLton_bogus, Functional, "MLton_bogus"),
- (MLton_bug, SideEffect, "MLton_bug"),
- (MLton_deserialize, Moveable, "MLton_deserialize"),
- (MLton_eq, Functional, "MLton_eq"),
- (MLton_equal, Functional, "MLton_equal"),
- (MLton_halt, SideEffect, "MLton_halt"),
- (MLton_handlesSignals, Functional, "MLton_handlesSignals"),
- (MLton_installSignalHandler, SideEffect,
- "MLton_installSignalHandler"),
- (MLton_serialize, DependsOnState, "MLton_serialize"),
- (MLton_size, DependsOnState, "MLton_size"),
- (MLton_touch, SideEffect, "MLton_touch"),
- (Ref_assign, SideEffect, "Ref_assign"),
- (Ref_deref, DependsOnState, "Ref_deref"),
- (Ref_ref, Moveable, "Ref_ref"),
- (String_toWord8Vector, Functional, "String_toWord8Vector"),
- (Thread_atomicBegin, SideEffect, "Thread_atomicBegin"),
- (Thread_atomicEnd, SideEffect, "Thread_atomicEnd"),
- (Thread_canHandle, DependsOnState, "Thread_canHandle"),
- (Thread_copy, Moveable, "Thread_copy"),
- (Thread_copyCurrent, SideEffect, "Thread_copyCurrent"),
- (Thread_returnToC, SideEffect, "Thread_returnToC"),
- (Thread_switchTo, SideEffect, "Thread_switchTo"),
- (Vector_length, Functional, "Vector_length"),
- (Vector_sub, Functional, "Vector_sub"),
- (Weak_canGet, DependsOnState, "Weak_canGet"),
- (Weak_get, DependsOnState, "Weak_get"),
- (Weak_new, Moveable, "Weak_new"),
- (Word_toIntInf, Functional, "Word_toIntInf"),
- (WordVector_toIntInf, Functional, "WordVector_toIntInf"),
- (Word8_toChar, Functional, "Word8_toChar"),
- (Word8Array_subWord, DependsOnState, "Word8Array_subWord"),
- (Word8Array_updateWord, SideEffect, "Word8Array_updateWord"),
- (Word8Vector_subWord, Functional, "Word8Vector_subWord"),
- (Word8Vector_toString, Functional, "Word8Vector_toString"),
- (World_save, SideEffect, "World_save")]
- @ List.concat [List.concatMap (IntSize.all, ints),
- List.concatMap (RealSize.all, reals),
- List.concatMap (WordSize.all, words)]
- @ let
- val int = ("Int", IntSize.all, IntSize.toString)
- val real = ("Real", RealSize.all, RealSize.toString)
- val word = ("Word", WordSize.all, WordSize.toString)
- local
- fun coerces' suf (name,
- (n, sizes, sizeToString),
- (n', sizes', sizeToString')) =
- List.fold
- (sizes, [], fn (s, ac) =>
- List.fold
- (sizes', ac, fn (s', ac) =>
- (name (s, s'), Functional,
- concat [n, sizeToString s, "_to", n', sizeToString' s',
- suf])
- :: ac))
- in
- val coerces = fn z => coerces' "" z
- val coercesX = fn z => coerces' "X" z
- end
- in
- List.concat [coerces (Int_toInt, int, int),
- coerces (Int_toReal, int, real),
- coerces (Int_toWord, int, word),
- coerces (Real_toInt, real, int),
- coerces (Real_toReal, real, real),
- coerces (Word_toInt, word, int),
- coercesX (Word_toIntX, word, int),
- coerces (Word_toWord, word, word),
- coercesX (Word_toWordX, word, word)]
- end
- @ let
- fun doit (name, all, toString, get, set) =
- List.concatMap
- (all, fn s =>
- [(get s, DependsOnState,
- concat ["Pointer_get", name, toString s]),
- (set s, SideEffect,
- concat ["Pointer_set", name, toString s])])
- in
- List.concat [doit ("Int", IntSize.all, IntSize.toString,
- Pointer_getInt, Pointer_setInt),
- doit ("Pointer", [()], fn () => "",
- fn () => Pointer_getPointer,
- fn () => Pointer_setPointer),
- doit ("Real", RealSize.all, RealSize.toString,
- Pointer_getReal, Pointer_setReal),
- doit ("Word", WordSize.all, WordSize.toString,
- Pointer_getWord, Pointer_setWord)]
- end
-
- fun toString n =
- case n of
- FFI f => CFunction.name f
- | FFI_Symbol {name, ...} => name
- | _ => (case List.peek (strings, fn (n', _, _) => n = n') of
- NONE => Error.bug "Prim.toString missing name"
- | SOME (_, _, s) => s)
-
- val layout = Layout.str o toString
- end
-
datatype t =
- T of {name: Name.t,
- nameString: string,
- kind: Kind.t}
-
-local
- fun make sel (T r) = sel r
-in
- val kind = make #kind
- val name = make #name
- val toString = make #nameString
-end
+ Array_array (* backend *)
+ | Array_array0Const (* constant propagation *)
+ | Array_length (* ssa to rssa *)
+ | Array_sub (* backend *)
+ | Array_toVector (* backend *)
+ | Array_update (* backend *)
+ | Char_toWord8 (* type inference *)
+ | Exn_extra (* implement exceptions *)
+ | Exn_keepHistory (* a compile-time boolean *)
+ | Exn_name (* implement exceptions *)
+ | Exn_setExtendExtra (* implement exceptions *)
+ | Exn_setInitExtra (* implement exceptions *)
+ | Exn_setTopLevelHandler (* implement exceptions *)
+ | FFI of CFunction.t (* ssa to rssa *)
+ | FFI_Symbol of {name: string,
+ ty: RepType.t} (* codegen *)
+ | GC_collect (* ssa to rssa *)
+ | GC_pack (* ssa to rssa *)
+ | GC_unpack (* ssa to rssa *)
+ | Int_add of IntSize.t (* codegen *)
+ | Int_addCheck of IntSize.t (* codegen *)
+ | Int_equal of IntSize.t (* ssa to rssa / codegen *)
+ | Int_ge of IntSize.t (* codegen *)
+ | Int_gt of IntSize.t (* codegen *)
+ | Int_le of IntSize.t (* codegen *)
+ | Int_lt of IntSize.t (* codegen *)
+ | Int_mul of IntSize.t (* codegen *)
+ | Int_mulCheck of IntSize.t (* codegen *)
+ | Int_neg of IntSize.t (* codegen *)
+ | Int_negCheck of IntSize.t (* codegen *)
+ | Int_quot of IntSize.t (* codegen *)
+ | Int_rem of IntSize.t (* codegen *)
+ | Int_sub of IntSize.t (* codegen *)
+ | Int_subCheck of IntSize.t (* codegen *)
+ | Int_toInt of IntSize.t * IntSize.t (* codegen *)
+ | Int_toReal of IntSize.t * RealSize.t (* codegen *)
+ | Int_toWord of IntSize.t * WordSize.t (* codegen *)
+ | IntInf_add (* ssa to rssa *)
+ | IntInf_andb (* ssa to rssa *)
+ | IntInf_arshift (* ssa to rssa *)
+ | IntInf_compare (* ssa to rssa *)
+ | IntInf_equal (* ssa to rssa *)
+ | IntInf_gcd (* ssa to rssa *)
+ | IntInf_lshift (* ssa to rssa *)
+ | IntInf_mul (* ssa to rssa *)
+ | IntInf_neg (* ssa to rssa *)
+ | IntInf_notb (* ssa to rssa *)
+ | IntInf_orb (* ssa to rssa *)
+ | IntInf_quot (* ssa to rssa *)
+ | IntInf_rem (* ssa to rssa *)
+ | IntInf_sub (* ssa to rssa *)
+ | IntInf_toString (* ssa to rssa *)
+ | IntInf_toVector (* ssa to rssa *)
+ | IntInf_toWord (* ssa to rssa *)
+ | IntInf_xorb (* ssa to rssa *)
+ | MLton_bogus (* ssa to rssa *)
+ (* of type unit -> 'a.
+ * Makes a bogus value of any type.
+ *)
+ | MLton_bug (* ssa to rssa *)
+ | MLton_deserialize (* unused *)
+ | MLton_eq (* codegen *)
+ | MLton_equal (* polymorphic equality *)
+ | MLton_halt (* ssa to rssa *)
+ (* MLton_handlesSignals and MLton_installSignalHandler work together
+ * to inform the optimizer and basis library whether or not the
+ * program uses signal handlers.
+ *
+ * MLton_installSignalHandler is called by MLton.Signal.setHandler,
+ * and is effectively a noop, but is left in the program until the
+ * end of the backend, so that the optimizer can test whether or
+ * not the program installs signal handlers.
+ *
+ * MLton_handlesSignals is translated by closure conversion into
+ * a boolean, and is true iff MLton_installsSignalHandler is called.
+ *)
+ | MLton_handlesSignals (* closure conversion *)
+ | MLton_installSignalHandler (* backend *)
+ | MLton_serialize (* unused *)
+ | MLton_size (* ssa to rssa *)
+ | MLton_touch (* backend *)
+ | Pointer_getInt of IntSize.t (* backend *)
+ | Pointer_getPointer (* backend *)
+ | Pointer_getReal of RealSize.t (* backend *)
+ | Pointer_getWord of WordSize.t (* backend *)
+ | Pointer_setInt of IntSize.t (* backend *)
+ | Pointer_setPointer (* backend *)
+ | Pointer_setReal of RealSize.t (* backend *)
+ | Pointer_setWord of WordSize.t (* backend *)
+ | Real_Math_acos of RealSize.t (* codegen *)
+ | Real_Math_asin of RealSize.t (* codegen *)
+ | Real_Math_atan of RealSize.t (* codegen *)
+ | Real_Math_atan2 of RealSize.t (* codegen *)
+ | Real_Math_cos of RealSize.t (* codegen *)
+ | Real_Math_exp of RealSize.t (* codegen *)
+ | Real_Math_ln of RealSize.t (* codegen *)
+ | Real_Math_log10 of RealSize.t (* codegen *)
+ | Real_Math_sin of RealSize.t (* codegen *)
+ | Real_Math_sqrt of RealSize.t (* codegen *)
+ | Real_Math_tan of RealSize.t (* codegen *)
+ | Real_abs of RealSize.t (* codegen *)
+ | Real_add of RealSize.t (* codegen *)
+ | Real_div of RealSize.t (* codegen *)
+ | Real_equal of RealSize.t (* codegen *)
+ | Real_ge of RealSize.t (* codegen *)
+ | Real_gt of RealSize.t (* codegen *)
+ | Real_ldexp of RealSize.t (* codegen *)
+ | Real_le of RealSize.t (* codegen *)
+ | Real_lt of RealSize.t (* codegen *)
+ | Real_mul of RealSize.t (* codegen *)
+ | Real_muladd of RealSize.t (* codegen *)
+ | Real_mulsub of RealSize.t (* codegen *)
+ | Real_neg of RealSize.t (* codegen *)
+ | Real_qequal of RealSize.t (* codegen *)
+ | Real_round of RealSize.t (* codegen *)
+ | Real_sub of RealSize.t (* codegen *)
+ | Real_toInt of RealSize.t * IntSize.t (* codegen *)
+ | Real_toReal of RealSize.t * RealSize.t (* codegen *)
+ | Ref_assign (* backend *)
+ | Ref_deref (* backend *)
+ | Ref_ref (* backend *)
+ | String_toWord8Vector (* type inference *)
+ | Thread_atomicBegin (* backend *)
+ | Thread_atomicEnd (* backend *)
+ | Thread_canHandle (* backend *)
+ | Thread_copy (* ssa to rssa *)
+ | Thread_copyCurrent (* ssa to rssa *)
+ | Thread_returnToC (* codegen *)
+ (* switchTo has to be a _prim because we have to know that it
+ * enters the runtime -- because everything must be saved
+ * on the stack.
+ *)
+ | Thread_switchTo (* ssa to rssa *)
+ | Vector_length (* ssa to rssa *)
+ | Vector_sub (* backend *)
+ | Weak_canGet (* ssa to rssa *)
+ | Weak_get (* ssa to rssa *)
+ | Weak_new (* ssa to rssa *)
+ | Word_add of WordSize.t (* codegen *)
+ | Word_addCheck of WordSize.t (* codegen *)
+ | Word_andb of WordSize.t (* codegen *)
+ | Word_arshift of WordSize.t (* codegen *)
+ | Word_div of WordSize.t (* codegen *)
+ | Word_equal of WordSize.t (* codegen *)
+ | Word_ge of WordSize.t (* codegen *)
+ | Word_gt of WordSize.t (* codegen *)
+ | Word_le of WordSize.t (* codegen *)
+ | Word_lshift of WordSize.t (* codegen *)
+ | Word_lt of WordSize.t (* codegen *)
+ | Word_mod of WordSize.t (* codegen *)
+ | Word_mul of WordSize.t (* codegen *)
+ | Word_mulCheck of WordSize.t (* codegen *)
+ | Word_neg of WordSize.t (* codegen *)
+ | Word_notb of WordSize.t (* codegen *)
+ | Word_orb of WordSize.t (* codegen *)
+ | Word_rol of WordSize.t (* codegen *)
+ | Word_ror of WordSize.t (* codegen *)
+ | Word_rshift of WordSize.t (* codegen *)
+ | Word_sub of WordSize.t (* codegen *)
+ | Word_toInt of WordSize.t * IntSize.t (* codegen *)
+ | Word_toIntInf (* ssa to rssa *)
+ | Word_toIntX of WordSize.t * IntSize.t (* codegen *)
+ | Word_toWord of WordSize.t * WordSize.t (* codegen *)
+ | Word_toWordX of WordSize.t * WordSize.t (* codegen *)
+ | Word_xorb of WordSize.t (* codegen *)
+ | WordVector_toIntInf (* ssa to rssa *)
+ | Word8_toChar (* type inference *)
+ | Word8Array_subWord (* ssa to rssa *)
+ | Word8Array_updateWord (* ssa to rssa *)
+ | Word8Vector_subWord (* ssa to rssa *)
+ | Word8Vector_toString (* type inference *)
+ | World_save (* ssa to rssa *)
-val layout = Name.layout o name
-
-local
- fun make k p = k = kind p
-in
- val isFunctional = make Kind.Functional
- val maySideEffect = make Kind.SideEffect
-end
-val isFunctional = Trace.trace ("isFunctional", layout, Bool.layout) isFunctional
-
-val isCommutative = Name.isCommutative o name
-val mayOverflow = Name.mayOverflow o name
-val mayRaise = Name.mayRaise o name
+fun name p = p
+
+(* The values of these strings are important since they are referred to
+ * in the basis library code. See basis-library/misc/primitive.sml.
+ *)
+fun toString (n: t): string =
+ let
+ fun int (s: IntSize.t, str: string): string =
+ concat ["Int", IntSize.toString s, "_", str]
+ fun real (s: RealSize.t, str: string): string =
+ concat ["Real", RealSize.toString s, "_", str]
+ fun word (s: WordSize.t, str: string): string =
+ concat ["Word", WordSize.toString s, "_", str]
+ val intC = ("Int", IntSize.toString)
+ val realC = ("Real", RealSize.toString)
+ val wordC = ("Word", WordSize.toString)
+ local
+ fun make (suf, ((n, sizeToString), (n', sizeToString'),
+ s, s')): string =
+ concat [n, sizeToString s, "_to", n', sizeToString' s', suf]
+ in
+ fun coerce z = make ("", z)
+ fun coerceX z = make ("X", z)
+ end
+ fun pointerGet (ty, s) = concat ["Pointer_get", ty, s]
+ fun pointerSet (ty, s) = concat ["Pointer_set", ty, s]
+ in
+ case n of
+ Array_array => "Array_array"
+ | Array_array0Const => "Array_array0Const"
+ | Array_length => "Array_length"
+ | Array_sub => "Array_sub"
+ | Array_toVector => "Array_toVector"
+ | Array_update => "Array_update"
+ | Char_toWord8 => "Char_toWord8"
+ | Exn_extra => "Exn_extra"
+ | Exn_keepHistory => "Exn_keepHistory"
+ | Exn_name => "Exn_name"
+ | Exn_setExtendExtra => "Exn_setExtendExtra"
+ | Exn_setInitExtra => "Exn_setInitExtra"
+ | Exn_setTopLevelHandler => "Exn_setTopLevelHandler"
+ | FFI f => CFunction.name f
+ | FFI_Symbol {name, ...} => name
+ | GC_collect => "GC_collect"
+ | GC_pack => "GC_pack"
+ | GC_unpack => "GC_unpack"
+ | IntInf_add => "IntInf_add"
+ | IntInf_andb => "IntInf_andb"
+ | IntInf_arshift => "IntInf_arshift"
+ | IntInf_compare => "IntInf_compare"
+ | IntInf_equal => "IntInf_equal"
+ | IntInf_gcd => "IntInf_gcd"
+ | IntInf_lshift => "IntInf_lshift"
+ | IntInf_mul => "IntInf_mul"
+ | IntInf_neg => "IntInf_neg"
+ | IntInf_notb => "IntInf_notb"
+ | IntInf_orb => "IntInf_orb"
+ | IntInf_quot => "IntInf_quot"
+ | IntInf_rem => "IntInf_rem"
+ | IntInf_sub => "IntInf_sub"
+ | IntInf_toString => "IntInf_toString"
+ | IntInf_toVector => "IntInf_toVector"
+ | IntInf_toWord => "IntInf_toWord"
+ | IntInf_xorb => "IntInf_xorb"
+ | Int_add s => int (s, "add")
+ | Int_addCheck s => int (s, "addCheck")
+ | Int_equal s => int (s, "equal")
+ | Int_ge s => int (s, "ge")
+ | Int_gt s => int (s, "gt")
+ | Int_le s => int (s, "le")
+ | Int_lt s => int (s, "lt")
+ | Int_mul s => int (s, "mul")
+ | Int_mulCheck s => int (s, "mulCheck")
+ | Int_neg s => int (s, "neg")
+ | Int_negCheck s => int (s, "negCheck")
+ | Int_quot s => int (s, "quot")
+ | Int_rem s => int (s, "rem")
+ | Int_sub s => int (s, "sub")
+ | Int_subCheck s => int (s, "subCheck")
+ | Int_toInt (s1, s2) => coerce (intC, intC, s1, s2)
+ | Int_toReal (s1, s2) => coerce (intC, realC, s1, s2)
+ | Int_toWord (s1, s2) => coerce (intC, wordC, s1, s2)
+ | MLton_bogus => "MLton_bogus"
+ | MLton_bug => "MLton_bug"
+ | MLton_deserialize => "MLton_deserialize"
+ | MLton_eq => "MLton_eq"
+ | MLton_equal => "MLton_equal"
+ | MLton_halt => "MLton_halt"
+ | MLton_handlesSignals => "MLton_handlesSignals"
+ | MLton_installSignalHandler => "MLton_installSignalHandler"
+ | MLton_serialize => "MLton_serialize"
+ | MLton_size => "MLton_size"
+ | MLton_touch => "MLton_touch"
+ | Pointer_getInt s => pointerGet ("Int", IntSize.toString s)
+ | Pointer_getPointer => "Pointer_getPointer"
+ | Pointer_getReal s => pointerGet ("Real", RealSize.toString s)
+ | Pointer_getWord s => pointerGet ("Word", WordSize.toString s)
+ | Pointer_setInt s => pointerSet ("Int", IntSize.toString s)
+ | Pointer_setPointer => "Pointer_setPointer"
+ | Pointer_setReal s => pointerSet ("Real", RealSize.toString s)
+ | Pointer_setWord s => pointerSet ("Word", WordSize.toString s)
+ | Real_Math_acos s => real (s, "Math_acos")
+ | Real_Math_asin s => real (s, "Math_asin")
+ | Real_Math_atan s => real (s, "Math_atan")
+ | Real_Math_atan2 s => real (s, "Math_atan2")
+ | Real_Math_cos s => real (s, "Math_cos")
+ | Real_Math_exp s => real (s, "Math_exp")
+ | Real_Math_ln s => real (s, "Math_ln")
+ | Real_Math_log10 s => real (s, "Math_log10")
+ | Real_Math_sin s => real (s, "Math_sin")
+ | Real_Math_sqrt s => real (s, "Math_sqrt")
+ | Real_Math_tan s => real (s, "Math_tan")
+ | Real_abs s => real (s, "abs")
+ | Real_add s => real (s, "add")
+ | Real_div s => real (s, "div")
+ | Real_equal s => real (s, "equal")
+ | Real_ge s => real (s, "ge")
+ | Real_gt s => real (s, "gt")
+ | Real_ldexp s => real (s, "ldexp")
+ | Real_le s => real (s, "le")
+ | Real_lt s => real (s, "lt")
+ | Real_mul s => real (s, "mul")
+ | Real_muladd s => real (s, "muladd")
+ | Real_mulsub s => real (s, "mulsub")
+ | Real_neg s => real (s, "neg")
+ | Real_qequal s => real (s, "qequal")
+ | Real_round s => real (s, "round")
+ | Real_sub s => real (s, "sub")
+ | Real_toInt (s1, s2) => coerce (realC, intC, s1, s2)
+ | Real_toReal (s1, s2) => coerce (realC, realC, s1, s2)
+ | Ref_assign => "Ref_assign"
+ | Ref_deref => "Ref_deref"
+ | Ref_ref => "Ref_ref"
+ | String_toWord8Vector => "String_toWord8Vector"
+ | Thread_atomicBegin => "Thread_atomicBegin"
+ | Thread_atomicEnd => "Thread_atomicEnd"
+ | Thread_canHandle => "Thread_canHandle"
+ | Thread_copy => "Thread_copy"
+ | Thread_copyCurrent => "Thread_copyCurrent"
+ | Thread_returnToC => "Thread_returnToC"
+ | Thread_switchTo => "Thread_switchTo"
+ | Vector_length => "Vector_length"
+ | Vector_sub => "Vector_sub"
+ | Weak_canGet => "Weak_canGet"
+ | Weak_get => "Weak_get"
+ | Weak_new => "Weak_new"
+ | Word8Array_subWord => "Word8Array_subWord"
+ | Word8Array_updateWord => "Word8Array_updateWord"
+ | Word8Vector_subWord => "Word8Vector_subWord"
+ | Word8Vector_toString => "Word8Vector_toString"
+ | Word8_toChar => "Word8_toChar"
+ | WordVector_toIntInf => "WordVector_toIntInf"
+ | Word_add s => word (s, "add")
+ | Word_addCheck s => word (s, "addCheck")
+ | Word_andb s => word (s, "andb")
+ | Word_arshift s => word (s, "arshift")
+ | Word_div s => word (s, "div")
+ | Word_equal s => word (s, "equal")
+ | Word_ge s => word (s, "ge")
+ | Word_gt s => word (s, "gt")
+ | Word_le s => word (s, "le")
+ | Word_lshift s => word (s, "lshift")
+ | Word_lt s => word (s, "lt")
+ | Word_mod s => word (s, "mod")
+ | Word_mul s => word (s, "mul")
+ | Word_mulCheck s => word (s, "mulCheck")
+ | Word_neg s => word (s, "neg")
+ | Word_notb s => word (s, "notb")
+ | Word_orb s => word (s, "orb")
+ | Word_rol s => word (s, "rol")
+ | Word_ror s => word (s, "ror")
+ | Word_rshift s => word (s, "rshift")
+ | Word_sub s => word (s, "sub")
+ | Word_toInt (s1, s2) => coerce (wordC, intC, s1, s2)
+ | Word_toIntInf => "Word_toIntInf"
+ | Word_toIntX (s1, s2) => coerceX (wordC, intC, s1, s2)
+ | Word_toWord (s1, s2) => coerce (wordC, wordC, s1, s2)
+ | Word_toWordX (s1, s2) => coerceX (wordC, wordC, s1, s2)
+ | Word_xorb s => word (s, "xorb")
+ | World_save => "World_save"
+ end
-fun make (n: Name.t, k: Kind.t): t =
- T {kind = k,
- name = n,
- nameString = Name.toString n}
+val layout = Layout.str o toString
+
+val equals: t * t -> bool =
+ fn (Array_array, Array_array) => true
+ | (Array_array0Const, Array_array0Const) => true
+ | (Array_length, Array_length) => true
+ | (Array_sub, Array_sub) => true
+ | (Array_toVector, Array_toVector) => true
+ | (Array_update, Array_update) => true
+ | (Char_toWord8, Char_toWord8) => true
+ | (Exn_extra, Exn_extra) => true
+ | (Exn_keepHistory, Exn_keepHistory) => true
+ | (Exn_name, Exn_name) => true
+ | (Exn_setExtendExtra, Exn_setExtendExtra) => true
+ | (Exn_setInitExtra, Exn_setInitExtra) => true
+ | (Exn_setTopLevelHandler, Exn_setTopLevelHandler) => true
+ | (FFI f, FFI f') => CFunction.equals (f, f')
+ | (FFI_Symbol {name = n, ...}, FFI_Symbol {name = n', ...}) => n = n'
+ | (GC_collect, GC_collect) => true
+ | (GC_pack, GC_pack) => true
+ | (GC_unpack, GC_unpack) => true
+ | (Int_add s, Int_add s') => IntSize.equals (s, s')
+ | (Int_addCheck s, Int_addCheck s') => IntSize.equals (s, s')
+ | (Int_equal s, Int_equal s') => IntSize.equals (s, s')
+ | (Int_ge s, Int_ge s') => IntSize.equals (s, s')
+ | (Int_gt s, Int_gt s') => IntSize.equals (s, s')
+ | (Int_le s, Int_le s') => IntSize.equals (s, s')
+ | (Int_lt s, Int_lt s') => IntSize.equals (s, s')
+ | (Int_mul s, Int_mul s') => IntSize.equals (s, s')
+ | (Int_mulCheck s, Int_mulCheck s') => IntSize.equals (s, s')
+ | (Int_neg s, Int_neg s') => IntSize.equals (s, s')
+ | (Int_negCheck s, Int_negCheck s') => IntSize.equals (s, s')
+ | (Int_quot s, Int_quot s') => IntSize.equals (s, s')
+ | (Int_rem s, Int_rem s') => IntSize.equals (s, s')
+ | (Int_sub s, Int_sub s') => IntSize.equals (s, s')
+ | (Int_subCheck s, Int_subCheck s') => IntSize.equals (s, s')
+ | (Int_toInt (s1, s2), Int_toInt (s1', s2')) =>
+ IntSize.equals (s1, s1') andalso IntSize.equals (s2, s2')
+ | (Int_toReal (s1, s2), Int_toReal (s1', s2')) =>
+ IntSize.equals (s1, s1') andalso RealSize.equals (s2, s2')
+ | (Int_toWord (s1, s2), Int_toWord (s1', s2')) =>
+ IntSize.equals (s1, s1') andalso WordSize.equals (s2, s2')
+ | (IntInf_add, IntInf_add) => true
+ | (IntInf_andb, IntInf_andb) => true
+ | (IntInf_arshift, IntInf_arshift) => true
+ | (IntInf_compare, IntInf_compare) => true
+ | (IntInf_equal, IntInf_equal) => true
+ | (IntInf_gcd, IntInf_gcd) => true
+ | (IntInf_lshift, IntInf_lshift) => true
+ | (IntInf_mul, IntInf_mul) => true
+ | (IntInf_neg, IntInf_neg) => true
+ | (IntInf_notb, IntInf_notb) => true
+ | (IntInf_orb, IntInf_orb) => true
+ | (IntInf_quot, IntInf_quot) => true
+ | (IntInf_rem, IntInf_rem) => true
+ | (IntInf_sub, IntInf_sub) => true
+ | (IntInf_toString, IntInf_toString) => true
+ | (IntInf_toVector, IntInf_toVector) => true
+ | (IntInf_toWord, IntInf_toWord) => true
+ | (IntInf_xorb, IntInf_xorb) => true
+ | (MLton_bogus, MLton_bogus) => true
+ | (MLton_bug, MLton_bug) => true
+ | (MLton_deserialize, MLton_deserialize) => true
+ | (MLton_eq, MLton_eq) => true
+ | (MLton_equal, MLton_equal) => true
+ | (MLton_halt, MLton_halt) => true
+ | (MLton_handlesSignals, MLton_handlesSignals) => true
+ | (MLton_installSignalHandler, MLton_installSignalHandler) => true
+ | (MLton_serialize, MLton_serialize) => true
+ | (MLton_size, MLton_size) => true
+ | (MLton_touch, MLton_touch) => true
+ | (Pointer_getInt s, Pointer_getInt s') => IntSize.equals (s, s')
+ | (Pointer_getPointer, Pointer_getPointer) => true
+ | (Pointer_getReal s, Pointer_getReal s') => RealSize.equals (s, s')
+ | (Pointer_getWord s, Pointer_getWord s') => WordSize.equals (s, s')
+ | (Pointer_setInt s, Pointer_setInt s') => IntSize.equals (s, s')
+ | (Pointer_setPointer, Pointer_setPointer) => true
+ | (Pointer_setReal s, Pointer_setReal s') => RealSize.equals (s, s')
+ | (Pointer_setWord s, Pointer_setWord s') => WordSize.equals (s, s')
+ | (Real_Math_acos s, Real_Math_acos s') => RealSize.equals (s, s')
+ | (Real_Math_asin s, Real_Math_asin s') => RealSize.equals (s, s')
+ | (Real_Math_atan s, Real_Math_atan s') => RealSize.equals (s, s')
+ | (Real_Math_atan2 s, Real_Math_atan2 s') => RealSize.equals (s, s')
+ | (Real_Math_cos s, Real_Math_cos s') => RealSize.equals (s, s')
+ | (Real_Math_exp s, Real_Math_exp s') => RealSize.equals (s, s')
+ | (Real_Math_ln s, Real_Math_ln s') => RealSize.equals (s, s')
+ | (Real_Math_log10 s, Real_Math_log10 s') => RealSize.equals (s, s')
+ | (Real_Math_sin s, Real_Math_sin s') => RealSize.equals (s, s')
+ | (Real_Math_sqrt s, Real_Math_sqrt s') => RealSize.equals (s, s')
+ | (Real_Math_tan s, Real_Math_tan s') => RealSize.equals (s, s')
+ | (Real_abs s, Real_abs s') => RealSize.equals (s, s')
+ | (Real_add s, Real_add s') => RealSize.equals (s, s')
+ | (Real_div s, Real_div s') => RealSize.equals (s, s')
+ | (Real_equal s, Real_equal s') => RealSize.equals (s, s')
+ | (Real_ge s, Real_ge s') => RealSize.equals (s, s')
+ | (Real_gt s, Real_gt s') => RealSize.equals (s, s')
+ | (Real_ldexp s, Real_ldexp s') => RealSize.equals (s, s')
+ | (Real_le s, Real_le s') => RealSize.equals (s, s')
+ | (Real_lt s, Real_lt s') => RealSize.equals (s, s')
+ | (Real_mul s, Real_mul s') => RealSize.equals (s, s')
+ | (Real_muladd s, Real_muladd s') => RealSize.equals (s, s')
+ | (Real_mulsub s, Real_mulsub s') => RealSize.equals (s, s')
+ | (Real_neg s, Real_neg s') => RealSize.equals (s, s')
+ | (Real_qequal s, Real_qequal s') => RealSize.equals (s, s')
+ | (Real_round s, Real_round s') => RealSize.equals (s, s')
+ | (Real_sub s, Real_sub s') => RealSize.equals (s, s')
+ | (Real_toInt (s1, s2), Real_toInt (s1', s2')) =>
+ RealSize.equals (s1, s1') andalso IntSize.equals (s2, s2')
+ | (Real_toReal (s1, s2), Real_toReal (s1', s2')) =>
+ RealSize.equals (s1, s1') andalso RealSize.equals (s2, s2')
+ | (Ref_assign, Ref_assign) => true
+ | (Ref_deref, Ref_deref) => true
+ | (Ref_ref, Ref_ref) => true
+ | (String_toWord8Vector, String_toWord8Vector) => true
+ | (Thread_atomicBegin, Thread_atomicBegin) => true
+ | (Thread_atomicEnd, Thread_atomicEnd) => true
+ | (Thread_canHandle, Thread_canHandle) => true
+ | (Thread_copy, Thread_copy) => true
+ | (Thread_copyCurrent, Thread_copyCurrent) => true
+ | (Thread_returnToC, Thread_returnToC) => true
+ | (Thread_switchTo, Thread_switchTo) => true
+ | (Vector_length, Vector_length) => true
+ | (Vector_sub, Vector_sub) => true
+ | (Weak_canGet, Weak_canGet) => true
+ | (Weak_get, Weak_get) => true
+ | (Weak_new, Weak_new) => true
+ | (Word_add s, Word_add s') => WordSize.equals (s, s')
+ | (Word_addCheck s, Word_addCheck s') => WordSize.equals (s, s')
+ | (Word_andb s, Word_andb s') => WordSize.equals (s, s')
+ | (Word_arshift s, Word_arshift s') => WordSize.equals (s, s')
+ | (Word_div s, Word_div s') => WordSize.equals (s, s')
+ | (Word_equal s, Word_equal s') => WordSize.equals (s, s')
+ | (Word_ge s, Word_ge s') => WordSize.equals (s, s')
+ | (Word_gt s, Word_gt s') => WordSize.equals (s, s')
+ | (Word_le s, Word_le s') => WordSize.equals (s, s')
+ | (Word_lshift s, Word_lshift s') => WordSize.equals (s, s')
+ | (Word_lt s, Word_lt s') => WordSize.equals (s, s')
+ | (Word_mod s, Word_mod s') => WordSize.equals (s, s')
+ | (Word_mul s, Word_mul s') => WordSize.equals (s, s')
+ | (Word_mulCheck s, Word_mulCheck s') => WordSize.equals (s, s')
+ | (Word_neg s, Word_neg s') => WordSize.equals (s, s')
+ | (Word_notb s, Word_notb s') => WordSize.equals (s, s')
+ | (Word_orb s, Word_orb s') => WordSize.equals (s, s')
+ | (Word_rol s, Word_rol s') => WordSize.equals (s, s')
+ | (Word_ror s, Word_ror s') => WordSize.equals (s, s')
+ | (Word_rshift s, Word_rshift s') => WordSize.equals (s, s')
+ | (Word_sub s, Word_sub s') => WordSize.equals (s, s')
+ | (Word_toInt (s1, s2), Word_toInt (s1', s2')) =>
+ WordSize.equals (s1, s1') andalso IntSize.equals (s2, s2')
+ | (Word_toIntInf, Word_toIntInf) => true
+ | (Word_toIntX (s1, s2), Word_toIntX (s1', s2')) =>
+ WordSize.equals (s1, s1') andalso IntSize.equals (s2, s2')
+ | (Word_toWord (s1, s2), Word_toWord (s1', s2')) =>
+ WordSize.equals (s1, s1') andalso WordSize.equals (s2, s2')
+ | (Word_toWordX (s1, s2), Word_toWordX (s1', s2')) =>
+ WordSize.equals (s1, s1') andalso WordSize.equals (s2, s2')
+ | (Word_xorb s, Word_xorb s') => WordSize.equals (s, s')
+ | (WordVector_toIntInf, WordVector_toIntInf) => true
+ | (Word8_toChar, Word8_toChar) => true
+ | (Word8Array_subWord, Word8Array_subWord) => true
+ | (Word8Array_updateWord, Word8Array_updateWord) => true
+ | (Word8Vector_subWord, Word8Vector_subWord) => true
+ | (Word8Vector_toString, Word8Vector_toString) => true
+ | (World_save, World_save) => true
+ | _ => false
+
+val allocTooLarge = FFI CFunction.allocTooLarge
+val array = Array_array
+val assign = Ref_assign
+val bogus = MLton_bogus
+val bug = MLton_bug
+val deref = Ref_deref
+val deserialize = MLton_deserialize
+val eq = MLton_eq
+val equal = MLton_equal
+val ffi = FFI
+val ffiSymbol = FFI_Symbol
+val gcCollect = GC_collect
+val intAdd = Int_add
+val intAddCheck = Int_addCheck
+val intEqual = Int_equal
+val intInfEqual = IntInf_equal
+val intInfNeg = IntInf_neg
+val intInfNotb = IntInf_notb
+val intMul = Int_mul
+val intMulCheck = Int_mulCheck
+val intNeg = Int_neg
+val intNegCheck = Int_negCheck
+val intSub = Int_sub
+val intSubCheck = Int_subCheck
+val intToInt = Int_toInt
+val intToWord = Int_toWord
+val reff = Ref_ref
+val serialize = MLton_serialize
+val vectorLength = Vector_length
+val vectorSub = Vector_sub
+val wordAdd = Word_add
+val wordAddCheck = Word_addCheck
+val wordAndb = Word_andb
+val wordEqual = Word_equal
+val wordGe = Word_ge
+val wordGt = Word_gt
+val wordLe = Word_le
+val wordLshift = Word_lshift
+val wordLt = Word_lt
+val wordMul = Word_mul
+val wordMulCheck = Word_mulCheck
+val wordNeg = Word_neg
+val wordNotb = Word_notb
+val wordRshift = Word_rshift
+val wordSub = Word_sub
+val wordToInt = Word_toInt
+val wordToIntX = Word_toIntX
+val wordToWord = Word_toWord
+
+val isCommutative =
+ fn Int_add _ => true
+ | Int_addCheck _ => true
+ | Int_equal _ => true
+ | Int_mul _ => true
+ | Int_mulCheck _ => true
+ | IntInf_equal => true
+ | MLton_eq => true
+ | MLton_equal => true
+ | Real_add _ => true
+ | Real_mul _ => true
+ | Real_qequal _ => true
+ | Word_add _ => true
+ | Word_addCheck _ => true
+ | Word_andb _ => true
+ | Word_equal _ => true
+ | Word_mul _ => true
+ | Word_mulCheck _ => true
+ | Word_orb _ => true
+ | Word_xorb _ => true
+ | _ => false
+
+val mayOverflow =
+ fn Int_addCheck _ => true
+ | Int_mulCheck _ => true
+ | Int_negCheck _ => true
+ | Int_subCheck _ => true
+ | Word_addCheck _ => true
+ | Word_mulCheck _ => true
+ | _ => false
-fun equals (p, p') = Name.equals (name p, name p')
+val mayRaise = mayOverflow
-val new: Name.t -> t =
- fn n =>
+val kind: t -> Kind.t =
let
- val k =
- case n of
- Name.FFI _ => Kind.SideEffect
- | Name.FFI_Symbol _ => Kind.DependsOnState
- | _ => (case List.peek (Name.strings, fn (n', _, _) => n = n') of
- NONE => Error.bug (concat ["strange name: ",
- Name.toString n])
- | SOME (_, k, _) => k)
+ datatype z = datatype Kind.t
in
- make (n, k)
+ fn Array_array => Moveable
+ | Array_array0Const => Moveable
+ | Array_length => Functional
+ | Array_sub => DependsOnState
+ | Array_toVector => DependsOnState
+ | Array_update => SideEffect
+ | Char_toWord8 => Functional
+ | Exn_extra => Functional
+ | Exn_keepHistory => Functional
+ | Exn_name => Functional
+ | Exn_setExtendExtra => SideEffect
+ | Exn_setInitExtra => SideEffect
+ | Exn_setTopLevelHandler => SideEffect
+ | FFI _ => Kind.SideEffect
+ | FFI_Symbol _ => Kind.DependsOnState
+ | GC_collect => SideEffect
+ | GC_pack => SideEffect
+ | GC_unpack => SideEffect
+ | IntInf_add => Functional
+ | IntInf_andb => Functional
+ | IntInf_arshift => Functional
+ | IntInf_compare => Functional
+ | IntInf_equal => Functional
+ | IntInf_gcd => Functional
+ | IntInf_lshift => Functional
+ | IntInf_mul => Functional
+ | IntInf_neg => Functional
+ | IntInf_notb => Functional
+ | IntInf_orb => Functional
+ | IntInf_quot => Functional
+ | IntInf_rem => Functional
+ | IntInf_sub => Functional
+ | IntInf_toString => Functional
+ | IntInf_toVector => Functional
+ | IntInf_toWord => Functional
+ | IntInf_xorb => Functional
+ | Int_add _ => Functional
+ | Int_addCheck _ => SideEffect
+ | Int_equal _ => Functional
+ | Int_ge _ => Functional
+ | Int_gt _ => Functional
+ | Int_le _ => Functional
+ | Int_lt _ => Functional
+ | Int_mul _ => Functional
+ | Int_mulCheck _ => SideEffect
+ | Int_neg _ => Functional
+ | Int_negCheck _ => SideEffect
+ | Int_quot _ => Functional
+ | Int_rem _ => Functional
+ | Int_sub _ => Functional
+ | Int_subCheck _ => SideEffect
+ | Int_toInt _ => Functional
+ | Int_toReal _ => Functional
+ | Int_toWord _ => Functional
+ | MLton_bogus => Functional
+ | MLton_bug => SideEffect
+ | MLton_deserialize => Moveable
+ | MLton_eq => Functional
+ | MLton_equal => Functional
+ | MLton_halt => SideEffect
+ | MLton_handlesSignals => Functional
+ | MLton_installSignalHandler => SideEffect
+ | MLton_serialize => DependsOnState
+ | MLton_size => DependsOnState
+ | MLton_touch => SideEffect
+ | Pointer_getInt _ => DependsOnState
+ | Pointer_getPointer => DependsOnState
+ | Pointer_getReal _ => DependsOnState
+ | Pointer_getWord _ => DependsOnState
+ | Pointer_setInt _ => SideEffect
+ | Pointer_setPointer => SideEffect
+ | Pointer_setReal _ => SideEffect
+ | Pointer_setWord _ => SideEffect
+ | Real_Math_acos _ => Functional
+ | Real_Math_asin _ => Functional
+ | Real_Math_atan _ => Functional
+ | Real_Math_atan2 _ => Functional
+ | Real_Math_cos _ => Functional
+ | Real_Math_exp _ => Functional
+ | Real_Math_ln _ => Functional
+ | Real_Math_log10 _ => Functional
+ | Real_Math_sin _ => Functional
+ | Real_Math_sqrt _ => Functional
+ | Real_Math_tan _ => Functional
+ | Real_abs _ => Functional
+ | Real_add _ => Functional
+ | Real_div _ => Functional
+ | Real_equal _ => Functional
+ | Real_ge _ => Functional
+ | Real_gt _ => Functional
+ | Real_ldexp _ => Functional
+ | Real_le _ => Functional
+ | Real_lt _ => Functional
+ | Real_mul _ => Functional
+ | Real_muladd _ => Functional
+ | Real_mulsub _ => Functional
+ | Real_neg _ => Functional
+ | Real_qequal _ => Functional
+ | Real_round _ => DependsOnState (* depends on rounding mode *)
+ | Real_sub _ => Functional
+ | Real_toInt _ => Functional
+ | Real_toReal _ => Functional
+ | Ref_assign => SideEffect
+ | Ref_deref => DependsOnState
+ | Ref_ref => Moveable
+ | String_toWord8Vector => Functional
+ | Thread_atomicBegin => SideEffect
+ | Thread_atomicEnd => SideEffect
+ | Thread_canHandle => DependsOnState
+ | Thread_copy => Moveable
+ | Thread_copyCurrent => SideEffect
+ | Thread_returnToC => SideEffect
+ | Thread_switchTo => SideEffect
+ | Vector_length => Functional
+ | Vector_sub => Functional
+ | Weak_canGet => DependsOnState
+ | Weak_get => DependsOnState
+ | Weak_new => Moveable
+ | Word8Array_subWord => DependsOnState
+ | Word8Array_updateWord => SideEffect
+ | Word8Vector_subWord => Functional
+ | Word8Vector_toString => Functional
+ | Word8_toChar => Functional
+ | WordVector_toIntInf => Functional
+ | Word_add _ => Functional
+ | Word_addCheck _ => SideEffect
+ | Word_andb _ => Functional
+ | Word_arshift _ => Functional
+ | Word_div _ => Functional
+ | Word_equal _ => Functional
+ | Word_ge _ => Functional
+ | Word_gt _ => Functional
+ | Word_le _ => Functional
+ | Word_lshift _ => Functional
+ | Word_lt _ => Functional
+ | Word_mod _ => Functional
+ | Word_mul _ => Functional
+ | Word_mulCheck _ => SideEffect
+ | Word_neg _ => Functional
+ | Word_notb _ => Functional
+ | Word_orb _ => Functional
+ | Word_rol _ => Functional
+ | Word_ror _ => Functional
+ | Word_rshift _ => Functional
+ | Word_sub _ => Functional
+ | Word_toInt _ => Functional
+ | Word_toIntInf => Functional
+ | Word_toIntX _ => Functional
+ | Word_toWord _ => Functional
+ | Word_toWordX _ => Functional
+ | Word_xorb _ => Functional
+ | World_save => SideEffect
end
-val array = new Name.Array_array
-val assign = new Name.Ref_assign
-val bogus = new Name.MLton_bogus
-val bug = new Name.MLton_bug
-val deref = new Name.Ref_deref
-val deserialize = new Name.MLton_deserialize
-val eq = new Name.MLton_eq
-val equal = new Name.MLton_equal
-val gcCollect = new Name.GC_collect
-val intInfEqual = new Name.IntInf_equal
-val intInfNeg = new Name.IntInf_neg
-val intInfNotb = new Name.IntInf_notb
-val reff = new Name.Ref_ref
-val serialize = new Name.MLton_serialize
-val vectorLength = new Name.Vector_length
-val vectorSub = new Name.Vector_sub
-
local
- fun make n = IntSize.memoize (new o n)
+ fun make k p = k = kind p
in
- val intAdd = make Name.Int_add
- val intAddCheck = make Name.Int_addCheck
- val intEqual = make Name.Int_equal
- val intNeg = make Name.Int_neg
- val intNegCheck = make Name.Int_negCheck
- val intMul = make Name.Int_mul
- val intMulCheck = make Name.Int_mulCheck
- val intSub = make Name.Int_sub
- val intSubCheck = make Name.Int_subCheck
+ val isFunctional = make Kind.Functional
+ val isFunctional =
+ Trace.trace ("isFunctional", layout, Bool.layout) isFunctional
+ val maySideEffect = make Kind.SideEffect
end
local
- fun make n = WordSize.memoize (new o n)
+ fun ints (s: IntSize.t) =
+ [(Int_add s),
+ (Int_addCheck s),
+ (Int_equal s),
+ (Int_ge s),
+ (Int_gt s),
+ (Int_le s),
+ (Int_lt s),
+ (Int_mul s),
+ (Int_mulCheck s),
+ (Int_neg s),
+ (Int_negCheck s),
+ (Int_quot s),
+ (Int_rem s),
+ (Int_sub s),
+ (Int_subCheck s)]
+
+ fun reals (s: RealSize.t) =
+ [(Real_Math_acos s),
+ (Real_Math_asin s),
+ (Real_Math_atan s),
+ (Real_Math_atan2 s),
+ (Real_Math_cos s),
+ (Real_Math_exp s),
+ (Real_Math_ln s),
+ (Real_Math_log10 s),
+ (Real_Math_sin s),
+ (Real_Math_sqrt s),
+ (Real_Math_tan s),
+ (Real_abs s),
+ (Real_add s),
+ (Real_div s),
+ (Real_equal s),
+ (Real_ge s),
+ (Real_gt s),
+ (Real_ldexp s),
+ (Real_le s),
+ (Real_lt s),
+ (Real_mul s),
+ (Real_muladd s),
+ (Real_mulsub s),
+ (Real_neg s),
+ (Real_qequal s),
+ (Real_round s),
+ (Real_sub s)]
+
+ fun words (s: WordSize.t) =
+ [(Word_add s),
+ (Word_addCheck s),
+ (Word_andb s),
+ (Word_arshift s),
+ (Word_div s),
+ (Word_equal s),
+ (Word_ge s),
+ (Word_gt s),
+ (Word_le s),
+ (Word_lshift s),
+ (Word_lt s),
+ (Word_mod s),
+ (Word_mul s),
+ (Word_mulCheck s),
+ (Word_neg s),
+ (Word_notb s),
+ (Word_orb s),
+ (Word_rol s),
+ (Word_ror s),
+ (Word_rshift s),
+ (Word_sub s),
+ (Word_xorb s)]
in
- val wordAdd = make Name.Word_add
- val wordAddCheck = make Name.Word_addCheck
- val wordAndb = make Name.Word_andb
- val wordEqual = make Name.Word_equal
- val wordGe = make Name.Word_ge
- val wordGt = make Name.Word_gt
- val wordLe = make Name.Word_le
- val wordLt = make Name.Word_lt
- val wordMul = make Name.Word_mul
- val wordMulCheck = make Name.Word_mulCheck
- val wordNeg = make Name.Word_neg
- val wordNotb = make Name.Word_notb
- val wordRshift = make Name.Word_rshift
- val wordSub = make Name.Word_sub
+ val all: t list =
+ [Array_array,
+ Array_array0Const,
+ Array_length,
+ Array_sub,
+ Array_toVector,
+ Array_update,
+ Char_toWord8,
+ Exn_extra,
+ Exn_name,
+ Exn_setExtendExtra,
+ Exn_setInitExtra,
+ Exn_setTopLevelHandler,
+ Exn_setTopLevelHandler,
+ GC_collect,
+ GC_pack,
+ GC_unpack,
+ IntInf_add,
+ IntInf_andb,
+ IntInf_arshift,
+ IntInf_compare,
+ IntInf_equal,
+ IntInf_gcd,
+ IntInf_lshift,
+ IntInf_mul,
+ IntInf_notb,
+ IntInf_neg,
+ IntInf_orb,
+ IntInf_quot,
+ IntInf_rem,
+ IntInf_sub,
+ IntInf_toString,
+ IntInf_toVector,
+ IntInf_toWord,
+ IntInf_xorb,
+ MLton_bogus,
+ MLton_bug,
+ MLton_deserialize,
+ MLton_eq,
+ MLton_equal,
+ MLton_halt,
+ MLton_handlesSignals,
+ MLton_installSignalHandler,
+ MLton_serialize,
+ MLton_size,
+ MLton_touch,
+ Ref_assign,
+ Ref_deref,
+ Ref_ref,
+ String_toWord8Vector,
+ Thread_atomicBegin,
+ Thread_atomicEnd,
+ Thread_canHandle,
+ Thread_copy,
+ Thread_copyCurrent,
+ Thread_returnToC,
+ Thread_switchTo,
+ Vector_length,
+ Vector_sub,
+ Weak_canGet,
+ Weak_get,
+ Weak_new,
+ Word_toIntInf,
+ WordVector_toIntInf,
+ Word8_toChar,
+ Word8Array_subWord,
+ Word8Array_updateWord,
+ Word8Vector_subWord,
+ Word8Vector_toString,
+ World_save]
+ @ List.concat [List.concatMap (IntSize.prims, ints),
+ List.concatMap (RealSize.all, reals),
+ List.concatMap (WordSize.prims, words)]
+ @ let
+ val int = IntSize.all
+ val real = RealSize.all
+ val word = WordSize.all
+ fun coerces (name, sizes, sizes') =
+ List.fold
+ (sizes, [], fn (s, ac) =>
+ List.fold (sizes', ac, fn (s', ac) => name (s, s') :: ac))
+ in
+ List.concat [coerces (Int_toInt, int, int),
+ coerces (Int_toReal, int, real),
+ coerces (Int_toWord, int, word),
+ coerces (Real_toInt, real, int),
+ coerces (Real_toReal, real, real),
+ coerces (Word_toInt, word, int),
+ coerces (Word_toIntX, word, int),
+ coerces (Word_toWord, word, word),
+ coerces (Word_toWordX, word, word)]
+ end
+ @ let
+ fun doit (all, get, set) =
+ List.concatMap (all, fn s => [get s, set s])
+ in
+ List.concat [doit (IntSize.prims, Pointer_getInt, Pointer_setInt),
+ [Pointer_getPointer, Pointer_setPointer],
+ doit (RealSize.all, Pointer_getReal, Pointer_setReal),
+ doit (WordSize.prims, Pointer_getWord, Pointer_setWord)]
+ end
end
local
- fun make (name, memo, memo') =
- let
- val f = memo (fn s => memo' (fn s' => name (s, s')))
- in
- fn (s, s') => new (f s s')
- end
- val int = IntSize.memoize
- val word = WordSize.memoize
+ val table: {hash: word,
+ prim: t,
+ string: string} HashSet.t =
+ HashSet.new {hash = #hash}
+ val () =
+ List.foreach (all, fn prim =>
+ let
+ val string = toString prim
+ val hash = String.hash string
+ val _ =
+ HashSet.lookupOrInsert (table, hash,
+ fn _ => false,
+ fn () => {hash = hash,
+ prim = prim,
+ string = string})
+ in
+ ()
+ end)
in
- val intToInt = make (Name.Int_toInt, int, int)
- val intToWord = make (Name.Int_toWord, int, word)
- val wordToInt = make (Name.Word_toInt, word, int)
- val wordToIntX = make (Name.Word_toIntX, word, int)
- val wordToWord = make (Name.Word_toWord, word, word)
+ val fromString: string -> t =
+ fn name =>
+ #prim
+ (HashSet.lookupOrInsert
+ (table, String.hash name,
+ fn {string, ...} => name = string,
+ fn () => Error.bug (concat ["unknown primitive: ", name])))
end
-
-val ffi = new o Name.FFI
-
-fun newNullary f = new (Name.FFI f)
-
-val allocTooLarge = newNullary CFunction.allocTooLarge
-
-fun ffiSymbol z = new (Name.FFI_Symbol z)
-
-val new: string -> t =
- fn name =>
- let
- val (name, kind) =
- case List.peek (Name.strings, fn (_, _, s) => s = name) of
- NONE => Error.bug (concat ["unknown primitive: ", name])
- | SOME (n, k, _) => (n, k)
- in
- make (name, kind)
- end
-val new = Trace.trace ("Prim.new", String.layout, layout) new
+val fromString =
+ Trace.trace ("Prim.fromString", String.layout, layout) fromString
fun 'a extractTargs {args: 'a vector,
deArray: 'a -> 'a,
@@ -612,9 +1021,9 @@
let
val one = Vector.new1
fun arg i = Vector.sub (args, i)
- datatype z = datatype Name.t
+ datatype z = datatype t
in
- case name prim of
+ case prim of
Array_array => one (deArray result)
| Array_array0Const => one (deArray result)
| Array_sub => one result
@@ -720,7 +1129,7 @@
fun 'a apply (p, args, varEquals) =
let
- datatype z = datatype Name.t
+ datatype z = datatype t
datatype z = datatype Const.t
val bool = ApplyResult.Bool
val int = ApplyResult.Const o Const.int
@@ -755,7 +1164,7 @@
| (Word8Vector v1, Word8Vector v2) => bool (v1 = v2)
| _ => ApplyResult.Unknown
fun allConsts (cs: Const.t list) =
- (case (name p, cs) of
+ (case (p, cs) of
(Int_add _, [Int i1, Int i2]) => io (IntX.+, i1, i2)
| (Int_addCheck _, [Int i1, Int i2]) => io (IntX.+, i1, i2)
| (Int_equal _, [Int i1, Int i2]) => bool (IntX.equals (i1, i2))
@@ -776,12 +1185,11 @@
| (Int_toWord (_, s), [Int i]) =>
word (WordX.fromIntInf (IntX.toIntInf i, s))
| (IntInf_compare, [IntInf i1, IntInf i2]) =>
- int (IntX.make
- (IntInf.fromInt (case IntInf.compare (i1, i2) of
- Relation.LESS => ~1
- | Relation.EQUAL => 0
- | Relation.GREATER => 1),
- IntSize.default))
+ int (IntX.make (IntInf.fromInt (case IntInf.compare (i1, i2) of
+ Relation.LESS => ~1
+ | Relation.EQUAL => 0
+ | Relation.GREATER => 1),
+ IntSize.default))
| (IntInf_equal, [IntInf i1, IntInf i2]) => bool (i1 = i2)
| (IntInf_toWord, [IntInf i]) =>
(case SmallIntInf.toWord i of
@@ -838,14 +1246,13 @@
| 1 => Var x
| ~1 => Apply (neg s, [x])
| _ => Unknown) handle Exn.Overflow => Unknown
- val name = name p
fun varIntInf (x, i: IntInf.t, space, inOrder) =
let
fun neg () = Apply (intInfNeg, [x, space])
fun notb () = Apply (intInfNotb, [x, space])
val i = IntInf.toInt i
in
- case name of
+ case p of
IntInf_add => if i = 0 then Var x else Unknown
| IntInf_andb => if i = 0
then intInfConst 0
@@ -907,7 +1314,9 @@
(WordX.mod
(w,
WordX.fromIntInf
- (IntInf.fromInt (WordSize.bits s), s)))
+ (IntInf.fromInt
+ (Bits.toInt (WordSize.bits s)),
+ s)))
then Var x
else Unknown
end
@@ -921,7 +1330,7 @@
then Var x
else if (WordX.>=
(w,
- WordX.fromIntInf (IntInf.fromInt
+ WordX.fromIntInf (Bits.toIntInf
(WordSize.bits s),
WordSize.default)))
then zero s
@@ -930,7 +1339,7 @@
then zero s
else Unknown
in
- case name of
+ case p of
Word_add _ => add ()
| Word_addCheck _ => add ()
| Word_andb s =>
@@ -996,7 +1405,7 @@
end
datatype z = datatype ApplyArg.t
in
- case (name, args) of
+ case (p, args) of
(IntInf_toString, [Const (IntInf i), Const (Int base), _]) =>
let
val base =
@@ -1010,7 +1419,10 @@
word8Vector (Word8.stringToVector (IntInf.format (i, base)))
end
| (_, [Con {con = c, hasArg = h}, Con {con = c', ...}]) =>
- if name = MLton_equal orelse name = MLton_eq
+ if (case p of
+ MLton_eq => true
+ | MLton_equal => true
+ | _ => false)
then if Con.equals (c, c')
then if h
then Unknown
@@ -1020,7 +1432,7 @@
| (_, [Var x, Const (Word i)]) => varWord (x, i, true)
| (_, [Const (Word i), Var x]) => varWord (x, i, false)
| (_, [Var x, Const (Int i)]) =>
- (case name of
+ (case p of
Int_add _ => add (x, i)
| Int_addCheck _ => add (x, i)
| Int_ge _ => if IntX.isMin i then t else Unknown
@@ -1049,7 +1461,7 @@
else Unknown
| _ => Unknown)
| (_, [Const (Int i), Var x]) =>
- (case name of
+ (case p of
Int_add _ => add (x, i)
| Int_addCheck _ => add (x, i)
| Int_ge _ => if IntX.isMax i then t else Unknown
@@ -1068,7 +1480,7 @@
else Unknown
| _ => Unknown)
| (_, [Const (IntInf i1), Const (IntInf i2), _]) =>
- (case name of
+ (case p of
IntInf_add => iio (IntInf.+, i1, i2)
| IntInf_andb => iio (IntInf.andb, i1, i2)
| IntInf_gcd => iio (IntInf.gcd, i1, i2)
@@ -1080,7 +1492,7 @@
| IntInf_xorb => iio (IntInf.xorb, i1, i2)
| _ => Unknown)
| (_, [Const (IntInf i1), Const (Word w2), _]) =>
- (case name of
+ (case p of
IntInf_arshift =>
intInf (IntInf.~>>
(i1, Word.fromIntInf (WordX.toIntInf w2)))
@@ -1089,7 +1501,7 @@
(i1, Word.fromIntInf (WordX.toIntInf w2)))
| _ => Unknown)
| (_, [Const (IntInf i1), _]) =>
- (case name of
+ (case p of
IntInf_neg => intInf (IntInf.~ i1)
| IntInf_notb => intInf (IntInf.notb i1)
| _ => Unknown)
@@ -1103,7 +1515,7 @@
let
datatype z = datatype ApplyResult.t
in
- case name of
+ case p of
IntInf_arshift => Var x
| IntInf_lshift => Var x
| _ => Unknown
@@ -1113,7 +1525,7 @@
if varEquals (x, y)
then let datatype z = datatype ApplyResult.t
in
- case name of
+ case p of
IntInf_andb => Var x
| IntInf_orb => Var x
| IntInf_quot => intInfConst 1
@@ -1130,7 +1542,7 @@
val f = ApplyResult.falsee
datatype z = datatype ApplyResult.t
in
- case name of
+ case p of
Int_equal _ => t
| Int_ge _ => t
| Int_gt _ => f
@@ -1181,9 +1593,9 @@
open Layout
fun one name = seq [str name, str " ", arg 0]
fun two name = seq [arg 0, str " ", str name, str " ", arg 1]
- datatype z = datatype Name.t
+ datatype z = datatype t
in
- case name p of
+ case p of
Int_mul _ => two "*?"
| Int_mulCheck _ => two "*"
| Int_add _ => two "+?"
@@ -1244,6 +1656,185 @@
| Word_sub _ => two "-"
| Word_xorb _ => two "^"
| _ => seq [layout p, str " ", Vector.layout layoutArg args]
+ end
+
+structure Type = RepType
+
+fun typeCheck (p: t, ts: Type.t vector): Type.t option =
+ let
+ fun nullary res =
+ if 0 = Vector.length ts
+ then res
+ else NONE
+ fun unary (t0, res) =
+ if 1 = Vector.length ts
+ andalso Type.isSubtype (Vector.sub (ts, 0), t0)
+ then SOME res
+ else NONE
+ fun two f =
+ if 2 = Vector.length ts
+ then f (Vector.sub (ts, 0), Vector.sub (ts, 1))
+ else NONE
+ fun twoWord f =
+ two (fn (t, t') =>
+ if Bits.equals (Type.width t, Type.width t')
+ then SOME (f (t, t'))
+ else NONE)
+ fun binary (t0, t1, res) =
+ two (fn (t0', t1') =>
+ if Type.isSubtype (Vector.sub (ts, 0), t0)
+ andalso Type.isSubtype (Vector.sub (ts, 1), t1)
+ then SOME res
+ else NONE)
+ fun ternary (t0, t1, t2, res) =
+ if 3 = Vector.length ts
+ andalso Type.isSubtype (Vector.sub (ts, 0), t0)
+ andalso Type.isSubtype (Vector.sub (ts, 1), t1)
+ andalso Type.isSubtype (Vector.sub (ts, 2), t2)
+ then SOME res
+ else NONE
+ local
+ open Type
+ in
+ val defaultInt = defaultInt
+ val defaultWord = defaultWord
+ val int = int
+ val real = real
+ val word = word o WordSize.bits
+ end
+ local
+ fun make f s = let val t = f s in unary (t, t) end
+ in
+ val intUnary = make int
+ val realUnary = make real
+ val wordUnary = make word
+ end
+ local
+ fun make f s = let val t = f s in binary (t, t, t) end
+ in
+ val intBinary = make int
+ val realBinary = make real
+ val wordBinary = make word
+ end
+ local
+ fun make f s = let val t = f s in binary (t, t, Type.bool) end
+ in
+ val intCompare = make int
+ val realCompare = make real
+ val wordCompare = make word
+ end
+ fun wordShift s = binary (word s, defaultWord, word s)
+ fun wordShift' f = two (fn (t, t') => SOME (f (t, t')))
+ fun real3 s =
+ let
+ val t = real s
+ in
+ ternary (t, t, t, t)
+ end
+ in
+ case p of
+ FFI f =>
+ let
+ val CFunction.T {args, return, ...} = f
+ in
+ if Vector.equals (ts, args, Type.isSubtype)
+ then SOME return
+ else NONE
+ end
+ | FFI_Symbol {ty, ...} => nullary (SOME ty)
+ | Int_add s => intBinary s
+ | Int_addCheck s => intBinary s
+ | Int_equal s => intCompare s
+ | Int_ge s => intCompare s
+ | Int_gt s => intCompare s
+ | Int_le s => intCompare s
+ | Int_lt s => intCompare s
+ | Int_mul s => intBinary s
+ | Int_mulCheck s => intBinary s
+ | Int_neg s => intUnary s
+ | Int_negCheck s => intUnary s
+ | Int_quot s => intBinary s
+ | Int_rem s => intBinary s
+ | Int_sub s => intBinary s
+ | Int_subCheck s => intBinary s
+ | Int_toInt (s, s') => unary (int s, int s')
+ | Int_toReal (s, s') => unary (int s, real s')
+ | Int_toWord (s, s') => unary (int s, word s')
+ | MLton_eq =>
+ two (fn (t1, t2) =>
+ if Type.isSubtype (t1, t2) orelse Type.isSubtype (t2, t1)
+ then SOME Type.bool
+ else NONE)
+ | Real_Math_acos s => realUnary s
+ | Real_Math_asin s => realUnary s
+ | Real_Math_atan s => realUnary s
+ | Real_Math_atan2 s => realBinary s
+ | Real_Math_cos s => realUnary s
+ | Real_Math_exp s => realUnary s
+ | Real_Math_ln s => realUnary s
+ | Real_Math_log10 s => realUnary s
+ | Real_Math_sin s => realUnary s
+ | Real_Math_sqrt s => realUnary s
+ | Real_Math_tan s => realUnary s
+ | Real_abs s => realUnary s
+ | Real_add s => realBinary s
+ | Real_div s => realBinary s
+ | Real_equal s => realCompare s
+ | Real_ge s => realCompare s
+ | Real_gt s => realCompare s
+ | Real_ldexp s => binary (real s, defaultInt, real s)
+ | Real_le s => realCompare s
+ | Real_lt s => realCompare s
+ | Real_mul s => realBinary s
+ | Real_muladd s => real3 s
+ | Real_mulsub s => real3 s
+ | Real_neg s => realUnary s
+ | Real_qequal s => realCompare s
+ | Real_round s => realUnary s
+ | Real_sub s => realBinary s
+ | Real_toInt (s, s') => unary (real s, int s')
+ | Real_toReal (s, s') => unary (real s, real s')
+ | Thread_returnToC => nullary (SOME Type.unit)
+ | Word_add s => twoWord Type.add
+ | Word_addCheck s => wordBinary s
+ | Word_andb s => two Type.andb
+ | Word_arshift s => wordShift s
+ | Word_div s => wordBinary s
+ | Word_equal s => wordCompare s
+ | Word_ge s => wordCompare s
+ | Word_gt s => wordCompare s
+ | Word_le s => wordCompare s
+ | Word_lshift s => wordShift' Type.lshift
+ | Word_lt s => wordCompare s
+ | Word_mod s => wordBinary s
+ | Word_mul s => twoWord Type.mul
+ | Word_mulCheck s => wordBinary s
+ | Word_neg s => wordUnary s
+ | Word_notb s => wordUnary s
+ | Word_orb s => two Type.orb
+ | Word_rol s => wordShift s
+ | Word_ror s => wordShift s
+ | Word_rshift s => wordShift' Type.rshift
+ | Word_sub s => wordBinary s
+ | Word_toInt (s, s') => unary (word s, int s')
+ | Word_toIntX (s, s') => unary (word s, int s')
+ | Word_toWord (s, s') => unary (word s, word s')
+ | Word_toWordX (s, s') => unary (word s, word s')
+ | Word_xorb s => wordBinary s
+ | _ => Error.bug (concat ["strange primitive to Prim.typeCheck: ",
+ toString p])
+ end
+
+val typeCheck =
+ Trace.trace2 ("Prim.typeCheck", layout, Vector.layout Type.layout,
+ Option.layout Type.layout)
+ typeCheck
+
+structure Name =
+ struct
+ datatype t = datatype t
+ val layout = layout
+ val toString = toString
end
end
1.57 +13 -10 mlton/mlton/atoms/prim.sig
Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- prim.sig 18 Mar 2004 03:22:22 -0000 1.56
+++ prim.sig 4 Apr 2004 06:50:14 -0000 1.57
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -13,11 +13,13 @@
structure Const: CONST
structure IntSize: INT_SIZE
structure RealSize: REAL_SIZE
+ structure RepType: REP_TYPE
structure WordSize: WORD_SIZE
- sharing CFunction.CType = CType
- sharing IntSize = CType.IntSize = Const.IntX.IntSize
- sharing RealSize = CType.RealSize = Const.RealX.RealSize
- sharing WordSize = CType.WordSize = Const.WordX.WordSize
+ sharing CType = RepType.CType
+ sharing IntSize = Const.IntX.IntSize = RepType.IntSize
+ sharing RealSize = Const.RealX.RealSize = RepType.RealSize
+ sharing RepType = CFunction.RepType
+ sharing WordSize = Const.WordX.WordSize = RepType.WordSize
end
signature PRIM =
@@ -42,7 +44,7 @@
| Exn_setTopLevelHandler (* implement exceptions *)
| FFI of CFunction.t (* ssa to rssa *)
| FFI_Symbol of {name: string,
- ty: CType.t} (* codegen *)
+ ty: RepType.t} (* codegen *)
| GC_collect (* ssa to rssa *)
| GC_pack (* ssa to rssa *)
| GC_unpack (* ssa to rssa *)
@@ -239,7 +241,7 @@
val deserialize: t
val eq: t (* pointer equality *)
val equal: t (* polymorphic equality *)
- val equals: t * t -> bool (* equality of names *)
+ val equals: t * t -> bool
val extractTargs: {args: 'a vector,
deArray: 'a -> 'a,
deArrow: 'a -> 'a * 'a,
@@ -249,7 +251,8 @@
prim: t,
result: 'a} -> 'a vector
val ffi: CFunction.t -> t
- val ffiSymbol: {name: string, ty: CType.t} -> t
+ val ffiSymbol: {name: string, ty: RepType.t} -> t
+ val fromString: string -> t
val gcCollect: t
val intInfEqual: t
val intAdd: IntSize.t -> t
@@ -280,11 +283,10 @@
*)
val maySideEffect: t -> bool
val name: t -> Name.t
- val new: string -> t
- val newNullary: CFunction.t -> t (* new of type unit -> unit *)
val reff: t
val serialize: t
val toString: t -> string
+ val typeCheck: t * RepType.t vector -> RepType.t option
val vectorLength: t
val vectorSub: t
val wordAdd: WordSize.t -> t
@@ -295,6 +297,7 @@
val wordGt: WordSize.t -> t
val wordLe: WordSize.t -> t
val wordLt: WordSize.t -> t
+ val wordLshift: WordSize.t -> t
val wordMul: WordSize.t -> t
val wordMulCheck: WordSize.t -> t
val wordRshift: WordSize.t -> t
1.2 +7 -0 mlton/mlton/atoms/profile-exp.fun
Index: profile-exp.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/profile-exp.fun,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- profile-exp.fun 10 Jan 2003 18:36:08 -0000 1.1
+++ profile-exp.fun 4 Apr 2004 06:50:14 -0000 1.2
@@ -1,3 +1,10 @@
+(* Copyright (C) 2004 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 ProfileExp (S: PROFILE_EXP_STRUCTS): PROFILE_EXP =
struct
1.3 +7 -0 mlton/mlton/atoms/profile-exp.sig
Index: profile-exp.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/profile-exp.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- profile-exp.sig 18 Mar 2004 03:22:22 -0000 1.2
+++ profile-exp.sig 4 Apr 2004 06:50:14 -0000 1.3
@@ -1,3 +1,10 @@
+(* Copyright (C) 2004 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 word = Word.t
signature PROFILE_EXP_STRUCTS =
1.4 +6 -0 mlton/mlton/atoms/real-x.fun
Index: real-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/real-x.fun,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- real-x.fun 21 Jan 2004 05:08:46 -0000 1.3
+++ real-x.fun 4 Apr 2004 06:50:14 -0000 1.4
@@ -1,3 +1,9 @@
+(* Copyright (C) 2004 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 RealX (S: REAL_X_STRUCTS): REAL_X =
struct
1.4 +7 -0 mlton/mlton/atoms/real-x.sig
Index: real-x.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/real-x.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- real-x.sig 18 Mar 2004 03:22:22 -0000 1.3
+++ real-x.sig 4 Apr 2004 06:50:14 -0000 1.4
@@ -1,3 +1,10 @@
+(* Copyright (C) 2004 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 word = Word.t
signature REAL_X_STRUCTS =
1.20 +44 -29 mlton/mlton/atoms/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/sources.cm,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- sources.cm 5 Feb 2004 06:11:41 -0000 1.19
+++ sources.cm 4 Apr 2004 06:50:14 -0000 1.20
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -19,10 +19,14 @@
signature GENERIC_SCHEME
signature ID
signature HASH_TYPE
+signature LABEL
signature PRIM
signature PROFILE_EXP
+signature PROFILE_LABEL
signature REAL_X
signature RECORD
+signature REP_TYPE
+signature RUNTIME
signature SOURCE_INFO
signature TYCON
signature TYPE_OPS
@@ -43,41 +47,52 @@
../ast/sources.cm
../control/sources.cm
-atoms.fun
-atoms.sig
-c-function.sig
-c-function.fun
-c-type.sig
-c-type.fun
+id.sig
+id.fun
(* Windows doesn't like files named con, so use con- instead. *)
-con-.fun
con-.sig
-const.fun
+con-.fun
+int-x.sig
+int-x.fun
+real-x.sig
+real-x.fun
+word-x.sig
+word-x.fun
+c-type.sig
+c-type.fun
+runtime.sig
+runtime.fun
+pointer-tycon.sig
+pointer-tycon.fun
+object-type.sig
+label.sig
+rep-type.sig
+rep-type.fun
+c-function.sig
+c-function.fun
const.sig
-ffi.fun
+const.fun
+prim.sig
+prim.fun
ffi.sig
-generic-scheme.fun
+ffi.fun
+func.sig
generic-scheme.sig
-hash-type.fun
-hash-type.sig
-id.fun
-id.sig
-int-x.fun
-int-x.sig
-prim.fun
-prim.sig
-profile-exp.fun
-profile-exp.sig
-real-x.fun
-real-x.sig
-source-info.fun
+generic-scheme.fun
+profile-label.sig
+profile-label.fun
source-info.sig
-tycon.fun
+source-info.fun
+profile-exp.sig
+profile-exp.fun
tycon.sig
-type-ops.fun
+tycon.fun
type-ops.sig
+type-ops.fun
use-name.fun
-var.fun
var.sig
-word-x.fun
-word-x.sig
+var.fun
+atoms.sig
+atoms.fun
+hash-type.sig
+hash-type.fun
1.8 +1 -1 mlton/mlton/atoms/tycon.sig
Index: tycon.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/tycon.sig,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- tycon.sig 18 Mar 2004 03:22:22 -0000 1.7
+++ tycon.sig 4 Apr 2004 06:50:14 -0000 1.8
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.11 +1 -1 mlton/mlton/atoms/type-ops.fun
Index: type-ops.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/type-ops.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- type-ops.fun 5 Mar 2004 03:50:52 -0000 1.10
+++ type-ops.fun 4 Apr 2004 06:50:14 -0000 1.11
@@ -50,7 +50,7 @@
val weak = unary Tycon.weak
end
-val word8 = word (WordSize.W 8)
+val word8 = word WordSize.byte
val word8Vector = vector word8
local
1.8 +28 -10 mlton/mlton/atoms/word-x.fun
Index: word-x.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/word-x.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- word-x.fun 18 Mar 2004 03:22:22 -0000 1.7
+++ word-x.fun 4 Apr 2004 06:50:14 -0000 1.8
@@ -3,10 +3,11 @@
open S
+type int = Int.t
type word = Word.t
val modulus: WordSize.t -> IntInf.t =
- fn s => IntInf.<< (1, Word.fromInt (WordSize.bits s))
+ fn s => IntInf.<< (1, Bits.toWord (WordSize.bits s))
local
datatype t = T of {size: WordSize.t,
@@ -39,7 +40,7 @@
val s = size w
val v' = value w'
in
- if v' >= IntInf.fromInt (WordSize.bits s)
+ if v' >= Bits.toIntInf (WordSize.bits s)
then zero s
else make (f (value w, Word.fromIntInf v'), s)
end
@@ -50,11 +51,11 @@
fun equals (w, w') = WordSize.equals (size w, size w') andalso value w = value w'
-fun fromChar (c: Char.t) = make (Int.toIntInf (Char.toInt c), WordSize.W 8)
+fun fromChar (c: Char.t) = make (Int.toIntInf (Char.toInt c), WordSize.byte)
val fromIntInf = make
-fun fromWord8 w = make (Word8.toIntInf w, WordSize.W 8)
+fun fromWord8 w = make (Word8.toIntInf w, WordSize.byte)
fun isAllOnes w = value w = modulus (size w) - 1
@@ -93,8 +94,8 @@
val shift = value w'
val s = size w
val b = WordSize.bits s
- val shift = if shift > IntInf.fromInt b
- then Word.fromInt b
+ val shift = if shift > Bits.toIntInf b
+ then Bits.toWord b
else Word.fromIntInf shift
in
make (IntInf.~>> (toIntInfX w, shift), s)
@@ -111,19 +112,36 @@
let
val s = size w
val b = WordSize.bits s
- val shift = Word.fromIntInf (value w' mod IntInf.fromInt b)
+ val shift = Word.fromIntInf (value w' mod Bits.toIntInf b)
in
- make (swap (value w, {hi = shift, lo = Word.fromInt b - shift}), s)
+ make (swap (value w, {hi = shift, lo = Bits.toWord b - shift}), s)
end
fun ror (w, w') =
let
val s = size w
val b = WordSize.bits s
- val shift = Word.fromIntInf (value w' mod IntInf.fromInt b)
+ val shift = Word.fromIntInf (value w' mod Bits.toIntInf b)
in
- make (swap (value w, {hi = Word.fromInt b - shift, lo = shift}), s)
+ make (swap (value w, {hi = Bits.toWord b - shift, lo = shift}), s)
end
+
+fun splice {hi, lo} =
+ fromIntInf (value lo
+ + IntInf.<< (value hi, Bits.toWord (WordSize.bits (size lo))),
+ WordSize.+ (size hi, size lo))
+
+fun split (w, {lo}) =
+ let
+ val {size, value} = dest w
+ val (q, r) = IntInf.quotRem (value, IntInf.<< (1, Bits.toWord lo))
+ in
+ {hi = fromIntInf (q, WordSize.fromBits (Bits.- (WordSize.bits size, lo))),
+ lo = fromIntInf (r, WordSize.fromBits lo)}
+ end
+
+fun bitIsSet (w, i: int) =
+ 1 = IntInf.rem (IntInf.~>> (value w, Word.fromInt i), 2)
local
val make: (IntInf.t * IntInf.t -> IntInf.t) -> t * t -> t =
1.5 +4 -1 mlton/mlton/atoms/word-x.sig
Index: word-x.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/word-x.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- word-x.sig 18 Mar 2004 03:22:22 -0000 1.4
+++ word-x.sig 4 Apr 2004 06:50:14 -0000 1.5
@@ -20,7 +20,8 @@
val < : t * t -> bool
val >= : t * t -> bool
val <= : t * t -> bool
- val andb: t * t -> t
+ val andb: t * t -> t
+ val bitIsSet: t * Int.t -> bool
val div: t * t -> t
val equals: t * t -> bool
val fromChar: char -> t (* returns a word of size 8 *)
@@ -41,6 +42,8 @@
val rol: t * t -> t
val ror: t * t -> t
val size: t -> WordSize.t
+ val splice: {hi: t, lo: t} -> t
+ val split: t * {lo: Bits.t} -> {hi: t, lo: t}
val toChar: t -> char
val toIntInf: t -> IntInf.t
val toIntInfX: t -> IntInf.t
1.1 mlton/mlton/atoms/func.sig
Index: func.sig
===================================================================
signature FUNC = ID
1.1 mlton/mlton/atoms/label.sig
Index: label.sig
===================================================================
signature LABEL = ID
1.1 mlton/mlton/atoms/object-type.fun
<<Binary file>>
1.1 mlton/mlton/atoms/object-type.sig
Index: object-type.sig
===================================================================
signature OBJECT_TYPE =
sig
structure PointerTycon: POINTER_TYCON
structure Runtime: RUNTIME
type ty
datatype t =
Array of ty
| Normal of ty
| Stack
| Weak of ty (* in Weak t, must have Type.isPointer t *)
| WeakGone
val basic: (PointerTycon.t * t) vector
val isOk: t -> bool
val layout: t -> Layout.t
val toRuntime: t -> Runtime.RObjectType.t
end
1.1 mlton/mlton/atoms/pointer-tycon.fun
Index: pointer-tycon.fun
===================================================================
(* Copyright (C) 2004 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 PointerTycon (S: POINTER_TYCON_STRUCTS): POINTER_TYCON =
struct
type int = Int.t
datatype t = T of {index: int}
local
fun make f (T r) = f r
in
val index = make #index
end
fun fromIndex i = T {index = i}
fun compare (p, p') = Int.compare (index p, index p')
fun equals (pt, pt') = index pt = index 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}
(* 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,WEAK_GONE,WORD_VECTOR}_TYPE_INDEX.
*)
val stack = new ()
val word8Vector = new ()
val thread = new ()
val weakGone = new ()
val wordVector = new ()
end
1.1 mlton/mlton/atoms/pointer-tycon.sig
Index: pointer-tycon.sig
===================================================================
(* Copyright (C) 2004 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.
*)
signature POINTER_TYCON_STRUCTS =
sig
end
signature POINTER_TYCON =
sig
include POINTER_TYCON_STRUCTS
type t
val <= : t * t -> bool
val compare: t * t -> Relation.t
val equals: t * t -> bool
val fromIndex: Int.t -> t
val index: t -> Int.t (* index into objectTypes array *)
val layout: t -> Layout.t
val new: unit -> t
val stack: t
val thread: t
val toString: t -> string
val weakGone: t
val wordVector: t
val word8Vector: t
end
1.3 +4 -0 mlton/mlton/atoms/profile-label.fun
1.3 +0 -3 mlton/mlton/atoms/profile-label.sig
1.1 mlton/mlton/atoms/rep-type.fun
Index: rep-type.fun
===================================================================
(* Copyright (C) 2004 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 RepType (S: REP_TYPE_STRUCTS): REP_TYPE =
struct
open S
type int = Int.t
structure Type =
struct
datatype t = T of dest
and dest =
Address of t
| Constant of WordX.t
| ExnStack
| GCState
| Int of IntSize.t
| Junk of Bits.t
| Label of Label.t
| Pointer of PointerTycon.t
| Real of RealSize.t
| Seq of t vector
| Sum of t vector
| Word of Bits.t
fun dest (T d): dest = d
fun layout (t: t): Layout.t =
let
open Layout
in
case dest t of
Address t => seq [str "Address ", layout t]
| Constant w => seq [str "0x", WordX.layout w, str ":",
WordSize.layout (WordX.size w)]
| ExnStack => str "ExnStack"
| GCState => str "GCState"
| Int s => str (concat ["Int", IntSize.toString s])
| Junk b => str (concat ["Junk", Bits.toString b])
| Label l => seq [str "Label ", Label.layout l]
| Pointer p => PointerTycon.layout p
| Real s => str (concat ["Real", RealSize.toString s])
| Seq ts => List.layout layout (Vector.toList ts)
| Sum ts => paren (seq (separate (Vector.toListMap (ts, layout),
" + ")))
| Word s => str (concat ["Word", Bits.toString s])
end
val toString = Layout.toString o layout
fun compare (t, t') =
case (dest t, dest t') of
(Address t, Address t') => compare (t, t')
| (Address _, _) => LESS
| (Constant w, Constant w') =>
Relation.lexico
(WordSize.compare (WordX.size w, WordX.size w'), fn () =>
IntInf.compare (WordX.toIntInf w, WordX.toIntInf w'))
| (Constant _, _) => LESS
| (ExnStack, ExnStack) => EQUAL
| (ExnStack, _) => LESS
| (GCState, GCState) => EQUAL
| (GCState, _) => LESS
| (Int s, Int s') => IntSize.compare (s, s')
| (Int _, _) => LESS
| (Junk b, Junk b') => Bits.compare (b, b')
| (Junk _, _) => LESS
| (Label l, Label l') =>
String.compare (Label.originalName l, Label.originalName l')
| (Label _, _) => LESS
| (Pointer p, Pointer p') => PointerTycon.compare (p, p')
| (Pointer _, _) => LESS
| (Real s, Real s') => RealSize.compare (s, s')
| (Real _, _) => LESS
| (Seq ts, Seq ts') => compares (ts, ts')
| (Seq _, _) => LESS
| (Sum ts, Sum ts') => compares (ts, ts')
| (Sum _, _) => LESS
| (Word s, Word s') => Bits.compare (s, s')
| _ => GREATER
and compares (ts: t vector, ts': t vector): Relation.t =
Vector.compare (ts, ts', compare)
val {<= = lessEq, equals, ...} = Relation.compare compare
val equals =
Trace.trace2 ("Machine.Type.equals", layout, layout, Bool.layout)
equals
local
val word = Bits.inWord
in
fun width (t: t): Bits.t =
case dest t of
Address _ => word
| Constant w => WordSize.bits (WordX.size w)
| ExnStack => word
| GCState => Bits.inPointer
| Int s => IntSize.bits s
| Junk b => b
| Label _ => word
| Pointer _ => word
| Real s => RealSize.bits s
| Seq ts => Vector.fold (ts, Bits.zero, fn (t, b) =>
Bits.+ (b, width t))
| Sum ts => width (Vector.sub (ts, 0))
| Word b => b
end
val bytes = Bits.toBytes o width
val address = T o Address
val constant = T o Constant
val exnStack = T ExnStack
val gcState = T GCState
val int = T o Int
val junk = T o Junk
val label = T o Label
val pointer = T o Pointer
val real = T o Real
val word = T o Word
val char = word Bits.inByte
fun isUnit t = Bits.zero = width t
local
fun seqOnto (ts: t vector, ts': t list): t list =
Vector.foldr (ts, ts', fn (t, ts) =>
if isUnit t
then ts
else
case (dest t, ts) of
(Constant w, t' :: ts') =>
(case dest t' of
Constant w' =>
constant (WordX.splice {hi = w',
lo = w})
:: ts'
| _ => t :: ts)
| (Seq ts', _) => seqOnto (ts', ts)
| (Word s, t' :: ts') =>
(case dest t' of
Word s' =>
word (Bits.+ (s, s')) :: ts'
| _ => t :: ts)
| _ => t :: ts)
in
fun seq ts =
case seqOnto (ts, []) of
[t] => t
| ts => T (Seq (Vector.fromList ts))
end
val unit = seq (Vector.new0 ())
fun sum (ts: t vector): t =
if 1 <= Vector.length ts
andalso
let
val w = width (Vector.sub (ts, 0))
in
Vector.forall (ts, fn t => Bits.equals (w, width t))
end
then
let
val ts =
Vector.removeDuplicates
(QuickSort.sortVector (ts, lessEq), equals)
in
if 1 = Vector.length ts
then Vector.sub (ts, 0)
else T (Sum ts)
end
else Error.bug "invalid sum"
val sum = Trace.trace ("Type.sum", Vector.layout layout, layout) sum
val bool = sum (Vector.new2
(constant (WordX.fromIntInf (0, WordSize.default)),
constant (WordX.fromIntInf (1, WordSize.default))))
fun cPointer () = word Bits.inPointer
fun isCPointer t =
case dest t of
Word b => Bits.equals (b, Bits.inPointer)
| _ => false
val defaultInt = int IntSize.default
val defaultWord = word Bits.inWord
val word8 = word Bits.inByte
val stack = pointer PointerTycon.stack
val thread = pointer PointerTycon.thread
val wordVector = pointer PointerTycon.wordVector
val word8Vector = pointer PointerTycon.word8Vector
val string = word8Vector
val intInf: t =
sum (Vector.new2
(wordVector,
seq (Vector.new2
(constant (WordX.fromIntInf
(1, WordSize.fromBits (Bits.fromInt 1))),
int (IntSize.I (Bits.fromInt 31))))))
local
fun make is t =
case dest t of
Constant w => is w
| _ => false
in
val isOne = make WordX.isOne
val isZero = make WordX.isZero
end
fun isBool t =
case dest t of
Sum ts =>
2 = Vector.length ts
andalso isZero (Vector.sub (ts, 0))
andalso isOne (Vector.sub (ts, 1))
| _ => false
fun isReal t =
case dest t of
Real _ => true
| _ => false
fun isPointer t =
case dest t of
Pointer _ => true
| Sum ts => Vector.exists (ts, isPointer)
| _ => false
val traceSplit =
Trace.trace2 ("Type.split", layout,
fn {lo} => Layout.record [("lo", Bits.layout lo)],
fn {hi, lo} =>
Layout.record [("hi", layout hi),
("lo", layout lo)])
fun split arg: {hi: t, lo: t} =
traceSplit
(fn (t: t, {lo: Bits.t}) =>
let
val w = width t
in
if Bits.> (lo, w)
then Error.bug "Type.split"
else if Bits.isZero lo
then {lo = unit, hi = t}
else if Bits.equals (lo, w)
then {lo = t, hi = unit}
else
let
val hi = Bits.- (w, lo)
in
case dest t of
Constant c =>
let
val {hi = hiW, lo = loW} =
WordX.split (c, {lo = lo})
in
{hi = constant hiW,
lo = constant loW}
end
| Junk _ =>
{hi = junk hi,
lo = junk lo}
| Seq ts =>
let
fun loop (i: int, lo: Bits.t, ac: t list)
: {hi: t, lo: t} =
let
val t = Vector.sub (ts, i)
val w = width t
in
if Bits.> (lo, w)
then loop (i + 1, Bits.- (lo, w),
t :: ac)
else
let
val {hi, lo} =
split (t, {lo = lo})
val hi =
seq
(Vector.fromList
(hi ::
(Vector.toList
(Vector.dropPrefix
(ts, i + 1)))))
val lo =
seq (Vector.fromListRev
(lo :: ac))
in
{hi = hi, lo = lo}
end
end
in
loop (0, lo, [])
end
| Sum ts =>
let
val all = Vector.map (ts, fn t =>
split (t, {lo = lo}))
fun make f = sum (Vector.map (all, f))
in
{hi = make #hi,
lo = make #lo}
end
| _ => {hi = word hi,
lo = word lo}
end
end) arg
fun prefix (t, b) = #lo (split (t, {lo = b}))
fun dropSuffix (t, b) = prefix (t, Bits.- (width t, b))
fun dropPrefix (t, b) = #hi (split (t, {lo = b}))
fun suffix (t, b) = dropPrefix (t, Bits.- (width t, b))
fun fragment (t: t, {start, width}): t =
prefix (dropPrefix (t, start), width)
val fragment =
Trace.trace2 ("Type.fragment",
layout,
fn {start, width} =>
Layout.record [("start", Bits.layout start),
("width", Bits.layout width)],
layout)
fragment
fun isSubtype (t: t, t': t): bool =
Bits.equals (width t, width t')
andalso
(equals (t, t')
orelse
(case (dest t, dest t') of
(Address t, Address t') => isSubtype (t, t')
| (Seq ts, Sum ts') =>
(* Multiply out any sums in the sequence, and check that each
* resulting sequence is in one of the ts'. This is sound,
* but not complete. For example, it won't show that
* Word4 is a subtype of (Word3 * 1) + (Word3 * 0).
*)
let
val flat =
Vector.foldr
(ts, [[]], fn (t, tss) =>
let
fun cons (t, ac) =
List.fold (tss, ac, fn (ts, ac) =>
(t :: ts) :: ac)
in
case dest t of
Sum ts => Vector.fold (ts, [], cons)
| _ => cons (t, [])
end)
in
List.forall (flat, fn ts =>
let
val t = seq (Vector.fromList ts)
in
Vector.exists (ts', fn t' =>
isSubtype (t, t'))
end)
end
| (Seq ts, Word _) =>
Vector.forall (ts, fn t => isSubtype (t, word (width t)))
(* | (Word _, Sum _) => *)
| (_, Junk _) => true
| (Junk _, _) => false
| (_, Seq ts') =>
let
val n' = Vector.length ts'
fun loop (i, t) =
let
val t' = Vector.sub (ts', i)
val i = i + 1
in
if i = n'
then isSubtype (t, t')
else
let
val {hi, lo} = split (t, {lo = width t'})
in
isSubtype (lo, t') andalso loop (i, hi)
end
end
in
loop (0, t)
end
| (Sum ts, _) => Vector.forall (ts, fn t => isSubtype (t, t'))
| (_, Sum ts') => Vector.exists (ts', fn t' => isSubtype (t, t'))
| (_, Word _) => true
| _ => false))
val isSubtype =
Trace.trace2 ("Type.isSubtype", layout, layout, Bool.layout) isSubtype
fun isValidInit (t, v) =
let
val (_, ts) =
Vector.fold
(v, (Bytes.zero, []), fn ({offset, ty}, (last, ts)) =>
let
val ts =
if Bytes.equals (last, offset)
then ts
else junk (Bytes.toBits (Bytes.- (offset, last))) :: ts
in
(Bytes.+ (offset, bytes ty), ty :: ts)
end)
val init = seq (Vector.fromListRev ts)
val init =
if Bits.equals (width t, width init)
then init
else seq (Vector.new2 (init, junk (Bits.- (width t, width init))))
in
isSubtype (init, t)
end
val isValidInit =
Trace.trace2 ("Type.isValidInit",
layout,
Vector.layout (fn {offset, ty} =>
Layout.record
[("offset", Bytes.layout offset),
("ty", layout ty)]),
Bool.layout)
isValidInit
fun binaryWord (t1: t, t2: t): t =
let
val w = width t1
val t = word w
in
if isSubtype (t1, t) andalso isSubtype (t2, t)
then t
else junk w
end
fun add (t1: t, t2: t): t =
if width t1 <> width t2
then Error.bug "Type.add"
else
case dest t1 of
Address t =>
let
val w = width t
val m =
Bits.fromWord (Word.maxPow2ThatDivides
(Bytes.toWord (Bits.toBytes w)))
in
if isSubtype
(t2, seq (Vector.new2
(constant (WordX.zero (WordSize.fromBits m)),
word (Bits.- (w, m)))))
then t1
else junk (width t1)
end
| _ => binaryWord (t1, t2)
val add = Trace.trace2 ("Type.add", layout, layout, layout) add
fun mulConstant (t: t, w: WordX.t): t =
case dest t of
Constant w' => constant (WordX.* (w, w'))
| _ =>
let
val n = width t
val t' = word n
in
if isSubtype (t, t')
then
let
val lo =
Bits.fromWord
(IntInf.maxPow2ThatDivides (WordX.toIntInf w))
in
seq (Vector.new2
(constant (WordX.zero (WordSize.fromBits lo)),
word (Bits.- (n, lo))))
end
else junk n
end
fun mul (t: t, t': t): t =
if width t <> width t'
then Error.bug "Type.mul"
else
case (dest t, dest t') of
(Constant w, _) => mulConstant (t', w)
| (_, Constant w') => mulConstant (t, w')
| _ => binaryWord (t, t')
val mul = Trace.trace2 ("Type.mul", layout, layout, layout) mul
fun shift (t1, t2) =
let
val w = width t1
val t1' = word w
val t2' = word (width t2)
in
if isSubtype (t1, t1') andalso isSubtype (t2, t2')
then t1'
else junk w
end
fun lshift (t, t'): t =
case dest t' of
Constant w =>
let
val shift = Bits.fromIntInf (WordX.toIntInf w)
in
seq (Vector.new2 (constant (WordX.zero (WordSize.fromBits shift)),
dropSuffix (t, shift)))
end
| _ => shift (t, t')
val lshift = Trace.trace2 ("Type.lshift", layout, layout, layout) lshift
fun rshift (t, t'): t =
case dest t' of
Constant w =>
let
val shift = Bits.fromIntInf (WordX.toIntInf w)
in
seq (Vector.new2 (dropPrefix (t, shift),
constant (WordX.zero
(WordSize.fromBits shift))))
end
| _ => shift (t, t')
val rshift = Trace.trace2 ("Type.rshift", layout, layout, layout) rshift
local
fun make (name: string,
const: WordX.t * WordX.t -> WordX.t,
bit: bool -> t)
: t * t -> t option =
let
val rec doit: t * t -> t option =
fn (t, t') =>
if not (Bits.equals (width t, width t'))
then NONE
else
case (dest t, dest t') of
(Constant w, _) => SOME (doConstant (t', w))
| (_, Constant w') => SOME (doConstant (t, w'))
| (Word _, Word _) => SOME t
| _ => NONE
and doConstant: t * WordX.t -> t =
fn (t, w) =>
if not (Bits.equals (width t, WordSize.bits (WordX.size w)))
then Error.bug (concat ["Type.", name, "Constant"])
else
case dest t of
Constant w' => constant (const (w, w'))
| Seq ts =>
seq
(Vector.fromListRev
(#2
(Vector.fold
(ts, (w, []), fn (t, (w, ac)) =>
let
val {hi, lo} = WordX.split (w, {lo = width t})
in
(hi, doConstant (t, lo) :: ac)
end))))
| Sum ts =>
sum (Vector.map (ts, fn t => doConstant (t, w)))
| Word _ =>
seq (Vector.tabulate
(Bits.toInt (width t), fn i =>
bit (WordX.bitIsSet (w, i))))
| _ =>
junk (width t)
in
doit
end
in
val andb = make ("andb", WordX.andb, fn b =>
if b
then word (Bits.fromInt 1)
else constant (WordX.zero WordSize.one))
val orb = make ("orb", WordX.orb,
fn b =>
if b
then constant (WordX.one WordSize.one)
else word (Bits.fromInt 1))
end
local
structure C =
struct
open CType
val defaultWord = Word32
val pointer = Word32
fun fromBits (b: Bits.t): t =
case Bits.toInt b of
8 => Word8
| 16 => Word16
| 32 => Word32
| 64 => Word64
| _ => Error.bug (concat ["CType.fromBits: ",
Bits.toString b])
val fromIntSize = fromBits o IntSize.bits
val fromWordSize = fromBits o WordSize.bits
end
fun w i = word (Bits.fromInt i)
in
val fromCType: CType.t -> t =
fn C.Pointer => w 32
| C.Real32 => real RealSize.R32
| C.Real64 => real RealSize.R64
| C.Word8 => w 8
| C.Word16 => w 16
| C.Word32 => w 32
| C.Word64 => w 64
val rec toCType: t -> CType.t =
fn t =>
if isPointer t
then C.Pointer
else
case dest t of
Real s =>
(case s of
RealSize.R32 => C.Real32
| RealSize.R64 => C.Real64)
| _ => C.fromBits (width t)
val name = C.name o toCType
fun align (t: t, n: Bytes.t): Bytes.t = C.align (toCType t, n)
end
fun bytesAndPointers (t: t): Bytes.t * int =
case dest t of
Pointer _ => (Bytes.zero, 1)
| Seq ts =>
(case Vector.peeki (ts, isPointer o #2) of
NONE => (bytes t, 0)
| SOME (i, _) =>
let
val b = bytes (seq (Vector.prefix (ts, i)))
in
(b, (Bytes.toInt (Bytes.- (bytes t, b))
div Bytes.toInt Bytes.inPointer))
end)
| Sum ts =>
Vector.fold
(ts, (bytes t, 0), fn (t, (b, p)) =>
let
val (b', p') = bytesAndPointers t
in
if Bytes.< (b', b)
then (b', p')
else (b, p)
end)
| _ => (bytes t, 0)
end
structure ObjectType =
struct
structure PointerTycon = PointerTycon
structure Runtime = Runtime
type ty = Type.t
datatype t =
Array of Type.t
| Normal of Type.t
| Stack
| Weak of Type.t
| WeakGone
fun layout (t: t) =
let
open Layout
in
case t of
Array t => seq [str "Array ", Type.layout t]
| Normal t => seq [str "Normal ", Type.layout t]
| Stack => str "Stack"
| Weak t => seq [str "Weak ", Type.layout t]
| WeakGone => str "WeakGone"
end
fun isOk (t: t): bool =
case t of
Array t => Bits.isByteAligned (Type.width t)
| Normal t =>
not (Type.isUnit t) andalso Bits.isWordAligned (Type.width t)
| Stack => true
| Weak t => Type.isPointer t
| WeakGone => true
val stack = Stack
val thread =
Normal (Type.seq
(Vector.new3 (Type.defaultWord,
Type.defaultWord,
Type.stack)))
val word8Vector = Array Type.word8
val wordVector = Array Type.defaultWord
val basic =
Vector.fromList
[(PointerTycon.stack, stack),
(PointerTycon.thread, thread),
(PointerTycon.weakGone, WeakGone),
(PointerTycon.wordVector, wordVector),
(PointerTycon.word8Vector, word8Vector)]
local
structure R = Runtime.RObjectType
in
fun toRuntime (t: t): R.t =
case t of
Array t => let
val (b, p) = Type.bytesAndPointers t
in
R.Array {nonPointer = b,
pointers = p}
end
| Normal t => let
val (b, p) = Type.bytesAndPointers t
in
R.Normal {nonPointer = Bytes.toWords b,
pointers = p}
end
| Stack => R.Stack
| Weak _ => R.Weak
| WeakGone => R.WeakGone
end
end
open Type
fun pointerHeader p =
constant (WordX.fromIntInf
(1 + 2 * Int.toIntInf (PointerTycon.index p),
WordSize.default))
fun offset (t: t, {offset, pointerTy, width}): t option =
let
fun frag t =
fragment (t, {start = Bytes.toBits offset,
width = width})
fun doit t =
case dest t of
Address t => SOME (frag t)
| Pointer p =>
if Bytes.equals (offset, Runtime.headerOffset)
then SOME (pointerHeader p)
else
(case pointerTy p of
ObjectType.Array _ =>
if Bytes.equals (offset, Runtime.arrayLengthOffset)
then SOME Type.defaultInt
else NONE
| ObjectType.Normal t => SOME (frag t)
| _ => NONE)
| Sum ts =>
let
val ts' = Vector.keepAllMap (ts, doit)
in
if Vector.length ts = Vector.length ts'
then SOME (sum ts')
else NONE
end
| _ => NONE
in
doit t
end
val offset =
Trace.trace2
("Type.offset",
layout,
fn {offset, width, ...} =>
Layout.record [("offset", Bytes.layout offset),
("width", Bits.layout width)],
Option.layout layout)
offset
structure GCField = Runtime.GCField
fun ofGCField (f: GCField.t): t =
let
datatype z = datatype GCField.t
in
case f of
CanHandle => defaultWord
| CardMap => cPointer ()
| CurrentThread => cPointer ()
| ExnStack => defaultWord
| Frontier => cPointer ()
| Limit => cPointer ()
| LimitPlusSlop => cPointer ()
| MaxFrameSize => defaultWord
| SignalIsPending => bool
| StackBottom => cPointer ()
| StackLimit => cPointer ()
| StackTop => cPointer ()
end
fun castIsOk _ = true
end
1.1 mlton/mlton/atoms/rep-type.sig
Index: rep-type.sig
===================================================================
(* Copyright (C) 2004 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.
*)
signature REP_TYPE_STRUCTS =
sig
structure CType: C_TYPE
structure IntSize: INT_SIZE
structure IntX: INT_X
structure Label: LABEL
structure PointerTycon: POINTER_TYCON
structure RealSize: REAL_SIZE
structure Runtime: RUNTIME
structure WordSize: WORD_SIZE
structure WordX: WORD_X
sharing IntSize = IntX.IntSize
sharing WordSize = WordX.WordSize
end
signature REP_TYPE =
sig
include REP_TYPE_STRUCTS
structure ObjectType: OBJECT_TYPE
(*
* - Junk is used for padding. You can stick any value in, but you
* can't get any value out.
* - In Seq, the components are listed in increasing order of
* address.
* - In Seq ts, length ts <> 1
* - In Sum ts, length ts >= 2
* - In Sum ts, all t in ts must have same width.
* - In Sum ts, there are no duplicates, and the types are in order.
*)
type t
sharing type t = ObjectType.ty
datatype dest =
Address of t (* an internal pointer *)
| Constant of WordX.t
| ExnStack
| GCState (* The address of gcState. *)
| Int of IntSize.t
| Junk of Bits.t
| Label of Label.t
| Pointer of PointerTycon.t
| Real of RealSize.t
| Seq of t vector
| Sum of t vector
| Word of Bits.t
val add: t * t -> t
val address: t -> t
val align: t * Bytes.t -> Bytes.t
val andb: t * t -> t option
val bool: t
val bytes: t -> Bytes.t
val castIsOk: {from: t,
fromInt: IntX.t option,
to: t,
tyconTy: PointerTycon.t -> ObjectType.t} -> bool
val char: t
val cPointer: unit -> t
val constant: WordX.t -> t
val defaultInt: t
val defaultWord: t
val dest: t -> dest
val equals: t * t -> bool
val exnStack: t
val fragment: t * {start: Bits.t, width: Bits.t} -> t
val fromCType: CType.t -> t
val gcState: t
val int: IntSize.t -> t
val intInf: t
val isBool: t -> bool
val isCPointer: t -> bool
val isPointer: t -> bool
val isUnit: t -> bool
val isValidInit: t * {offset: Bytes.t, ty: t} vector -> bool
val isReal: t -> bool
val isSubtype: t * t -> bool
val junk: Bits.t -> t
val label: Label.t -> t
val layout: t -> Layout.t
val lshift: t * t -> t
val mul: t * t -> t
val name: t -> string (* simple one letter abbreviation *)
val ofGCField: Runtime.GCField.t -> t
val offset: t * {offset: Bytes.t,
pointerTy: PointerTycon.t -> ObjectType.t,
width: Bits.t} -> t option
val orb: t * t -> t option
val pointer: PointerTycon.t -> t
val pointerHeader: PointerTycon.t -> t
val real: RealSize.t -> t
val rshift: t * t -> t
val seq: t vector -> t
val string: t
val sum: t vector -> t
val thread: t
val toCType: t -> CType.t
val toString: t -> string
val unit: t
val width: t -> Bits.t
val word: Bits.t -> t
val word8: t
val wordVector: t
val word8Vector: t
end
1.1 mlton/mlton/atoms/runtime.fun
Index: runtime.fun
===================================================================
(* Copyright (C) 2002-2004 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 Runtime (S: RUNTIME_STRUCTS): RUNTIME =
struct
open S
structure GCField =
struct
datatype t =
CanHandle
| CardMap
| CurrentThread
| ExnStack
| Frontier
| Limit
| LimitPlusSlop
| MaxFrameSize
| SignalIsPending
| StackBottom
| StackLimit
| StackTop
val equals: t * t -> bool = op =
(* val ty =
* fn CanHandle => CType.defaultInt
* | CardMap => CType.pointer
* | CurrentThread => CType.pointer
* | ExnStack => CType.defaultWord
* | Frontier => CType.pointer
* | Limit => CType.pointer
* | LimitPlusSlop => CType.pointer
* | MaxFrameSize => CType.defaultWord
* | SignalIsPending => CType.defaultInt
* | StackBottom => CType.pointer
* | StackLimit => CType.pointer
* | StackTop => CType.pointer
*)
val canHandleOffset: Bytes.t ref = ref Bytes.zero
val cardMapOffset: Bytes.t ref = ref Bytes.zero
val currentThreadOffset: Bytes.t ref = ref Bytes.zero
val exnStackOffset: Bytes.t ref = ref Bytes.zero
val frontierOffset: Bytes.t ref = ref Bytes.zero
val limitOffset: Bytes.t ref = ref Bytes.zero
val limitPlusSlopOffset: Bytes.t ref = ref Bytes.zero
val maxFrameSizeOffset: Bytes.t ref = ref Bytes.zero
val signalIsPendingOffset: Bytes.t ref = ref Bytes.zero
val stackBottomOffset: Bytes.t ref = ref Bytes.zero
val stackLimitOffset: Bytes.t ref = ref Bytes.zero
val stackTopOffset: Bytes.t ref = ref Bytes.zero
fun setOffsets {canHandle, cardMap, currentThread, exnStack, frontier,
limit, limitPlusSlop, maxFrameSize, signalIsPending,
stackBottom, stackLimit, stackTop} =
(canHandleOffset := canHandle
; cardMapOffset := cardMap
; currentThreadOffset := currentThread
; exnStackOffset := exnStack
; frontierOffset := frontier
; limitOffset := limit
; limitPlusSlopOffset := limitPlusSlop
; maxFrameSizeOffset := maxFrameSize
; signalIsPendingOffset := signalIsPending
; stackBottomOffset := stackBottom
; stackLimitOffset := stackLimit
; stackTopOffset := stackTop)
val offset =
fn CanHandle => !canHandleOffset
| CardMap => !cardMapOffset
| CurrentThread => !currentThreadOffset
| ExnStack => !exnStackOffset
| Frontier => !frontierOffset
| Limit => !limitOffset
| LimitPlusSlop => !limitPlusSlopOffset
| MaxFrameSize => !maxFrameSizeOffset
| SignalIsPending => !signalIsPendingOffset
| StackBottom => !stackBottomOffset
| StackLimit => !stackLimitOffset
| StackTop => !stackTopOffset
val toString =
fn CanHandle => "CanHandle"
| CardMap => "CardMap"
| CurrentThread => "CurrentThread"
| ExnStack => "ExnStack"
| Frontier => "Frontier"
| Limit => "Limit"
| LimitPlusSlop => "LimitPlusSlop"
| MaxFrameSize => "MaxFrameSize"
| SignalIsPending => "SignalIsPending"
| StackBottom => "StackBottom"
| StackLimit => "StackLimit"
| StackTop => "StackTop"
val layout = Layout.str o toString
end
structure RObjectType =
struct
datatype t =
Array of {nonPointer: Bytes.t,
pointers: int}
| Normal of {nonPointer: Words.t,
pointers: int}
| Stack
| Weak
| WeakGone
fun layout (t: t): Layout.t =
let
open Layout
in
case t of
Array {nonPointer = np, pointers = p} =>
seq [str "Array ",
record [("nonPointer", Bytes.layout np),
("pointers", Int.layout p)]]
| Normal {nonPointer = np, pointers = p} =>
seq [str "Normal ",
record [("nonPointer", Words.layout np),
("pointers", Int.layout p)]]
| Stack => str "Stack"
| Weak => str "Weak"
| WeakGone => str "WeakGone"
end
val _ = layout (* quell unused warning *)
end
val maxTypeIndex = Int.pow (2, 19)
fun typeIndexToHeader typeIndex =
(Assert.assert ("Runtime.header", fn () =>
0 <= typeIndex
andalso typeIndex < maxTypeIndex)
; Word.orb (0w1, Word.<< (Word.fromInt typeIndex, 0w1)))
fun headerToTypeIndex w = Word.toInt (Word.>> (w, 0w1))
val arrayHeaderSize = Bytes.scale (Bytes.inWord, 3)
val intInfOverhead = Bytes.+ (arrayHeaderSize, Bytes.inWord) (* for the sign *)
val labelSize = Bytes.inWord
val limitSlop = Bytes.fromInt 512
val normalHeaderSize = Bytes.inWord
val pointerSize = Bytes.inWord
val array0Size =
Bytes.+ (arrayHeaderSize, Bytes.inWord) (* for the forwarding pointer *)
val arrayLengthOffset = Bytes.~ (Bytes.scale (Bytes.inWord, 2))
val allocTooLarge = Bytes.fromWord 0wxFFFFFFFC
val headerOffset = Bytes.~ Bytes.inWord
fun normalSize {nonPointers, pointers} =
Bytes.+ (Words.toBytes nonPointers,
Bytes.scale (pointerSize, pointers))
val maxFrameSize = Bytes.fromInt (Int.pow (2, 16))
end
1.1 mlton/mlton/atoms/runtime.sig
Index: runtime.sig
===================================================================
(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
type int = Int.t
type word = Word.t
signature RUNTIME_STRUCTS =
sig
end
signature RUNTIME =
sig
include RUNTIME_STRUCTS
structure GCField:
sig
datatype t =
CanHandle
| CardMap
| CurrentThread
| ExnStack
| Frontier (* The place where the next object is allocated. *)
| Limit (* frontier + heapSize - LIMIT_SLOP *)
| LimitPlusSlop (* frontier + heapSize *)
| MaxFrameSize
| SignalIsPending
| StackBottom
| StackLimit (* Must have StackTop <= StackLimit *)
| StackTop (* Points at the next available word on the stack. *)
val equals: t * t -> bool
val layout: t -> Layout.t
val offset: t -> Bytes.t (* Field offset in struct GC_state. *)
val setOffsets: {canHandle: Bytes.t,
cardMap: Bytes.t,
currentThread: Bytes.t,
exnStack: Bytes.t,
frontier: Bytes.t,
limit: Bytes.t,
limitPlusSlop: Bytes.t,
maxFrameSize: Bytes.t,
signalIsPending: Bytes.t,
stackBottom: Bytes.t,
stackLimit: Bytes.t,
stackTop: Bytes.t} -> unit
val toString: t -> string
end
structure RObjectType:
sig
datatype t =
Array of {nonPointer: Bytes.t,
pointers: int}
| Normal of {nonPointer: Words.t,
pointers: int}
| Stack
| Weak
| WeakGone
end
val allocTooLarge: Bytes.t
val arrayHeaderSize: Bytes.t
val arrayLengthOffset: Bytes.t
val array0Size: Bytes.t
val headerOffset: Bytes.t
val headerToTypeIndex: word -> int
val intInfOverhead: Bytes.t
val labelSize: Bytes.t
(* Same as LIMIT_SLOP from gc.c. *)
val limitSlop: Bytes.t
val maxFrameSize: Bytes.t
val normalHeaderSize: Bytes.t
(* normalBytes does not include the header. *)
val normalSize: {nonPointers: Words.t,
pointers: int} -> Bytes.t
val pointerSize: Bytes.t
val typeIndexToHeader: int -> word
end
1.31 +52 -40 mlton/mlton/backend/allocate-registers.fun
Index: allocate-registers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.fun,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- allocate-registers.fun 19 Feb 2004 22:42:09 -0000 1.30
+++ allocate-registers.fun 4 Apr 2004 06:50:16 -0000 1.31
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -9,6 +9,7 @@
struct
open S
+
structure R = Rssa
local
@@ -17,6 +18,7 @@
structure Func = Func
structure Function = Function
structure Kind = Kind
+ structure Label = Label
structure Type = Type
structure Var = Var
end
@@ -38,41 +40,41 @@
sig
type t
- val get: t * Type.t -> t * {offset: int}
+ val get: t * Type.t -> t * {offset: Bytes.t}
val layout: t -> Layout.t
- val new: {offset: int, ty: Type.t} list -> t
- val size: t -> int
+ val new: {offset: Bytes.t, ty: Type.t} list -> t
+ val size: t -> Bytes.t
end
type t
val getRegister: t * Type.t -> Register.t
- val getStack: t * Type.t -> {offset: int}
+ val getStack: t * Type.t -> {offset: Bytes.t}
val layout: t -> Layout.t
- val new: {offset: int, ty: Type.t} list * Register.t list -> t
+ val new: {offset: Bytes.t, ty: Type.t} list * Register.t list -> t
val stack: t -> Stack.t
- val stackSize: t -> int
+ val stackSize: t -> Bytes.t
end =
struct
structure Stack =
struct
(* Keep a list of allocated slots sorted in increasing order of offset.
*)
- datatype t = T of {offset: int, size: int} list
+ datatype t = T of {offset: Bytes.t, size: Bytes.t} list
fun layout (T alloc) =
List.layout (fn {offset, size} =>
- Layout.record [("offset", Int.layout offset),
- ("size", Int.layout size)])
+ Layout.record [("offset", Bytes.layout offset),
+ ("size", Bytes.layout size)])
alloc
fun size (T alloc) =
case alloc of
- [] => 0
+ [] => Bytes.zero
| _ => let
val {offset, size} = List.last alloc
in
- offset + size
+ Bytes.+ (offset, size)
end
fun new (alloc): t =
@@ -80,29 +82,29 @@
(QuickSort.sortArray
(Array.fromListMap (alloc, fn {offset, ty} =>
{offset = offset,
- size = Type.size ty}),
- fn (r, r') => #offset r <= #offset r')))
+ size = Type.bytes ty}),
+ fn (r, r') => Bytes.<= (#offset r, #offset r'))))
fun get (T alloc, ty) =
let
- val slotSize = Type.size ty
+ val slotSize = Type.bytes ty
in
case alloc of
- [] => (T [{offset = 0, size = slotSize}],
- {offset = 0})
+ [] => (T [{offset = Bytes.zero, size = slotSize}],
+ {offset = Bytes.zero})
| a :: alloc =>
let
fun loop (alloc, a as {offset, size}, ac) =
let
- val prevEnd = offset + size
+ val prevEnd = Bytes.+ (offset, size)
val begin = Type.align (ty, prevEnd)
fun coalesce () =
- if prevEnd = begin
+ if Bytes.equals (prevEnd, begin)
then ({offset = offset,
- size = size + slotSize},
+ size = Bytes.+ (size, slotSize)},
ac)
- else ({offset = begin, size = slotSize},
- {offset = offset, size = size} :: ac)
+ else ({offset = begin, size = slotSize},
+ {offset = offset, size = size} :: ac)
in
case alloc of
[] =>
@@ -112,19 +114,22 @@
(T (rev (a :: ac)), {offset = begin})
end
| (a' as {offset, size}) :: alloc =>
- if begin + slotSize > offset
+ if Bytes.> (Bytes.+ (begin, slotSize),
+ offset)
then loop (alloc, a', a :: ac)
- else
+ else
let
val (a'' as {offset = o', size = s'}, ac) =
coalesce ()
val alloc =
List.appendRev
(ac,
- if o' + s' = offset
- then {offset = o', size = size + s'}
+ if Bytes.equals (Bytes.+ (o', s'),
+ offset)
+ then {offset = o',
+ size = Bytes.+ (size, s')}
:: alloc
- else a'' :: a' :: alloc)
+ else a'' :: a' :: alloc)
in
(T alloc, {offset = begin})
end
@@ -253,13 +258,13 @@
struct
type t = {live: Operand.t vector,
liveNoFormals: Operand.t vector,
- size: int}
+ size: Bytes.t}
fun layout ({live, liveNoFormals, size, ...}: t) =
Layout.record
[("live", Vector.layout Operand.layout live),
("liveNoFormals", Vector.layout Operand.layout liveNoFormals),
- ("size", Int.layout size)]
+ ("size", Bytes.layout size)]
end
(* ------------------------------------------------- *)
@@ -367,8 +372,7 @@
let
val {offset} = Allocation.getStack (a, ty)
in
- Operand.StackOffset {ty = ty,
- offset = offset}
+ Operand.StackOffset {offset = offset, ty = ty}
end
| Register =>
Operand.Register
@@ -405,7 +409,7 @@
val (stack, {offset = handler, ...}) =
Allocation.Stack.get (stack, Type.defaultWord)
val (_, {offset = link, ...}) =
- Allocation.Stack.get (stack, Type.ExnStack)
+ Allocation.Stack.get (stack, Type.exnStack)
in
SOME {handler = handler, link = link}
end
@@ -443,7 +447,7 @@
if linkLive
then
Operand.StackOffset {offset = link,
- ty = Type.ExnStack}
+ ty = Type.exnStack}
:: ops
else ops
in
@@ -462,7 +466,7 @@
NONE => stackInit
| SOME {handler, link} =>
{offset = handler, ty = Type.defaultWord} (* should be label *)
- :: {offset = link, ty = Type.ExnStack}
+ :: {offset = link, ty = Type.exnStack}
:: stackInit
val a = Allocation.new (stackInit, registersInit)
val size =
@@ -471,17 +475,25 @@
(case handlerLinkOffset of
NONE => Error.bug "Handler with no handler offset"
| SOME {handler, ...} =>
- Runtime.labelSize + handler)
+ Bytes.+ (Runtime.labelSize, handler))
| _ =>
let
val size =
- Runtime.labelSize
- + Runtime.wordAlignInt (Allocation.stackSize a)
+ Bytes.+
+ (Runtime.labelSize,
+ Bytes.wordAlign (Allocation.stackSize a))
in
case !Control.align of
Control.Align4 => size
- | Control.Align8 => CType.align8 size
+ | Control.Align8 =>
+ Bytes.align (size, {alignment = Bytes.fromInt 8})
end
+ val _ =
+ if Bytes.isWordAligned size
+ then ()
+ else Error.bug (concat ["bad size ",
+ Bytes.toString size,
+ " in ", Label.toString label])
val _ = Vector.foreach (args, fn (x, _) => allocateVar (x, a))
(* Must compute live after allocateVar'ing the args, since that
* sets the operands for the args.
@@ -509,8 +521,8 @@
str " handlerLinkOffset ",
Option.layout
(fn {handler, link} =>
- record [("handler", Int.layout handler),
- ("link", Int.layout link)])
+ record [("handler", Bytes.layout handler),
+ ("link", Bytes.layout link)])
handlerLinkOffset])
val _ = Vector.foreach (args, diagVar o #1)
val _ =
1.15 +3 -3 mlton/mlton/backend/allocate-registers.sig
Index: allocate-registers.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/allocate-registers.sig,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- allocate-registers.sig 24 Apr 2003 20:50:46 -0000 1.14
+++ allocate-registers.sig 4 Apr 2004 06:50:16 -0000 1.15
@@ -35,8 +35,8 @@
-> {(* If handlers are used, handlerLinkOffset gives the stack offsets
* where the handler and link (old exnStack) should be stored.
*)
- handlerLinkOffset: {handler: int,
- link: int} option,
+ handlerLinkOffset: {handler: Bytes.t,
+ link: Bytes.t} option,
labelInfo:
Rssa.Label.t -> {(* Live operands at the beginning of the block. *)
live: Machine.Operand.t vector,
@@ -47,6 +47,6 @@
(* Number of bytes in frame including return
* address.
*)
- size: int
+ size: Bytes.t
}}
end
1.64 +50 -75 mlton/mlton/backend/backend.fun
Index: backend.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.fun,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- backend.fun 18 Mar 2004 03:22:23 -0000 1.63
+++ backend.fun 4 Apr 2004 06:50:16 -0000 1.64
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -203,7 +203,7 @@
val frameLayoutsCounter = Counter.new 0
val _ = IntSet.reset ()
val table = HashSet.new {hash = Word.fromInt o #frameOffsetsIndex}
- val frameOffsets: int vector list ref = ref []
+ val frameOffsets: Bytes.t vector list ref = ref []
val frameOffsetsCounter = Counter.new 0
val {get = frameOffsetsIndex: IntSet.t -> int, ...} =
Property.get
@@ -213,8 +213,9 @@
let
val _ = List.push (frameOffsets,
QuickSort.sortVector
- (Vector.fromList (IntSet.toList offsets),
- op <=))
+ (Vector.fromListMap
+ (IntSet.toList offsets, Bytes.fromInt),
+ Bytes.<=))
in
Counter.next frameOffsetsCounter
end))
@@ -230,10 +231,12 @@
end
fun getFrameLayoutsIndex {isC: bool,
label: Label.t,
- offsets: int list,
- size: int}: int =
+ offsets: Bytes.t list,
+ size: Bytes.t}: int =
let
- val foi = frameOffsetsIndex (IntSet.fromList offsets)
+ val foi =
+ frameOffsetsIndex (IntSet.fromList
+ (List.map (offsets, Bytes.toInt)))
fun new () =
let
val _ =
@@ -265,7 +268,7 @@
fn {frameOffsetsIndex = foi', isC = isC', size = s', ...} =>
foi = foi'
andalso isC = isC'
- andalso size = s',
+ andalso Bytes.equals (size, s'),
fn () => {frameLayoutsIndex = new (),
frameOffsetsIndex = foi,
isC = isC,
@@ -410,7 +413,7 @@
M.Operand.Offset {base = M.Operand.GCState,
offset = GCField.offset field,
ty = ty}
- val exnStackOp = runtimeOp (GCField.ExnStack, Type.ExnStack)
+ val exnStackOp = runtimeOp (GCField.ExnStack, Type.exnStack)
val stackBottomOp = runtimeOp (GCField.StackBottom, Type.defaultWord)
val stackTopOp = runtimeOp (GCField.StackTop, Type.defaultWord)
fun translateOperand (oper: R.Operand.t): M.Operand.t =
@@ -446,8 +449,8 @@
end
fun translateOperands ops = Vector.map (ops, translateOperand)
fun genStatement (s: R.Statement.t,
- handlerLinkOffset: {handler: int,
- link: int} option)
+ handlerLinkOffset: {handler: Bytes.t,
+ link: Bytes.t} option)
: M.Statement.t vector =
let
fun handlerOffset () = #handler (valOf handlerLinkOffset)
@@ -468,12 +471,11 @@
Vector.new1
(M.Statement.move {dst = translateOperand dst,
src = translateOperand src})
- | Object {dst, size, stores, tycon, ...} =>
+ | Object {dst, header, size, stores} =>
Vector.new1
(M.Statement.Object
- {dst = varOperand dst,
- header = (Runtime.typeIndexToHeader
- (PointerTycon.index tycon)),
+ {dst = varOperand (#1 dst),
+ header = header,
size = size,
stores = Vector.map (stores, fn {offset, value} =>
{offset = offset,
@@ -498,7 +500,8 @@
(stackTopOp,
M.Operand.Int
(IntX.defaultInt
- (handlerOffset () + Runtime.wordSize)))),
+ (Bytes.toInt
+ (Bytes.+ (handlerOffset (), Bytes.inWord)))))),
dst = SOME tmp,
prim = Prim.wordAdd WordSize.default},
M.Statement.PrimApp
@@ -512,7 +515,7 @@
(M.Statement.move
{dst = exnStackOp,
src = M.Operand.StackOffset {offset = linkOffset (),
- ty = Type.ExnStack}})
+ ty = Type.exnStack}})
| SetHandler h =>
Vector.new1
(M.Statement.move
@@ -524,7 +527,7 @@
Vector.new1
(M.Statement.move
{dst = M.Operand.StackOffset {offset = linkOffset (),
- ty = Type.ExnStack},
+ ty = Type.exnStack},
src = exnStackOp})
| _ => Error.bug (concat
["backend saw strange statement: ",
@@ -551,17 +554,17 @@
setLabelInfo
fun callReturnOperands (xs: 'a vector,
ty: 'a -> Type.t,
- shift: int): M.Operand.t vector =
+ shift: Bytes.t): M.Operand.t vector =
#1 (Vector.mapAndFold
- (xs, 0,
+ (xs, Bytes.zero,
fn (x, offset) =>
let
val ty = ty x
val offset = Type.align (ty, offset)
in
- (M.Operand.StackOffset {offset = shift + offset,
+ (M.Operand.StackOffset {offset = Bytes.+ (shift, offset),
ty = ty},
- offset + Type.size ty)
+ Bytes.+ (offset, Type.bytes ty))
end))
fun genFunc (f: Function.t, isMain: bool): unit =
let
@@ -571,7 +574,7 @@
val raises = Option.map (raises, fn ts => raiseOperands ts)
val returns =
Option.map (returns, fn ts =>
- callReturnOperands (ts, fn t => t, 0))
+ callReturnOperands (ts, fn t => t, Bytes.zero))
val chunk = funcChunk name
fun labelArgOperands (l: R.Label.t): M.Operand.t vector =
Vector.map (#args (labelInfo l), varOperand o #1)
@@ -658,7 +661,7 @@
in
val {handlerLinkOffset, labelInfo = labelRegInfo, ...} =
AllocateRegisters.allocate
- {argOperands = callReturnOperands (args, #2, 0),
+ {argOperands = callReturnOperands (args, #2, Bytes.zero),
function = f,
varInfo = varInfo}
end
@@ -719,8 +722,7 @@
dst = varOperand dst,
overflow = overflow,
prim = prim,
- success = success,
- ty = ty})
+ success = success})
| R.Transfer.CCall {args, func, return} =>
simple (M.Transfer.CCall
{args = translateOperands args,
@@ -734,8 +736,8 @@
datatype z = datatype R.Return.t
val (contLive, frameSize, return) =
case return of
- Dead => (Vector.new0 (), 0, NONE)
- | Tail => (Vector.new0 (), 0, NONE)
+ Dead => (Vector.new0 (), Bytes.zero, NONE)
+ | Tail => (Vector.new0 (), Bytes.zero, NONE)
| NonTail {cont, handler} =>
let
val {liveNoFormals, size, ...} =
@@ -783,7 +785,7 @@
| R.Transfer.Return xs =>
let
val dsts =
- callReturnOperands (xs, R.Operand.ty, 0)
+ callReturnOperands (xs, R.Operand.ty, Bytes.zero)
in
(parallelMove
{chunk = chunk,
@@ -793,49 +795,22 @@
end
| R.Transfer.Switch switch =>
let
- fun doit ({cases: ('a * Label.t) vector,
- default: Label.t option,
- size: 'b,
- test: R.Operand.t},
- make: {cases: ('a * Label.t) vector,
- default: Label.t option,
- size: 'b,
- test: M.Operand.t} -> M.Switch.t) =
- simple
- (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
- (make {cases = cases,
- default = default,
- size = size,
- test = translateOperand test}))
+ val R.Switch.T {cases, default, size, test} =
+ switch
in
- case switch of
- 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})),
+ simple
+ (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
+ (M.Switch.T
+ {cases = cases,
default = default,
- tag = translateOperand tag,
+ size = size,
test = translateOperand test}))
- | R.Switch.Word z => doit (z, M.Switch.Word)
end
end
val genTransfer =
@@ -1015,13 +990,13 @@
val _ = List.foreach (chunks, fn M.Chunk.T {blocks, ...} =>
Vector.foreach (blocks, Label.clear o M.Block.label))
val (frameLabels, frameLayouts, frameOffsets) = allFrameInfo ()
- val maxFrameSize =
+ val maxFrameSize: Bytes.t =
List.fold
- (chunks, 0, fn (M.Chunk.T {blocks, ...}, max) =>
+ (chunks, Bytes.zero, fn (M.Chunk.T {blocks, ...}, max) =>
Vector.fold
(blocks, max, fn (M.Block.T {kind, statements, transfer, ...}, max) =>
let
- fun doOperand (z: M.Operand.t, max) =
+ fun doOperand (z: M.Operand.t, max: Bytes.t): Bytes.t =
let
datatype z = datatype M.Operand.t
in
@@ -1032,14 +1007,14 @@
| Contents {oper, ...} => doOperand (oper, max)
| Offset {base, ...} => doOperand (base, max)
| StackOffset {offset, ty} =>
- Int.max (offset + Type.size ty, max)
+ Bytes.max (Bytes.+ (offset, Type.bytes ty), max)
| _ => max
end
val max =
case M.Kind.frameInfoOpt kind of
NONE => max
| SOME (M.FrameInfo.T {frameLayoutsIndex, ...}) =>
- Int.max
+ Bytes.max
(max,
#size (Vector.sub (frameLayouts, frameLayoutsIndex)))
val max =
@@ -1051,7 +1026,7 @@
in
max
end))
- val maxFrameSize = Runtime.wordAlignInt maxFrameSize
+ val maxFrameSize = Bytes.wordAlign maxFrameSize
val profileInfo = makeProfileInfo {frames = frameLabels}
in
Machine.Program.T
1.11 +2 -8 mlton/mlton/backend/backend.sig
Index: backend.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/backend.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- backend.sig 19 Jul 2003 01:23:26 -0000 1.10
+++ backend.sig 4 Apr 2004 06:50:16 -0000 1.11
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -12,13 +12,7 @@
sig
structure Machine: MACHINE
structure Ssa: SSA
- sharing Machine.CFunction = Ssa.CFunction
- sharing Machine.IntX = Ssa.IntX
- sharing Machine.Label = Ssa.Label
- sharing Machine.Prim = Ssa.Prim
- sharing Machine.RealX = Ssa.RealX
- sharing Machine.SourceInfo = Ssa.SourceInfo
- sharing Machine.WordX = Ssa.WordX
+ sharing Machine.Atoms = Ssa.Atoms
val funcToLabel: Ssa.Func.t -> Machine.Label.t
end
1.18 +1 -12 mlton/mlton/backend/chunkify.fun
Index: chunkify.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/chunkify.fun,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- chunkify.fun 19 Feb 2004 22:42:09 -0000 1.17
+++ chunkify.fun 4 Apr 2004 06:50:16 -0000 1.18
@@ -39,18 +39,7 @@
let
val transferSize =
case transfer of
- Switch s =>
- let
- datatype z = datatype Switch.t
- fun simple {cases, default = _, size = _, test = _} =
- 1 + Vector.length cases
- in
- case s of
- EnumPointers _ => 2
- | Int z => simple z
- | Pointer {cases, ...} => 1 + Vector.length cases
- | Word z => simple z
- end
+ Switch (Switch.T {cases, ...}) => 1 + Vector.length cases
| _ => 1
val statementsSize =
if !Control.profile = Control.ProfileNone
1.47 +55 -46 mlton/mlton/backend/limit-check.fun
Index: limit-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/limit-check.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- limit-check.fun 18 Mar 2004 03:22:23 -0000 1.46
+++ limit-check.fun 4 Apr 2004 06:50:16 -0000 1.47
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -72,10 +72,10 @@
fun caseBytes (s: Statement.t,
{big = _: Operand.t -> 'a,
- small: word -> 'a}): 'a =
+ small: Bytes.t -> 'a}): 'a =
case s of
- Object {size, ...} => small (Word.fromInt size)
- | _ => small 0w0
+ Object {size, ...} => small size
+ | _ => small Bytes.zero
end
structure Transfer =
@@ -83,38 +83,39 @@
open Transfer
fun caseBytes (t: t, {big: Operand.t -> 'a,
- small: word -> 'a}): 'a =
+ small: Bytes.t -> 'a}): 'a =
case t of
CCall {args, func, ...} =>
(case CFunction.bytesNeeded func of
- NONE => small 0w0
+ NONE => small Bytes.zero
| SOME i =>
Operand.caseBytes (Vector.sub (args, i),
{big = big,
small = small}))
- | _ => small 0w0
+ | _ => small Bytes.zero
end
structure Block =
struct
open Block
- fun objectBytesAllocated (T {statements, transfer, ...}): word =
- Vector.fold (statements, 0w0, fn (s, ac) =>
- ac + Statement.caseBytes (s,
- {big = fn _ => 0w0,
- small = fn w => w}))
- + Transfer.caseBytes (transfer,
- {big = fn _ => 0w0,
- small = fn w => w})
+ fun objectBytesAllocated (T {statements, transfer, ...}): Bytes.t =
+ Bytes.+
+ (Vector.fold (statements, Bytes.zero, fn (s, ac) =>
+ Bytes.+
+ (ac,
+ Statement.caseBytes (s, {big = fn _ => Bytes.zero,
+ small = fn b => b}))),
+ Transfer.caseBytes (transfer, {big = fn _ => Bytes.zero,
+ small = fn b => b}))
end
val extraGlobals: Var.t list ref = ref []
fun insertFunction (f: Function.t,
handlesSignals: bool,
- blockCheckAmount: {blockIndex: int} -> word,
- ensureBytesFree: Label.t -> word) =
+ blockCheckAmount: {blockIndex: int} -> Bytes.t,
+ ensureFree: Label.t -> Bytes.t) =
let
val {args, blocks, name, raises, returns, start} = Function.dest f
val newBlocks = ref []
@@ -138,7 +139,7 @@
modifiesFrontier = false,
modifiesStackTop = false,
name = "MLton_allocTooLarge",
- return = NONE}
+ return = Type.unit}
val _ =
newBlocks :=
Block.T {args = Vector.new0 (),
@@ -170,8 +171,8 @@
Operand.EnsuresBytesFree =>
Operand.word
(WordX.fromIntInf
- (Word.toIntInf
- (ensureBytesFree (valOf return)),
+ (Bytes.toIntInf
+ (ensureFree (valOf return)),
WordSize.default))
| _ => z)),
func = func,
@@ -203,7 +204,7 @@
label = dontCollect',
statements = Vector.new0 (),
transfer =
- Transfer.ifInt
+ Transfer.ifBool
(global, {falsee = dontCollect,
truee = collect})})
in
@@ -345,7 +346,8 @@
frontierCheck (isFirst,
Prim.eq,
Operand.Runtime Limit,
- Operand.int (IntX.zero IntSize.default),
+ Operand.word (WordX.zero
+ WordSize.default),
{collect = collect,
dontCollect = newBlock (false,
statements,
@@ -359,8 +361,8 @@
newBlock (false, statements, transfer)})
else newBlock (isFirst, statements, transfer)
end
- fun heapCheckNonZero (bytes: Word.t): Label.t =
- if bytes <= Word.fromInt Runtime.limitSlop
+ fun heapCheckNonZero (bytes: Bytes.t): Label.t =
+ if Bytes.<= (bytes, Runtime.limitSlop)
then frontierCheck (true,
Prim.wordGt WordSize.default,
Operand.Runtime Frontier,
@@ -369,30 +371,31 @@
(WordX.zero WordSize.default)))
else heapCheck (true,
Operand.word (WordX.fromIntInf
- (Word.toIntInf bytes,
+ (Bytes.toIntInf bytes,
WordSize.default)))
fun smallAllocation _ =
let
- val w = blockCheckAmount {blockIndex = i}
+ val b = blockCheckAmount {blockIndex = i}
in
- if w = 0w0
+ if Bytes.isZero b
then maybeStack ()
- else heapCheckNonZero w
+ else heapCheckNonZero b
end
fun bigAllocation (bytesNeeded: Operand.t) =
let
val extraBytes =
- Word.fromInt Runtime.arrayHeaderSize
- + blockCheckAmount {blockIndex = i}
+ Bytes.+ (Runtime.arrayHeaderSize,
+ blockCheckAmount {blockIndex = i})
in
case bytesNeeded of
Operand.Const c =>
(case c of
Const.Word w =>
heapCheckNonZero
- (Word.addCheck
- (Word.fromIntInf (WordX.toIntInf w),
- extraBytes)
+ (Bytes.fromWord
+ (Word.addCheck
+ (Word.fromIntInf (WordX.toIntInf w),
+ Bytes.toWord extraBytes))
handle Overflow => Runtime.allocTooLarge)
| _ => Error.bug "strange primitive bytes needed")
| _ =>
@@ -405,7 +408,8 @@
Transfer.Arith
{args = Vector.new2 (Operand.word
(WordX.fromIntInf
- (Word.toIntInf extraBytes,
+ (Word.toIntInf
+ (Bytes.toWord extraBytes),
WordSize.default)),
bytesNeeded),
dst = bytes,
@@ -442,7 +446,7 @@
fun blockCheckAmount {blockIndex} =
Block.objectBytesAllocated (Vector.sub (blocks, blockIndex))
in
- insertFunction (f, handlesSignals, blockCheckAmount, fn _ => 0w0)
+ insertFunction (f, handlesSignals, blockCheckAmount, fn _ => Bytes.zero)
end
structure Graph = DirectedGraph
@@ -450,7 +454,7 @@
structure Edge = Graph.Edge
structure Forest = Graph.LoopForest
-val traceMaxPath = Trace.trace ("maxPath", Int.layout, Word.layout)
+val traceMaxPath = Trace.trace ("maxPath", Int.layout, Bytes.layout)
fun insertCoalesce (f: Function.t, handlesSignals) =
let
@@ -618,7 +622,9 @@
let
val i = nodeIndex n
in
- if 0w0 < Vector.sub (objectBytesAllocated, i)
+ if (Bytes.<
+ (Bytes.zero,
+ Vector.sub (objectBytesAllocated, i)))
then Array.update (classDoesAllocate,
indexClass i,
true)
@@ -672,7 +678,7 @@
local
val a = Array.array (n, NONE)
in
- fun maxPath arg : word = (* i is a node index *)
+ fun maxPath arg : Bytes.t = (* i is a node index *)
traceMaxPath
(fn (i: int) =>
case Array.sub (a, i) of
@@ -682,15 +688,16 @@
val x = Vector.sub (objectBytesAllocated, i)
val max =
List.fold
- (Node.successors (indexNode i), 0w0, fn (e, max) =>
+ (Node.successors (indexNode i), Bytes.zero,
+ fn (e, max) =>
let
val i' = nodeIndex (Edge.to e)
in
if Array.sub (mayHaveCheck, i')
then max
- else Word.max (max, maxPath i')
+ else Bytes.max (max, maxPath i')
end)
- val x = x + max
+ val x = Bytes.+ (x, max)
val _ = Array.update (a, i, SOME x)
in
x
@@ -700,7 +707,7 @@
fun blockCheckAmount {blockIndex} =
if Array.sub (mayHaveCheck, blockIndex)
then maxPath blockIndex
- else 0w0
+ else Bytes.zero
val f = insertFunction (f, handlesSignals, blockCheckAmount,
maxPath o labelIndex)
val _ =
@@ -710,7 +717,7 @@
(blocks, fn Block.T {label, ...} =>
display (let open Layout
in seq [Label.layout label, str " ",
- Word.layout (maxPath (labelIndex label))]
+ Bytes.layout (maxPath (labelIndex label))]
end)))
val _ = Function.clear f
in
@@ -735,9 +742,11 @@
label = newStart,
statements = (Vector.fromListMap
(!extraGlobals, fn x =>
- Statement.Bind {isMutable = true,
- oper = Operand.bool true,
- var = x})),
+ Statement.Bind
+ {isMutable = true,
+ oper = Operand.Cast (Operand.bool true,
+ Type.bool),
+ var = x})),
transfer = Transfer.Goto {args = Vector.new0 (),
dst = start}}
val blocks = Vector.concat [Vector.new1 block, blocks]
1.59 +152 -166 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -r1.58 -r1.59
--- machine.fun 5 Mar 2004 03:50:52 -0000 1.58
+++ machine.fun 4 Apr 2004 06:50:16 -0000 1.59
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -11,16 +11,7 @@
open S
-structure IntSize = IntX.IntSize
-structure RealSize = RealX.RealSize
-structure WordSize = WordX.WordSize
-structure Runtime = Runtime (structure CType = CType)
-structure Atoms = MachineAtoms (open S
- structure IntSize = IntSize
- structure RealSize = RealSize
- structure Runtime = Runtime
- structure WordSize = WordSize)
-open Atoms
+structure Type = RepType
structure ChunkLabel = Id (val noname = "ChunkLabel")
@@ -135,27 +126,29 @@
structure StackOffset =
struct
- type t = {offset: int,
+ type t = {offset: Bytes.t,
ty: Type.t}
- fun layout {offset, ty} =
+ fun layout ({offset, ty}: t): Layout.t =
let
open Layout
in
seq [str (concat ["S", Type.name ty]),
- paren (Int.layout offset),
+ paren (Bytes.layout offset),
str ": ", Type.layout ty]
end
- fun equals ({offset = i, ty}, {offset = i', ty = ty'}) =
- i = i' andalso Type.equals (ty, ty')
+ val equals: t * t -> bool =
+ fn ({offset = b, ty}, {offset = b', ty = ty'}) =>
+ Bytes.equals (b, b') andalso Type.equals (ty, ty')
- fun interfere ({offset = off, ty = ty}, {offset = off', ty = ty'}): bool =
+ val interfere: t * t -> bool =
+ fn ({offset = b, ty = ty}, {offset = b', ty = ty'}) =>
let
- val max = off + Type.size ty
- val max' = off' + Type.size ty'
+ val max = Bytes.+ (b, Type.bytes ty)
+ val max' = Bytes.+ (b', Type.bytes ty')
in
- max > off' andalso max' > off
+ Bytes.> (max, b') andalso Bytes.> (max', b)
end
end
@@ -176,7 +169,9 @@
| SmallIntInf of SmallIntInf.t
| Label of Label.t
| Line
- | Offset of {base: t, offset: int, ty: Type.t}
+ | Offset of {base: t,
+ offset: Bytes.t,
+ ty: Type.t}
| Register of Register.t
| Real of RealX.t
| StackOffset of StackOffset.t
@@ -199,7 +194,7 @@
| Contents {ty, ...} => ty
| File => Type.cPointer ()
| Frontier => Type.defaultWord
- | GCState => Type.cPointer ()
+ | GCState => Type.gcState
| Global g => Global.ty g
| Int i => Type.int (IntX.size i)
| Label l => Type.label l
@@ -210,7 +205,7 @@
| SmallIntInf _ => Type.intInf
| StackOffset {ty, ...} => ty
| StackTop => Type.defaultWord
- | Word w => Type.word (WordX.size w)
+ | Word w => Type.constant w
fun layout (z: t): Layout.t =
let
@@ -239,14 +234,14 @@
| Line => str "<Line>"
| Offset {base, offset, ty} =>
seq [str (concat ["O", Type.name ty, " "]),
- tuple [layout base, Int.layout offset],
+ tuple [layout base, Bytes.layout offset],
constrain ty]
| Real r => RealX.layout r
| Register r => Register.layout r
| SmallIntInf w => seq [str "SmallIntInf ", paren (Word.layout w)]
| StackOffset so => StackOffset.layout so
| StackTop => str "<StackTop>"
- | Word w => seq [WordX.layout w, str ": ", Type.layout (ty z)]
+ | Word w => seq [str "0x", WordX.layout w]
end
val toString = Layout.toString o layout
@@ -267,7 +262,7 @@
| (Line, Line) => true
| (Offset {base = b, offset = i, ...},
Offset {base = b', offset = i', ...}) =>
- equals (b, b') andalso i = i'
+ equals (b, b') andalso Bytes.equals (i, i')
| (Real r, Real r') => RealX.equals (r, r')
| (Register r, Register r') => Register.equals (r, r')
| (SmallIntInf w, SmallIntInf w') => Word.equals (w, w')
@@ -293,6 +288,7 @@
end
structure Switch = Switch (open Atoms
+ structure Type = Type
structure Use = Operand)
structure Statement =
@@ -303,8 +299,8 @@
| Noop
| Object of {dst: Operand.t,
header: word,
- size: int,
- stores: {offset: int,
+ size: Bytes.t,
+ stores: {offset: Bytes.t,
value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
dst: Operand.t option,
@@ -324,11 +320,12 @@
[Operand.layout dst,
seq [str " = Object ",
record [("header", Word.layout header),
- ("size", Int.layout size)],
+ ("size", Bytes.layout size)],
str " ",
- Vector.layout (fn {offset, value} =>
- record [("offset", Int.layout offset),
- ("value", Operand.layout value)])
+ Vector.layout
+ (fn {offset, value} =>
+ record [("offset", Bytes.layout offset),
+ ("value", Operand.layout value)])
stores]]
| PrimApp {args, dst, prim, ...} =>
let
@@ -402,8 +399,7 @@
dst: Operand.t,
overflow: Label.t,
prim: Prim.t,
- success: Label.t,
- ty: Type.t}
+ success: Label.t}
| CCall of {args: Operand.t vector,
frameInfo: FrameInfo.t option,
func: CFunction.t,
@@ -412,7 +408,7 @@
live: Operand.t vector,
return: {return: Label.t,
handler: Label.t option,
- size: int} option}
+ size: Bytes.t} option}
| Goto of Label.t
| Raise
| Return
@@ -446,7 +442,7 @@
record [("return", Label.layout return),
("handler",
Option.layout Label.layout handler),
- ("size", Int.layout size)])
+ ("size", Bytes.layout size)])
return)]]
| Goto l => seq [str "Goto ", Label.layout l]
| Raise => str "Raise"
@@ -706,13 +702,13 @@
datatype t = T of {chunks: Chunk.t list,
frameLayouts: {frameOffsetsIndex: int,
isC: bool,
- size: int} vector,
- frameOffsets: int vector vector,
+ size: Bytes.t} vector,
+ frameOffsets: Bytes.t vector vector,
handlesSignals: bool,
intInfs: (Global.t * string) list,
main: {chunkLabel: ChunkLabel.t,
label: Label.t},
- maxFrameSize: int,
+ maxFrameSize: Bytes.t,
objectTypes: ObjectType.t vector,
profileInfo: ProfileInfo.t option,
reals: (Global.t * RealX.t) list,
@@ -737,15 +733,15 @@
output (record
[("handlesSignals", Bool.layout handlesSignals),
("main", Label.layout label),
- ("maxFrameSize", Int.layout maxFrameSize),
+ ("maxFrameSize", Bytes.layout maxFrameSize),
("frameOffsets",
- Vector.layout (Vector.layout Int.layout) frameOffsets),
+ Vector.layout (Vector.layout Bytes.layout) frameOffsets),
("frameLayouts",
Vector.layout (fn {frameOffsetsIndex, isC, size} =>
record [("frameOffsetsIndex",
Int.layout frameOffsetsIndex),
("isC", Bool.layout isC),
- ("size", Int.layout size)])
+ ("size", Bytes.layout size)])
frameLayouts)])
; Option.app (profileInfo, fn pi =>
(output (str "\nProfileInfo:")
@@ -858,12 +854,12 @@
("frameLayouts",
fn () => (0 <= frameOffsetsIndex
andalso frameOffsetsIndex < Vector.length frameOffsets
- andalso size <= maxFrameSize
- andalso size <= Runtime.maxFrameSize
- andalso 0 = Int.rem (size, 4)),
+ andalso Bytes.<= (size, maxFrameSize)
+ andalso Bytes.<= (size, Runtime.maxFrameSize)
+ andalso Bytes.isWordAligned size),
fn () => Layout.record [("frameOffsetsIndex",
Int.layout frameOffsetsIndex),
- ("size", Int.layout size)]))
+ ("size", Bytes.layout size)]))
val _ =
Vector.foreach
(objectTypes, fn ty =>
@@ -886,10 +882,10 @@
end)
val _ = globals ("real", reals, Type.isReal, RealX.layout)
val _ = globals ("intInf", intInfs,
- fn t => Type.equals (t, Type.intInf),
+ fn t => Type.isSubtype (t, Type.intInf),
String.layout)
val _ = globals ("string", strings,
- fn t => Type.equals (t, Type.word8Vector),
+ fn t => Type.isSubtype (t, Type.word8Vector),
String.layout)
(* Check for no duplicate labels. *)
local
@@ -931,7 +927,7 @@
; arrayOffsetIsOk z)
| Cast (z, t) =>
(checkOperand (z, alloc)
- ; (castIsOk
+ ; (Type.castIsOk
{from = Operand.ty z,
fromInt = (case z of
Int i => SOME i
@@ -957,16 +953,25 @@
in true
end handle _ => false)
| Line => true
- | Offset (z as {base, ...}) =>
+ | Offset {base, offset, ty} =>
(checkOperand (base, alloc)
- ; offsetIsOk z)
+ ; (case base of
+ Operand.GCState => true
+ | _ =>
+ (case Type.offset (Operand.ty base,
+ {offset = offset,
+ pointerTy = tyconTy,
+ width = Type.width ty}) of
+ NONE => false
+ | SOME t => Type.isSubtype (t, ty))))
| Real _ => true
| Register _ => Alloc.doesDefine (alloc, x)
| SmallIntInf w => 0wx1 = Word.andb (w, 0wx1)
| StackOffset {offset, ty, ...} =>
- offset + Type.size ty <= maxFrameSize
+ Bytes.<= (Bytes.+ (offset, Type.bytes ty),
+ maxFrameSize)
andalso Alloc.doesDefine (alloc, x)
- andalso (case ty of
+ andalso (case Type.dest ty of
Type.Label l =>
let
val Block.T {kind, ...} =
@@ -976,8 +981,10 @@
val {size, ...} =
getFrameInfo fi
in
- size
- = offset + Runtime.labelSize
+ Bytes.equals
+ (size,
+ Bytes.+ (offset,
+ Runtime.labelSize))
end
in
case kind of
@@ -998,65 +1005,20 @@
in
Err.check ("operand", ok, fn () => Operand.layout x)
end
- and arrayOffsetIsOk {base, index, ty} =
- Type.equals (Operand.ty index, Type.defaultInt)
+ and arrayOffsetIsOk {base: Operand.t, index: Operand.t, ty} =
+ Type.isSubtype (Operand.ty index, Type.defaultInt)
andalso
- case Operand.ty base of
- 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')
- orelse
- (* Get a word from a word8 array.*)
- (Type.equals
- (ty, Type.word (WordSize.W 32))
- andalso
- Type.equals
- (ty', Type.word (WordSize.W 8))))
- end
+ case Type.dest (Operand.ty base) of
+ Type.Pointer p =>
+ (case tyconTy p of
+ ObjectType.Array ty' =>
+ Type.isSubtype (ty', ty)
+ orelse
+ (* Get a word from a word8 array.*)
+ (Type.equals (ty, Type.defaultWord)
+ andalso Type.equals (ty', Type.word8))
| _ => false)
- | t => Type.isCPointer t
- and offsetIsOk {base, offset, ty} =
- let
- 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
- ((* Array_toVector header update. *)
- (offset = Runtime.headerOffset
- andalso Type.equals (ty, Type.defaultWord))
- orelse
- (offset = Runtime.arrayLengthOffset
- andalso Type.equals (ty, Type.defaultInt))
- orelse
- Vector.forall
- (pointers, fn p =>
- case tyconTy p of
- ObjectType.Normal m => memChunkIsOk m
- | _ => false))
- | Type.MemChunk m => memChunkIsOk m
- | t => Type.isCPointer t
- end
+ | _ => Type.isCPointer (Operand.ty base)
fun checkOperands (v, a) =
Vector.foreach (v, fn z => checkOperand (z, a))
fun check' (x, name, isOk, layout) =
@@ -1092,12 +1054,13 @@
val liveOffsets =
Vector.fromArray
(QuickSort.sortArray
- (Array.fromList liveOffsets, op <=))
+ (Array.fromList liveOffsets, Bytes.<=))
val liveOffsets' =
Vector.sub (frameOffsets, frameOffsetsIndex)
handle Subscript => raise No
in
- liveOffsets = liveOffsets'
+ Vector.equals (liveOffsets, liveOffsets',
+ Bytes.equals)
end)
end handle No => false
fun slotsAreInFrame (fi: FrameInfo.t): bool =
@@ -1108,7 +1071,7 @@
(alloc, fn z =>
case z of
Operand.StackOffset {offset, ty} =>
- offset + Type.size ty <= size
+ Bytes.<= (Bytes.+ (offset, Type.bytes ty), size)
| _ => false)
end
in
@@ -1121,20 +1084,32 @@
Alloc.define (alloc, z)))
else NONE
| CReturn {dst, frameInfo, func, ...} =>
- if (if CFunction.mayGC func
- then (case frameInfo of
- NONE => false
- | SOME fi => (frame (fi, true, true)
- andalso slotsAreInFrame fi))
- else if !Control.profile = Control.ProfileNone
- then true
- else (case frameInfo of
- NONE => false
- | SOME fi => frame (fi, false, true)))
- then SOME (case dst of
- NONE => alloc
- | SOME z => Alloc.define (alloc, z))
- else NONE
+ let
+ val ok =
+ (case dst of
+ NONE => true
+ | SOME z =>
+ Type.isSubtype (CFunction.return func,
+ Operand.ty z))
+ andalso
+ (if CFunction.mayGC func
+ then (case frameInfo of
+ NONE => false
+ | SOME fi =>
+ (frame (fi, true, true)
+ andalso slotsAreInFrame fi))
+ else if !Control.profile = Control.ProfileNone
+ then true
+ else (case frameInfo of
+ NONE => false
+ | SOME fi => frame (fi, false, true)))
+ in
+ if ok
+ then SOME (case dst of
+ NONE => alloc
+ | SOME z => Alloc.define (alloc, z))
+ else NONE
+ end
| Func => SOME alloc
| Handler {frameInfo, ...} =>
if frame (frameInfo, false, false)
@@ -1154,35 +1129,41 @@
val alloc = Alloc.define (alloc, dst)
val _ = checkOperand (dst, alloc)
in
- if Type.equals (Operand.ty dst, Operand.ty src)
+ if Type.isSubtype (Operand.ty src, Operand.ty dst)
andalso Operand.isLocation dst
then SOME alloc
else NONE
end
| Noop => SOME alloc
- | Object {dst, header, stores, ...} =>
+ | Object {dst, header, size, stores} =>
let
- val _ =
- Vector.foreach
- (stores, fn {value, ...} =>
- checkOperand (value, alloc))
+ val () =
+ Vector.foreach (stores, fn {value, ...} =>
+ checkOperand (value, alloc))
val alloc = Alloc.define (alloc, dst)
- val _ = checkOperand (dst, alloc)
+ val () = checkOperand (dst, alloc)
+ val index = Runtime.headerToTypeIndex header
+ val tycon = PointerTycon.fromIndex index
in
- (case Vector.sub (objectTypes,
- Runtime.headerToTypeIndex
- header) of
- ObjectType.Normal mc =>
- (if MemChunk.isValidInit
- (mc,
- Vector.map
- (stores, fn {offset, value} =>
- {offset = offset,
- ty = Operand.ty value}))
- then SOME alloc
- else NONE)
- | _ => NONE)
- handle Subscript => NONE
+ case (SOME (Vector.sub (objectTypes, index))
+ handle Subscript => NONE) of
+ SOME (ObjectType.Normal t) =>
+ (if Bytes.equals
+ (size, Bytes.+ (Runtime.normalHeaderSize,
+ Type.bytes t))
+ andalso
+ Type.isSubtype (Type.pointer tycon,
+ Operand.ty dst)
+ andalso
+ Type.isValidInit
+ (t,
+ Vector.map
+ (stores, fn {offset, value} =>
+ {offset = offset,
+ ty = Operand.ty value}))
+ then SOME alloc
+ else NONE)
+ | _ => NONE
end
| PrimApp {args, dst, ...} =>
let
@@ -1231,7 +1212,7 @@
| (SOME os, SOME os') =>
Vector.equals (os, os', Operand.equals)
| _ => false)
- fun checkCont (cont: Label.t, size: int, alloc: Alloc.t) =
+ fun checkCont (cont: Label.t, size: Bytes.t, alloc: Alloc.t) =
let
val Block.T {kind, live, ...} = labelBlock cont
in
@@ -1239,7 +1220,8 @@
then
(case kind of
Kind.Cont {args, frameInfo, ...} =>
- (if size = #size (getFrameInfo frameInfo)
+ (if Bytes.equals (size,
+ #size (getFrameInfo frameInfo))
then
SOME
(live,
@@ -1249,7 +1231,7 @@
case z of
Operand.StackOffset {offset, ty} =>
Operand.StackOffset
- {offset = offset - size,
+ {offset = Bytes.- (offset, size),
ty = ty}
| _ => z)))
else NONE)
@@ -1268,7 +1250,7 @@
NONE =>
{raises = raises,
returns = returns,
- size = 0}
+ size = Bytes.zero}
| SOME {handler, return, size} =>
let
val (contLive, returns) =
@@ -1308,10 +1290,10 @@
(live, [], fn (z, ac) =>
case z of
Operand.StackOffset {offset, ty} =>
- if offset < size
+ if Bytes.< (offset, size)
then ac
else (Operand.StackOffset
- {offset = offset - size,
+ {offset = Bytes.- (offset, size),
ty = ty} :: ac)
| _ => ac))
in
@@ -1335,20 +1317,32 @@
datatype z = datatype Transfer.t
in
case t of
- Arith {args, dst, overflow, success, ty, ...} =>
+ Arith {args, dst, overflow, prim, success, ...} =>
let
val _ = checkOperands (args, alloc)
val alloc = Alloc.define (alloc, dst)
val _ = checkOperand (dst, alloc)
in
- Type.equals (ty, Operand.ty dst)
+ Prim.mayOverflow prim
andalso jump (overflow, alloc)
andalso jump (success, alloc)
+ andalso
+ (case (Prim.typeCheck
+ (prim, Vector.map (args, Operand.ty))) of
+ NONE => false
+ | SOME t => Type.isSubtype (t, Operand.ty dst))
+
end
| CCall {args, frameInfo = fi, func, return} =>
let
val _ = checkOperands (args, alloc)
in
+ CFunction.isOk func
+ andalso
+ Vector.equals (args, CFunction.args func,
+ fn (z, t) =>
+ Type.isSubtype (Operand.ty z, t))
+ andalso
case return of
NONE => true
| SOME l =>
@@ -1363,14 +1357,6 @@
CFunction.equals (func, f)
andalso (Option.equals
(fi, fi', FrameInfo.equals))
- andalso
- (case (dst, CFunction.return f) of
- (NONE, _) => true
- | (SOME x, SOME ty) =>
- CType.equals
- (ty,
- Type.toCType (Operand.ty x))
- | _ => false)
| _ => false
end
end
1.42 +19 -31 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- machine.sig 5 Feb 2004 06:11:41 -0000 1.41
+++ machine.sig 4 Apr 2004 06:50:16 -0000 1.42
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -10,31 +10,20 @@
signature MACHINE_STRUCTS =
sig
- structure CFunction: C_FUNCTION
- structure CType: C_TYPE
- structure IntX: INT_X
- structure Label: ID
- structure Prim: PRIM
- structure SourceInfo: SOURCE_INFO
- structure RealX: REAL_X
- structure WordX: WORD_X
- sharing CFunction = Prim.CFunction
- sharing CFunction.CType = CType = Prim.CType = Prim.CFunction.CType
- sharing CType.IntSize = IntX.IntSize = Prim.IntSize
- sharing CType.RealSize = RealX.RealSize = Prim.RealSize
- sharing CType.WordSize = WordX.WordSize = Prim.WordSize
+ include ATOMS
end
signature MACHINE =
sig
- include MACHINE_ATOMS
+ include MACHINE_STRUCTS
+
+ structure Type: REP_TYPE
+ sharing Type = RepType
structure Switch: SWITCH
- sharing IntX = Switch.IntX
- sharing Label = Switch.Label
- sharing PointerTycon = Switch.PointerTycon
+ sharing Atoms = Switch
sharing Type = Switch.Type
- sharing WordX = Switch.WordX
+
structure ChunkLabel: ID
structure Register:
@@ -83,12 +72,12 @@
| Label of Label.t
| Line (* expand by codegen into int constant *)
| Offset of {base: t,
- offset: int,
+ offset: Bytes.t,
ty: Type.t}
| Real of RealX.t
| Register of Register.t
| SmallIntInf of word
- | StackOffset of {offset: int,
+ | StackOffset of {offset: Bytes.t,
ty: Type.t}
| StackTop
| Word of WordX.t
@@ -114,8 +103,8 @@
(* Fixed-size allocation. *)
| Object of {dst: Operand.t,
header: word,
- size: int,
- stores: {offset: int,
+ size: Bytes.t,
+ stores: {offset: Bytes.t,
value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
dst: Operand.t option,
@@ -148,8 +137,7 @@
dst: Operand.t,
overflow: Label.t,
prim: Prim.t,
- success: Label.t,
- ty: Type.t} (* int or word *)
+ success: Label.t}
| CCall of {args: Operand.t vector,
frameInfo: FrameInfo.t option,
func: CFunction.t,
@@ -162,7 +150,7 @@
live: Operand.t vector,
return: {return: Label.t,
handler: Label.t option,
- size: int} option}
+ size: Bytes.t} option}
| Goto of Label.t (* label must be a Jump *)
| Raise
| Return
@@ -245,23 +233,23 @@
T of {chunks: Chunk.t list,
frameLayouts: {frameOffsetsIndex: int,
isC: bool,
- size: int} vector,
+ size: Bytes.t} vector,
(* Each vector in frame Offsets specifies the offsets
* of live pointers in a stack frame. A vector is referred
* to by index as the offsetsIndex in frameLayouts.
*)
- frameOffsets: int vector vector,
+ frameOffsets: Bytes.t vector vector,
handlesSignals: bool,
intInfs: (Global.t * string) list,
main: {chunkLabel: ChunkLabel.t,
label: Label.t},
- maxFrameSize: int,
- objectTypes: ObjectType.t vector,
+ maxFrameSize: Bytes.t,
+ objectTypes: Type.ObjectType.t vector,
profileInfo: ProfileInfo.t option,
reals: (Global.t * RealX.t) list,
strings: (Global.t * string) list}
- val frameSize: t * FrameInfo.t -> int
+ val frameSize: t * FrameInfo.t -> Bytes.t
val clearLabelNames: t -> unit
val layouts: t * (Layout.t -> unit) -> unit
val typeCheck: t -> unit
1.33 +13 -7 mlton/mlton/backend/profile.fun
Index: profile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/profile.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- profile.fun 16 Mar 2004 06:38:27 -0000 1.32
+++ profile.fun 4 Apr 2004 06:50:17 -0000 1.33
@@ -493,11 +493,15 @@
| Handler => add pushes
| Jump => ()
end
- fun maybeSplit {args, bytesAllocated, kind, label,
+ fun maybeSplit {args,
+ bytesAllocated: Bytes.t,
+ kind,
+ label,
leaves,
pushes: Push.t list,
statements} =
- if profileAlloc andalso bytesAllocated > 0
+ if profileAlloc
+ andalso Bytes.> (bytesAllocated, Bytes.zero)
then
let
val newLabel = Label.newNoname ()
@@ -510,7 +514,8 @@
(Operand.GCState,
Operand.word
(WordX.fromIntInf
- (IntInf.fromInt bytesAllocated,
+ (IntInf.fromInt
+ (Bytes.toInt bytesAllocated),
WordSize.default)))),
func = func,
return = SOME newLabel}
@@ -525,14 +530,14 @@
transfer = transfer}
in
{args = Vector.new0 (),
- bytesAllocated = 0,
+ bytesAllocated = Bytes.zero,
kind = Kind.CReturn {func = func},
label = newLabel,
leaves = [],
statements = []}
end
else {args = args,
- bytesAllocated = 0,
+ bytesAllocated = Bytes.zero,
kind = kind,
label = label,
leaves = leaves,
@@ -542,7 +547,7 @@
Vector.fold
(statements,
{args = args,
- bytesAllocated = 0,
+ bytesAllocated = Bytes.zero,
kind = kind,
label = label,
leaves = [],
@@ -568,7 +573,8 @@
case s of
Object {size, ...} =>
{args = args,
- bytesAllocated = bytesAllocated + size,
+ bytesAllocated = Bytes.+ (bytesAllocated,
+ size),
kind = kind,
label = label,
leaves = leaves,
1.26 +506 -403 mlton/mlton/backend/representation.fun
Index: representation.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.fun,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- representation.fun 19 Mar 2004 04:40:07 -0000 1.25
+++ representation.fun 4 Apr 2004 06:50:17 -0000 1.26
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -43,14 +43,64 @@
structure Tycon = Tycon
end
+val bitsPerByte: int = 8
+
datatype z = datatype WordSize.prim
+structure Type =
+ struct
+ open Type
+
+ fun enumPointers {enum, pointers}: t =
+ sum (Vector.concat [Vector.map (enum, constant),
+ Vector.map (pointers, pointer)])
+
+ fun layoutEP {enum, pointers} =
+ Layout.record
+ [("enum", Vector.layout WordX.layout enum),
+ ("pointers", Vector.layout PointerTycon.layout pointers)]
+
+ val enumPointers =
+ Trace.trace ("enumPointers", layoutEP, layout) enumPointers
+
+ fun getEnumPointersOpt (t: t)
+ : {enum: WordX.t vector,
+ pointers: PointerTycon.t vector} option =
+ case dest t of
+ Constant w =>
+ SOME {enum = Vector.new1 w, pointers = Vector.new0 ()}
+ | Pointer p =>
+ SOME {enum = Vector.new0 (), pointers = Vector.new1 p}
+ | Sum ts =>
+ let
+ val (ws, ps) =
+ Vector.fold
+ (ts, ([], []), fn (t, (ws, ps)) =>
+ case dest t of
+ Constant w => (w :: ws, ps)
+ | Pointer p => (ws, p :: ps)
+ | _ => Error.bug "getEnumPointers")
+ in
+ SOME {enum = Vector.fromListRev ws,
+ pointers = Vector.fromListRev ps}
+ end
+ | _ => NONE
+
+ fun getEnumPointers t =
+ case getEnumPointersOpt t of
+ NONE => Error.bug "getEnumPointers of non Sum"
+ | SOME z => z
+
+ val getEnumPointers =
+ Trace.trace ("getEnumPointers", layout, layoutEP) getEnumPointers
+ end
+
structure TupleRep =
struct
- datatype t = T of {offsets: {offset: int,
- ty: R.Type.t} option vector,
- size: int,
- ty: R.Type.t,
+ datatype t = T of {offsets: {offset: Bytes.t,
+ ty: Type.t} option vector,
+ size: Bytes.t,
+ ty: Type.t,
tycon: R.PointerTycon.t}
fun layout (T {offsets, size, ty, tycon, ...}) =
@@ -59,11 +109,11 @@
in record [("offsets",
Vector.layout (Option.layout
(fn {offset, ty} =>
- record [("offset", Int.layout offset),
- ("ty", R.Type.layout ty)]))
+ record [("offset", Bytes.layout offset),
+ ("ty", Type.layout ty)]))
offsets),
- ("size", Int.layout size),
- ("ty", R.Type.layout ty),
+ ("size", Bytes.layout size),
+ ("ty", Type.layout ty),
("tycon", R.PointerTycon.layout tycon)]
end
@@ -73,98 +123,51 @@
val tycon = make #tycon
end
- fun select (T {offsets, ...}, {dst, offset, tuple}) =
- case Vector.sub (offsets, offset) of
- NONE => []
- | SOME {offset, ty} =>
- [R.Statement.Bind
- {isMutable = false,
- oper = R.Operand.Offset {base = tuple (),
- offset = offset,
- ty = ty},
- var = dst ()}]
-
- fun tuple (T {size, offsets, ty, tycon, ...}, {components, dst, oper}) =
+ fun tuple (T {offsets, size, ty, tycon, ...}, {components, dst, oper}) =
let
val stores =
QuickSort.sortVector
(Vector.keepAllMap2
(components, offsets, fn (x, offset) =>
- Option.map (offset, fn {offset, ty = _} =>
+ Option.map (offset, fn {offset, ...} =>
{offset = offset,
value = oper x})),
- fn ({offset = i, ...}, {offset = i', ...}) => i <= i')
+ fn ({offset, ...}, {offset = offset', ...}) =>
+ Bytes.<= (offset, offset'))
in
- [R.Statement.Object {dst = dst,
- size = size + Runtime.normalHeaderSize,
- stores = stores,
- ty = ty,
- tycon = tycon}]
+ [R.Statement.Object {dst = (dst, ty),
+ header = (Runtime.typeIndexToHeader
+ (PointerTycon.index tycon)),
+ size = size,
+ stores = stores}]
end
-
- fun conSelects (T {offsets, ...}, variant: Operand.t): Operand.t vector =
- Vector.keepAllMap
- (offsets, fn off =>
- Option.map (off, fn {offset, ty} =>
- Operand.Offset {base = variant,
- offset = offset,
- ty = ty}))
end
structure ConRep =
struct
datatype t =
- (* 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}
+ (* box the arg(s) *)
+ TagTuple of TupleRep.t
(* just keep the value itself *)
| Transparent of Rssa.Type.t
(* box the arg(s) *)
| Tuple of TupleRep.t
(* need no representation *)
| Void
+ (* an integer representing a variant in a datatype *)
+ | WordAsTy of {ty: Rssa.Type.t,
+ word: WordX.t}
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]
+ fn TagTuple rep => seq [str "TagTuple ", TupleRep.layout rep]
+ | Transparent t => seq [str "Transparent ", Type.layout t]
| Tuple r => seq [str "Tuple ", TupleRep.layout r]
| Void => str "Void"
- end
-
- fun con (cr: t, {args, dst, oper, ty}) =
- let
- fun move (oper: Operand.t) =
- [Statement.Bind {isMutable = false,
- oper = oper,
- var = dst ()}]
- fun allocate (ys, tr) =
- TupleRep.tuple (tr, {components = ys,
- dst = dst (),
- oper = oper})
- in
- case cr of
- Void => []
- | IntAsTy {int, ty} =>
- move (Operand.Cast
- (Operand.int
- (IntX.make (IntInf.fromInt int,
- IntSize.default)),
- ty))
- | TagTuple {rep, ...} => allocate (args, rep)
- | Transparent _ =>
- move (Operand.cast (oper (Vector.sub (args, 0)), ty ()))
- | Tuple rep => allocate (args, rep)
+ | WordAsTy {ty, word} =>
+ seq [str "0x", WordX.layout word, str ": ", Type.layout ty]
end
end
@@ -214,252 +217,9 @@
end
val equals:t * t -> bool = op =
-
- fun genCase (testRep: t,
- {cases: (ConRep.t * Label.t) vector,
- default: Label.t option,
- test: unit -> Operand.t}) =
- let
- datatype z = datatype Operand.t
- datatype z = datatype Transfer.t
- val extraBlocks = ref []
- fun newBlock {args, kind,
- statements: Statement.t vector,
- transfer: Transfer.t}: Label.t =
- let
- val l = Label.newNoname ()
- val _ = List.push (extraBlocks,
- Block.T {args = args,
- kind = kind,
- label = l,
- statements = statements,
- transfer = transfer})
- in
- l
- end
- fun enum (test: Operand.t): Transfer.t =
- let
- val cases =
- Vector.keepAllMap
- (cases, fn (c, j) =>
- case 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')
- val cases =
- Vector.map (cases, fn (i, l) =>
- (IntX.make (IntInf.fromInt i,
- IntSize.default),
- l))
- in
- Switch
- (Switch.Int {cases = cases,
- default = default,
- size = IntSize.default,
- test = test})
- end
- end
- end
- fun switchEP
- (makePointersTransfer: Operand.t -> Statement.t list * Transfer.t)
- : Transfer.t =
- let
- val test = test ()
- 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 = Var {var = enumVar,
- ty = enumTy}
- val pointersTy = Type.EnumPointers {enum = Vector.new0 (),
- pointers = p}
- val pointersVar = Var.newNoname ()
- val pointersOp = Var {ty = pointersTy,
- var = pointersVar}
- fun block (var, ty, statements, transfer) =
- newBlock {args = Vector.new0 (),
- kind = Kind.Jump,
- statements = (Vector.fromList
- (Statement.Bind
- {isMutable = false,
- oper = Cast (test, ty),
- var = var}
- :: statements)),
- transfer = transfer}
- val (s, t) = makePointersTransfer pointersOp
- val pointers = block (pointersVar, pointersTy, s, t)
- val enum = block (enumVar, enumTy, [], enum enumOp)
- in
- Switch (Switch.EnumPointers {enum = enum,
- pointers = pointers,
- test = test})
- end
- fun enumAndOne (): Transfer.t =
- let
- fun make (pointersOp: Operand.t)
- : Statement.t list * Transfer.t =
- let
- val (dst, args: Operand.t vector) =
- case Vector.peekMap
- (cases, fn (c, j) =>
- case c of
- ConRep.Transparent _ =>
- SOME (j, Vector.new1 pointersOp)
- | ConRep.Tuple r =>
- SOME (j,
- TupleRep.conSelects (r, pointersOp))
- | _ => NONE) of
- NONE =>
- (case default of
- NONE => Error.bug "enumAndOne: no default"
- | SOME j => (j, Vector.new0 ()))
- | SOME z => z
- in
- ([], Goto {args = args, dst = dst})
- end
- in
- switchEP make
- end
- fun indirectTag (test: Operand.t): Statement.t list * Transfer.t =
- let
- val cases =
- Vector.keepAllMap
- (cases, fn (c, l) =>
- case c of
- ConRep.TagTuple {rep, tag} =>
- let
- val tycon = TupleRep.tycon rep
- val tag = PointerTycon.index tycon
- 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 = Cast (test, pointerTy),
- var = pointerVar})
- val dst =
- newBlock
- {args = Vector.new0 (),
- kind = Kind.Jump,
- statements = statements,
- transfer =
- Goto
- {args = TupleRep.conSelects (rep, 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'))
- val headerOffset = ~4
- val tagVar = Var.newNoname ()
- val s =
- Statement.PrimApp
- {args = (Vector.new2
- (Offset {base = test,
- offset = headerOffset,
- ty = Type.defaultWord},
- Operand.word (WordX.one WordSize.default))),
- dst = SOME (tagVar, Type.defaultWord),
- prim = Prim.wordRshift WordSize.default}
- val tag =
- Cast (Var {ty = Type.defaultWord,
- var = tagVar},
- Type.defaultInt)
- in
- ([s], Switch (Switch.Pointer {cases = cases,
- default = default,
- tag = tag,
- test = test}))
- end
- fun prim () =
- case (Vector.length cases, default) of
- (1, _) =>
- (* We use _ instead of NONE for the default becuase
- * there may be an unreachable default case.
- *)
- let
- val (c, l) = Vector.sub (cases, 0)
- in
- case c of
- ConRep.Void =>
- Goto {dst = l,
- args = Vector.new0 ()}
- | ConRep.Transparent _ =>
- Goto {dst = l,
- args = Vector.new1 (test ())}
- | ConRep.Tuple r =>
- Goto {dst = l,
- args = TupleRep.conSelects (r, 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"
- val (ss, t) =
- case testRep of
- Direct => ([], prim ())
- | Enum => ([], enum (test ()))
- | EnumDirect => ([], enumAndOne ())
- | EnumIndirect => ([], enumAndOne ())
- | EnumIndirectTag => ([], switchEP indirectTag)
- | IndirectTag => indirectTag (test ())
- | Void => ([], prim ())
- in
- (ss, t, !extraBlocks)
- end
end
+
fun compute (program as Ssa.Program.T {datatypes, ...}) =
let
val {get = tyconRep, set = setTyconRep, ...} =
@@ -516,7 +276,7 @@
let
val a = Vector.sub (args, 0)
(* Which types are guaranteed to be
- * translated to R.Type.Pointer and are
+ * translated to Type.Pointer and are
* represented as zero mod 4.
*)
datatype z = datatype S.Type.dest
@@ -559,13 +319,13 @@
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
+ * recursion when converting from S.Type.t to 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, ...} =
+ val {get = toRtype: S.Type.t -> Type.t option, ...} =
Property.get
(S.Type.plist,
Property.initRec
@@ -575,10 +335,13 @@
isTagged: bool,
mutable: bool,
pointerTycon: R.PointerTycon.t,
- ty: R.Type.t,
+ ty: Type.t,
tys: S.Type.t vector}: TupleRep.t =
let
- val initialOffset = if isTagged then Runtime.wordSize else 0
+ val initialOffset =
+ if isTagged
+ then Bytes.inWord
+ else Bytes.zero
val tys = Vector.map (tys, toRtype)
val bytes = ref []
val doubleWords = ref []
@@ -593,17 +356,10 @@
| 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
+ if Type.isPointer t
then pointers
- else (case R.Type.size t of
+ else (case (Bytes.toInt
+ (Bits.toBytes (Type.width t))) of
1 => bytes
| 2 => halfWords
| 4 => words
@@ -616,32 +372,39 @@
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 (halfWords, 2,
- build (words, 4,
- build (doubleWords, 8,
+ Bytes.+ (offset, size)))
+ val (accum, offset: Bytes.t) =
+ build (bytes, Bytes.fromInt 1,
+ build (halfWords, Bytes.fromInt 2,
+ build (words, Bytes.fromInt 4,
+ build (doubleWords, Bytes.fromInt 8,
([], initialOffset)))))
val offset =
if isNormal
then
let
- val offset = CType.align (CType.pointer, offset)
+ val offset =
+ Bytes.align (offset,
+ {alignment = Bytes.inPointer})
in
if !Control.align = Control.Align8
andalso
- 0 < Int.rem (Runtime.normalHeaderSize
- + offset
- + (Runtime.pointerSize
- * List.length (!pointers)),
+ 0 < Int.rem (Bytes.toInt
+ ((Bytes.+
+ (Runtime.normalHeaderSize,
+ Bytes.+
+ (offset,
+ Bytes.scale
+ (Runtime.pointerSize,
+ List.length (!pointers)))))),
8)
- then offset + 4
+ then Bytes.+ (offset, Bytes.fromInt 4)
else offset
end
else offset
- val (components, size) = build (pointers, 4, (accum, offset))
- val size = if 0 = size then 4 else size
+ val (components, size) =
+ build (pointers, Runtime.pointerSize, (accum, offset))
+ val size = if Bytes.isZero size then Bytes.inWord else size
val offsets =
Vector.mapi
(tys, fn (i, ty) =>
@@ -662,34 +425,55 @@
val components =
if isTagged
then {mutable = false,
- offset = 0,
- ty = R.Type.int IntSize.default} :: components
+ offset = Bytes.zero,
+ ty = Type.int IntSize.default} :: components
else components
val components =
- Vector.fromArray
- (QuickSort.sortArray
- (Array.fromList components,
- fn ({offset = i, ...}, {offset = i', ...}) =>
- i <= i'))
- val mc = R.MemChunk.T {components = components,
- size = size}
+ QuickSort.sortArray
+ (Array.fromList components,
+ fn ({offset = i, ...}, {offset = i', ...}) =>
+ Bytes.<= (i, i'))
+ val (_, cs) =
+ Array.fold
+ (components, (Bytes.zero, []),
+ fn ({mutable, offset, ty}, (i, ac)) =>
+ let
+ val ac =
+ if Bytes.equals (i, offset)
+ then ac
+ else
+ Type.junk (Bytes.toBits (Bytes.- (offset, i)))
+ :: ac
+ in
+ (Bytes.+ (offset,
+ Bits.toBytes (Type.width ty)),
+ ty :: ac)
+ end)
+ val t = Type.seq (Vector.fromListRev cs)
+ val tSize = Type.bytes t
+ val t =
+ if Bytes.equals (tSize, size)
+ then t
+ else Type.seq (Vector.new2
+ (t, Type.junk (Bytes.toBits
+ (Bytes.- (size, tSize)))))
val _ =
List.push
(objectTypes,
(pointerTycon,
if isNormal
- then R.ObjectType.Normal mc
- else R.ObjectType.Array mc))
+ then R.ObjectType.Normal t
+ else R.ObjectType.Array t))
in
TupleRep.T {offsets = offsets,
- size = size,
+ size = Bytes.+ (size, Runtime.normalHeaderSize),
ty = ty,
tycon = pointerTycon}
end
- fun pointer {fin, isNormal, mutable, tys}: R.Type.t =
+ fun pointer {fin, isNormal, mutable, tys}: Type.t =
let
val pt = R.PointerTycon.new ()
- val ty = R.Type.pointer pt
+ val ty = Type.pointer pt
val _ =
List.push
(finish, fn () =>
@@ -702,7 +486,7 @@
in
ty
end
- fun convertDatatype (tycon: Tycon.t): R.Type.t option =
+ fun convertDatatype (tycon: Tycon.t): Type.t option =
let
val (noArgs', haveArgs') = splitCons (tyconCons tycon)
val noArgs = Vector.fromList noArgs'
@@ -724,7 +508,7 @@
ty = ty,
tys = args}
in
- setConRep (con, conRep {rep = rep, tag = i})
+ setConRep (con, conRep rep)
end))
fun transparent {con, args} =
let
@@ -736,23 +520,25 @@
in
ty
end
- fun enumAnd (pointers: R.PointerTycon.t vector): R.Type.t =
+ fun enumAnd (pointers: R.PointerTycon.t vector): Type.t =
let
val enum =
Vector.tabulate
- (Vector.length noArgs, fn i => 2 * i + 1)
+ (Vector.length noArgs, fn i =>
+ WordX.fromIntInf (IntInf.fromInt (2 * i + 1),
+ WordSize.default))
val ty =
- R.Type.EnumPointers {enum = enum,
- pointers = pointers}
+ Type.enumPointers {enum = enum,
+ pointers = pointers}
val _ =
Vector.foreach2
- (noArgs, enum, fn (c, i) =>
- setConRep (c, (ConRep.IntAsTy
- {int = i, ty = ty})))
+ (noArgs, enum, fn (c, w) =>
+ setConRep (c, (ConRep.WordAsTy
+ {ty = ty, word = w})))
in
ty
end
- fun indirectTag (): R.Type.t =
+ fun indirectTag (): Type.t =
let
val pts = pointers ()
val ty = enumAnd pts
@@ -790,18 +576,24 @@
let
val enum =
Vector.tabulate
- (Vector.length noArgs, fn i => i)
+ (Vector.length noArgs, fn i =>
+ WordX.fromIntInf (IntInf.fromInt i,
+ WordSize.default))
val ty =
- R.Type.EnumPointers {enum = enum,
- pointers = Vector.new0 ()}
- fun set (i, c) =
- setConRep (c, (ConRep.IntAsTy
- {int = i, ty = ty}))
+ Type.enumPointers {enum = enum,
+ pointers = Vector.new0 ()}
+ fun set (w, c) =
+ setConRep (c, (ConRep.WordAsTy
+ {ty = ty, word = w}))
+ fun seti (i, c) =
+ set (WordX.fromIntInf (IntInf.fromInt i,
+ WordSize.default),
+ c)
val _ =
if Tycon.equals (tycon, Tycon.bool)
- then (set (0, Con.falsee)
- ; set (1, Con.truee))
- else Vector.foreachi (noArgs, set)
+ then (seti (0, Con.falsee)
+ ; seti (1, Con.truee))
+ else Vector.foreachi (noArgs, seti)
in
SOME ty
end
@@ -810,11 +602,10 @@
[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"
+ SOME
+ (enumAnd
+ (#pointers
+ (Type.getEnumPointers (transparent ca))))
else
let
val pt = R.PointerTycon.new ()
@@ -841,7 +632,7 @@
let
val pts = pointers ()
val ty = enumAnd pts
- val _ = indirect {conRep = ConRep.Tuple o #rep,
+ val _ = indirect {conRep = ConRep.Tuple,
isTagged = false,
pointerTycons = pts,
ty = ty}
@@ -861,7 +652,7 @@
NONE
end
end
- fun array {mutable: bool, ty: S.Type.t}: R.Type.t =
+ fun array {mutable: bool, ty: S.Type.t}: Type.t =
let
fun new () =
pointer {fin = fn _ => (),
@@ -876,8 +667,8 @@
case S.Type.dest ty of
Word s =>
(case WordSize.prim s of
- W8 => R.Type.word8Vector
- | W32 => R.Type.wordVector
+ W8 => Type.word8Vector
+ | W32 => Type.wordVector
| _ => new ())
| _ => new ()
end
@@ -886,16 +677,15 @@
case S.Type.dest t of
Array t => SOME (array {mutable = true, ty = t})
| Datatype tycon => convertDatatype tycon
- | Int s => SOME (R.Type.int (IntSize.roundUpToPrim s))
- | IntInf => SOME R.Type.intInf
- | PreThread => SOME R.Type.thread
- | Real s => SOME (R.Type.real s)
+ | Int s => SOME (Type.int (IntSize.roundUpToPrim s))
+ | IntInf => SOME Type.intInf
+ | Real s => SOME (Type.real s)
| Ref t =>
SOME (pointer {fin = fn r => setRefRep (t, r),
isNormal = true,
mutable = true,
tys = Vector.new1 t})
- | Thread => SOME R.Type.thread
+ | Thread => SOME Type.thread
| Tuple ts =>
if Vector.isEmpty ts
then NONE
@@ -909,23 +699,24 @@
(case toRtype t of
NONE => NONE
| SOME t =>
- if R.Type.isPointer t
+ if Type.isPointer t
then
let
val pt = PointerTycon.new ()
val _ =
List.push
(objectTypes,
- (pt, R.ObjectType.weak t))
+ (pt, R.ObjectType.Weak t))
in
- SOME (R.Type.pointer pt)
+ SOME (Type.pointer pt)
end
else NONE)
- | Word s => SOME (R.Type.word (WordSize.roundUpToPrim s))
+ | Word s =>
+ SOME (Type.word (WordSize.bits (WordSize.roundUpToPrim s)))
end))
val toRtype =
Trace.trace
- ("toRtype", S.Type.layout, Option.layout R.Type.layout)
+ ("toRtype", S.Type.layout, Option.layout Type.layout)
toRtype
val _ = S.Program.foreachVar (program, fn (_, t) => ignore (toRtype t))
val n = List.length (!finish)
@@ -962,13 +753,325 @@
cons,
2))
end))))
+ fun conApp {args, con, dst, oper, ty} =
+ let
+ fun move (oper: Operand.t) =
+ [Statement.Bind {isMutable = false,
+ oper = oper,
+ var = dst ()}]
+ fun allocate (ys, tr) =
+ TupleRep.tuple (tr, {components = ys,
+ dst = dst (),
+ oper = oper})
+ datatype z = datatype ConRep.t
+ in
+ case conRep con of
+ Void => []
+ | TagTuple rep => allocate (args, rep)
+ | Transparent _ =>
+ move (Operand.cast (oper (Vector.sub (args, 0)), ty ()))
+ | Tuple rep => allocate (args, rep)
+ | WordAsTy {ty, word} => move (Operand.word word)
+ end
+ fun conSelects (TupleRep.T {offsets, ...}, variant: Operand.t)
+ : Operand.t vector =
+ Vector.keepAllMap
+ (offsets, fn off =>
+ Option.map (off, fn {offset, ty} =>
+ Operand.Offset {base = variant,
+ offset = offset,
+ ty = ty}))
+ fun genCase {cases: (Con.t * Label.t) vector,
+ default: Label.t option,
+ test: unit -> Operand.t,
+ tycon: Tycon.t} =
+ let
+ datatype z = datatype Operand.t
+ datatype z = datatype Transfer.t
+ val extraBlocks = ref []
+ fun newBlock {args, kind,
+ statements: Statement.t vector,
+ transfer: Transfer.t}: Label.t =
+ let
+ val l = Label.newNoname ()
+ val _ = List.push (extraBlocks,
+ Block.T {args = args,
+ kind = kind,
+ label = l,
+ statements = statements,
+ transfer = transfer})
+ in
+ l
+ end
+ fun enum (test: Operand.t): Transfer.t =
+ let
+ val cases =
+ Vector.keepAllMap
+ (cases, fn (c, j) =>
+ case conRep c of
+ ConRep.WordAsTy {word, ...} => SOME (word, j)
+ | _ => NONE)
+ val numEnum =
+ case Type.dest (Operand.ty test) of
+ Type.Constant _ => 1
+ | Type.Sum ts => Vector.length ts
+ | _ => Error.bug "strange 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 ((w, _), (w', _)) =>
+ WordX.<= (w, w'))
+ in
+ Switch (Switch.T {cases = cases,
+ default = default,
+ size = WordSize.default,
+ test = test})
+ end
+ end
+ end
+ fun switchEP
+ (makePointersTransfer: Operand.t -> Statement.t list * Transfer.t)
+ : Statement.t list * Transfer.t =
+ let
+ val test = test ()
+ val {enum = e, pointers = p} =
+ Type.getEnumPointers (Operand.ty test)
+ val enumTy = Type.enumPointers {enum = e,
+ pointers = Vector.new0 ()}
+ val enumVar = Var.newNoname ()
+ val enumOp = Var {var = enumVar,
+ ty = enumTy}
+ val pointersTy = Type.enumPointers {enum = Vector.new0 (),
+ pointers = p}
+ val pointersVar = Var.newNoname ()
+ val pointersOp = Var {ty = pointersTy,
+ var = pointersVar}
+ fun block (var, ty, statements, transfer) =
+ newBlock {args = Vector.new0 (),
+ kind = Kind.Jump,
+ statements = (Vector.fromList
+ (Statement.Bind
+ {isMutable = false,
+ oper = Cast (test, ty),
+ var = var}
+ :: statements)),
+ transfer = transfer}
+ val (s, t) = makePointersTransfer pointersOp
+ val pointers = block (pointersVar, pointersTy, s, t)
+ val enum = block (enumVar, enumTy, [], enum enumOp)
+ val tmp = Var.newNoname ()
+ val ss =
+ [Statement.PrimApp
+ {args = (Vector.new2
+ (Operand.word
+ (WordX.fromIntInf (3, WordSize.default)),
+ Operand.cast (test, Type.defaultWord))),
+ dst = SOME (tmp, Type.defaultWord),
+ prim = Prim.wordAndb WordSize.default}]
+ val t =
+ Transfer.Switch
+ (Switch.T
+ {cases = Vector.new1 (WordX.zero WordSize.default,
+ pointers),
+ default = SOME enum,
+ size = WordSize.default,
+ test = Operand.Var {ty = Type.defaultWord,
+ var = tmp}})
+ in
+ (ss, t)
+ end
+ fun enumAndOne (): Statement.t list * Transfer.t =
+ let
+ fun make (pointersOp: Operand.t)
+ : Statement.t list * 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 (r, pointersOp))
+ | _ => NONE) of
+ NONE =>
+ (case default of
+ NONE => Error.bug "enumAndOne: no default"
+ | SOME j => (j, Vector.new0 ()))
+ | SOME z => z
+ in
+ ([], Goto {args = args, dst = dst})
+ end
+ in
+ switchEP make
+ end
+ fun indirectTag (test: Operand.t): Statement.t list * Transfer.t =
+ let
+ val cases =
+ Vector.keepAllMap
+ (cases, fn (c, l) =>
+ case conRep c of
+ ConRep.TagTuple rep =>
+ let
+ val tycon = TupleRep.tycon rep
+ val tag = PointerTycon.index tycon
+ 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 = Cast (test, pointerTy),
+ var = pointerVar})
+ val dst =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.Jump,
+ statements = statements,
+ transfer =
+ Goto {args = conSelects (rep, pointerOp),
+ dst = l}}
+ in
+ SOME (WordX.fromIntInf (Int.toIntInf tag,
+ WordSize.default),
+ dst)
+ end
+ | _ => NONE)
+ val pointers =
+ #pointers (Type.getEnumPointers (Operand.ty test))
+ val numTag = Vector.length pointers
+ val default =
+ if numTag = Vector.length cases
+ then NONE
+ else default
+ val cases =
+ QuickSort.sortVector
+ (cases, fn ((w, _), (w', _)) => WordX.<= (w, w'))
+ val headerOffset = Bytes.fromInt ~4
+ val tagVar = Var.newNoname ()
+ val tagTy =
+ Type.sum (Vector.map
+ (pointers, fn p =>
+ Type.constant
+ (WordX.fromIntInf
+ (Int.toIntInf (PointerTycon.index p),
+ WordSize.default))))
+
+ val s =
+ Statement.PrimApp
+ {args = (Vector.new2
+ (Offset {base = test,
+ offset = headerOffset,
+ ty = Type.sum (Vector.map
+ (pointers,
+ Type.pointerHeader))},
+ Operand.word (WordX.one WordSize.default))),
+ dst = SOME (tagVar, tagTy),
+ prim = Prim.wordRshift WordSize.default}
+ in
+ ([s],
+ Transfer.Switch
+ (Switch.T {cases = cases,
+ default = default,
+ size = WordSize.default,
+ test = Operand.Var {ty = tagTy,
+ var = tagVar}}))
+ end
+ fun prim () =
+ case (Vector.length cases, default) of
+ (1, _) =>
+ (* We use _ instead of NONE for the default becuase
+ * there may be an unreachable default case.
+ *)
+ let
+ val (c, l) = Vector.sub (cases, 0)
+ in
+ case conRep c of
+ ConRep.Void =>
+ Goto {dst = l,
+ args = Vector.new0 ()}
+ | ConRep.Transparent _ =>
+ Goto {dst = l,
+ args = Vector.new1 (test ())}
+ | ConRep.Tuple r =>
+ Goto {dst = l,
+ args = conSelects (r, 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"
+ val (ss, t) =
+ let
+ datatype z = datatype TyconRep.t
+ in
+ case tyconRep tycon of
+ Direct => ([], prim ())
+ | Enum => ([], enum (test ()))
+ | EnumDirect => enumAndOne ()
+ | EnumIndirect => enumAndOne ()
+ | EnumIndirectTag => switchEP indirectTag
+ | IndirectTag => indirectTag (test ())
+ | Void => ([], prim ())
+ end
+ in
+ (ss, t, !extraBlocks)
+ end
+ fun select {dst, offset, tuple, tupleTy} =
+ let
+ val TupleRep.T {offsets, ...} = tupleRep tupleTy
+ in
+ case Vector.sub (offsets, offset) of
+ NONE => []
+ | SOME {offset, ty} =>
+ [R.Statement.Bind
+ {isMutable = false,
+ oper = R.Operand.Offset {base = tuple (),
+ offset = offset,
+ ty = ty},
+ var = dst ()}]
+ end
+ fun tuple ({components, dst = (dst, dstTy), oper}) =
+ TupleRep.tuple (tupleRep dstTy,
+ {components = components, dst = dst, oper = oper})
+ fun reff {arg, dst, ty} =
+ TupleRep.tuple (refRep ty,
+ {components = Vector.new1 arg,
+ dst = dst,
+ oper = fn f => f ()})
in
- {conRep = conRep,
+ {conApp = conApp,
+ genCase = genCase,
objectTypes = objectTypes,
- refRep = refRep,
+ reff = reff,
+ select = select,
toRtype = toRtype,
- tupleRep = tupleRep,
- tyconRep = tyconRep}
+ tuple = tuple}
end
end
1.10 +21 -39 mlton/mlton/backend/representation.sig
Index: representation.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/representation.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- representation.sig 19 Mar 2004 04:40:07 -0000 1.9
+++ representation.sig 4 Apr 2004 06:50:17 -0000 1.10
@@ -25,50 +25,32 @@
type t
val layout: t -> Layout.t
- val select:
- t * {dst: unit -> Rssa.Var.t,
- offset: int,
- tuple: unit -> Rssa.Operand.t} -> Rssa.Statement.t list
- val tuple:
- t * {components: 'a vector,
- dst: Rssa.Var.t,
- oper: 'a -> Rssa.Operand.t} -> Rssa.Statement.t list
val tycon: t -> Rssa.PointerTycon.t
end
- (* How a constructor variant of a datatype is represented. *)
- structure ConRep:
- sig
- type t
-
- val con: t * {args: 'a vector,
- dst: unit -> Rssa.Var.t,
- oper: 'a -> Rssa.Operand.t,
- ty: unit -> Rssa.Type.t} -> Rssa.Statement.t list
- val layout: t -> Layout.t
- end
-
- structure TyconRep:
- sig
- type t
-
- val genCase:
- t * {cases: (ConRep.t * Rssa.Label.t) vector,
- default: Rssa.Label.t option,
- test: unit -> Rssa.Operand.t}
- -> (Rssa.Statement.t list
- * Rssa.Transfer.t
- * Rssa.Block.t list)
- end
-
val compute:
Ssa.Program.t
- -> {
- conRep: Ssa.Con.t -> ConRep.t,
+ -> {conApp: {args: 'a vector,
+ con: Ssa.Con.t,
+ dst: unit -> Rssa.Var.t,
+ oper: 'a -> Rssa.Operand.t,
+ ty: unit -> Rssa.Type.t} -> Rssa.Statement.t list,
+ genCase: {cases: (Ssa.Con.t * Rssa.Label.t) vector,
+ default: Rssa.Label.t option,
+ test: unit -> Rssa.Operand.t,
+ tycon: Ssa.Tycon.t} -> (Rssa.Statement.t list
+ * Rssa.Transfer.t
+ * Rssa.Block.t list),
objectTypes: Rssa.ObjectType.t vector,
- refRep: Ssa.Type.t -> TupleRep.t,
+ reff: {arg: unit -> Rssa.Operand.t,
+ dst: Rssa.Var.t,
+ ty: Ssa.Type.t} -> Rssa.Statement.t list,
+ select: {dst: unit -> Rssa.Var.t,
+ offset: int,
+ tuple: unit -> Rssa.Operand.t,
+ tupleTy: Ssa.Type.t} -> Rssa.Statement.t list,
toRtype: Ssa.Type.t -> Rssa.Type.t option,
- tupleRep: Ssa.Type.t -> TupleRep.t,
- tyconRep: Ssa.Tycon.t -> TyconRep.t
- }
+ tuple: {components: 'a vector,
+ dst: Rssa.Var.t * Ssa.Type.t,
+ oper: 'a -> Rssa.Operand.t} -> Rssa.Statement.t list}
end
1.47 +133 -124 mlton/mlton/backend/rssa.fun
Index: rssa.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- rssa.fun 18 Mar 2004 10:44:41 -0000 1.46
+++ rssa.fun 4 Apr 2004 06:50:17 -0000 1.47
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -9,6 +9,9 @@
struct
open S
+
+structure Type = RepType
+
local
open Runtime
in
@@ -16,6 +19,15 @@
structure GCField = GCField
end
+fun constrain (ty: Type.t): Layout.t =
+ let
+ open Layout
+ in
+ if !Control.showTypes
+ then seq [str ": ", Type.layout ty]
+ else empty
+ end
+
structure Operand =
struct
datatype t =
@@ -29,7 +41,7 @@
| GCState
| Line
| Offset of {base: t,
- offset: int,
+ offset: Bytes.t,
ty: Type.t}
| PointerTycon of PointerTycon.t
| Runtime of GCField.t
@@ -40,8 +52,8 @@
val int = Const o Const.int
val word = Const o Const.word
- fun bool b = Cast (int (IntX.make (if b then 1 else 0, IntSize.default)),
- Type.bool)
+ fun bool b =
+ word (WordX.fromIntInf (if b then 1 else 0, WordSize.default))
val ty =
fn ArrayOffset {ty, ...} => ty
@@ -54,26 +66,22 @@
Int i => Type.int (IntX.size i)
| IntInf _ => Type.intInf
| Real r => Type.real (RealX.size r)
- | Word w => Type.word (WordX.size w)
+ | Word w => Type.constant w
| Word8Vector _ => Type.word8Vector
end
- | EnsuresBytesFree => Type.word WordSize.default
+ | EnsuresBytesFree => Type.defaultWord
| File => Type.cPointer ()
- | GCState => Type.cPointer ()
+ | GCState => Type.gcState
| Line => Type.int IntSize.default
| Offset {ty, ...} => ty
- | PointerTycon _ => Type.word WordSize.default
- | Runtime z => Type.fromCType (GCField.ty z)
- | SmallIntInf _ => Type.IntInf
+ | PointerTycon _ => Type.defaultWord
+ | Runtime z => Type.ofGCField 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} =>
@@ -89,7 +97,7 @@
| Line => str "<Line>"
| Offset {base, offset, ty} =>
seq [str (concat ["O", Type.name ty, " "]),
- tuple [layout base, Int.layout offset],
+ tuple [layout base, Bytes.layout offset],
constrain ty]
| PointerTycon pt => PointerTycon.layout pt
| Runtime r => GCField.layout r
@@ -125,7 +133,7 @@
foldVars (z, (), f o #1)
fun caseBytes (z, {big: t -> 'a,
- small: word -> 'a}): 'a =
+ small: Bytes.t -> 'a}): 'a =
case z of
Const c =>
(case c of
@@ -134,7 +142,7 @@
val w = WordX.toIntInf w
in
if w <= 512 (* 512 is pretty arbitrary *)
- then small (Word.fromIntInf w)
+ then small (Bytes.fromIntInf w)
else big z
end
| _ => Error.bug "strange numBytes")
@@ -142,6 +150,7 @@
end
structure Switch = Switch (open S
+ structure Type = Type
structure Use = Operand)
structure Statement =
@@ -152,12 +161,11 @@
var: Var.t}
| Move of {dst: Operand.t,
src: Operand.t}
- | Object of {dst: Var.t,
- size: int,
- stores: {offset: int,
- value: Operand.t} vector,
- ty: Type.t,
- tycon: PointerTycon.t}
+ | Object of {dst: Var.t * Type.t,
+ header: word,
+ size: Bytes.t,
+ stores: {offset: Bytes.t,
+ value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
dst: (Var.t * Type.t) option,
prim: Prim.t}
@@ -177,7 +185,7 @@
Bind {oper, var, ...} =>
def (var, Operand.ty oper, useOperand (oper, a))
| Move {dst, src} => useOperand (src, useOperand (dst, a))
- | Object {dst, stores, ty, ...} =>
+ | Object {dst = (dst, ty), stores, ...} =>
Vector.fold (stores, def (dst, ty, a),
fn ({value, ...}, a) => useOperand (value, a))
| PrimApp {dst, args, ...} =>
@@ -211,10 +219,6 @@
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, constrain (Operand.ty oper),
@@ -222,17 +226,17 @@
| Move {dst, src} =>
mayAlign [Operand.layout dst,
seq [str " = ", Operand.layout src]]
- | Object {dst, size, stores, ty, tycon} =>
+ | Object {dst = (dst, ty), header, size, stores} =>
mayAlign
[seq [Var.layout dst, constrain ty],
seq [str " = Object ",
record
- [("size", Int.layout size),
- ("tycon", PointerTycon.layout tycon),
+ [("header", Word.layout header),
+ ("size", Bytes.layout size),
("stores",
Vector.layout
(fn {offset, value} =>
- record [("offset", Int.layout offset),
+ record [("offset", Bytes.layout offset),
("value", Operand.layout value)])
stores)]]]
| PrimApp {dst, prim, args, ...} =>
@@ -381,19 +385,19 @@
foreachDef (t, Var.clear o #1)
local
- fun make i = IntX.make (i, IntSize.default)
+ fun make i = WordX.fromIntInf (i, WordSize.default)
in
fun ifBool (test, {falsee, truee}) =
- Switch (Switch.Int
+ Switch (Switch.T
{cases = Vector.new2 ((make 0, falsee), (make 1, truee)),
default = NONE,
- size = IntSize.default,
+ size = WordSize.default,
test = test})
- fun ifInt (test, {falsee, truee}) =
- Switch (Switch.Int
- {cases = Vector.new1 (make 0, falsee),
- default = SOME truee,
- size = IntSize.default,
+ fun ifZero (test, {falsee, truee}) =
+ Switch (Switch.T
+ {cases = Vector.new1 (make 0, truee),
+ default = SOME falsee,
+ size = WordSize.default,
test = test})
end
end
@@ -994,7 +998,7 @@
ArrayOffset z => arrayOffsetIsOk z
| Cast (z, ty) =>
(checkOperand z
- ; (castIsOk
+ ; (Type.castIsOk
{from = Operand.ty z,
fromInt = (case z of
Const c =>
@@ -1009,11 +1013,17 @@
| File => true
| GCState => true
| Line => true
- | Offset z => offsetIsOk z
+ | Offset {base, offset, ty} =>
+ (case Type.offset (Operand.ty base,
+ {offset = offset,
+ pointerTy = tyconTy,
+ width = Type.width ty}) of
+ NONE => false
+ | SOME t => Type.isSubtype (t, ty))
| PointerTycon _ => true
| Runtime _ => true
| SmallIntInf _ => true
- | Var {ty, var} => Type.equals (ty, varType var)
+ | Var {ty, var} => Type.isSubtype (varType var, ty)
in
Err.check ("operand", ok, fn () => Operand.layout x)
end
@@ -1022,63 +1032,19 @@
val _ = checkOperand base
val _ = checkOperand index
in
- Type.equals (Operand.ty index, Type.defaultInt)
+ Type.isSubtype (Operand.ty index, Type.defaultInt)
andalso
- case Operand.ty base of
- 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
- 0 = offset
- andalso (Type.equals (ty, ty')
- orelse
- (* Get a word from a word8 array.*)
- (Type.equals
- (ty, Type.word (WordSize.W 32))
- andalso
- Type.equals
- (ty', Type.word (WordSize.W 8))))
- end
+ case Type.dest (Operand.ty base) of
+ Type.Pointer p =>
+ (case tyconTy p of
+ ObjectType.Array ty' =>
+ Type.isSubtype (ty', ty)
+ orelse
+ (* Get a word from a word8 array.*)
+ (Type.equals (ty, Type.defaultWord)
+ andalso Type.equals (ty', Type.word8))
| _ => false)
- | t => Type.isCPointer t
- 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
- ((* Array_toVector header update. *)
- (offset = Runtime.headerOffset
- andalso Type.equals (ty, Type.defaultWord))
- orelse
- (offset = Runtime.arrayLengthOffset
- andalso Type.equals (ty, Type.defaultInt))
- orelse
- Vector.forall
- (pointers, fn p =>
- case tyconTy p of
- ObjectType.Normal m => memChunkIsOk m
- | _ => false))
- | Type.MemChunk m => memChunkIsOk m
- | _ => false
+ | _ => Type.isCPointer (Operand.ty base)
end
val checkOperand =
Trace.trace ("checkOperand", Operand.layout, Unit.layout)
@@ -1096,22 +1062,41 @@
| Move {dst, src} =>
(checkOperand dst
; checkOperand src
- ; (Type.equals (Operand.ty dst, Operand.ty src)
+ ; (Type.isSubtype (Operand.ty src, Operand.ty dst)
andalso Operand.isLocation dst))
- | Object {stores, tycon, ...} =>
- (Vector.foreach (stores, checkOperand o # value)
- ; (case tyconTy tycon of
- ObjectType.Normal mc =>
- MemChunk.isValidInit
- (mc,
+ | Object {dst = (_, ty), header, size, stores} =>
+ let
+ val () =
+ Vector.foreach (stores, checkOperand o # value)
+ val tycon =
+ PointerTycon.fromIndex
+ (Runtime.headerToTypeIndex header)
+ in
+ Type.isSubtype (Type.pointer tycon, ty)
+ andalso
+ (case tyconTy tycon of
+ ObjectType.Normal t =>
+ Bytes.equals
+ (size, Bytes.+ (Runtime.normalHeaderSize,
+ Type.bytes t))
+ andalso
+ Type.isValidInit
+ (t,
Vector.map
(stores, fn {offset, value} =>
{offset = offset,
ty = Operand.ty value}))
- | _ => false))
- | PrimApp {args, ...} =>
+ | _ => false)
+ end
+ | PrimApp {args, dst, prim} =>
(Vector.foreach (args, checkOperand)
- ; true)
+ ; (case (Prim.typeCheck
+ (prim, Vector.map (args, Operand.ty))) of
+ NONE => false
+ | SOME t =>
+ case dst of
+ NONE => true
+ | SOME (_, t') => Type.isSubtype (t, t')))
| Profile _ => true
| ProfileLabel _ => true
| SetExnStackLocal => true
@@ -1128,7 +1113,7 @@
val Block.T {args = formals, kind, ...} = labelBlock dst
in
Vector.equals (args, formals, fn (t, (_, t')) =>
- Type.equals (t, t'))
+ Type.isSubtype (t, t'))
andalso (case kind of
Kind.Jump => true
| _ => false)
@@ -1138,7 +1123,8 @@
callee: Type.t vector option): bool =
case (caller, callee) of
(_, NONE) => true
- | (SOME ts, SOME ts') => Vector.equals (ts, ts', Type.equals)
+ | (SOME caller, SOME callee) =>
+ Vector.equals (callee, caller, Type.isSubtype)
| _ => false
fun nonTailIsOk (formals: (Var.t * Type.t) vector,
returns: Type.t vector option): bool =
@@ -1146,7 +1132,7 @@
NONE => true
| SOME ts =>
Vector.equals (formals, ts, fn ((_, t), t') =>
- Type.equals (t, t'))
+ Type.isSubtype (t', t))
fun callIsOk {args, func, raises, return, returns} =
let
val Function.T {args = formals,
@@ -1156,7 +1142,7 @@
in
Vector.equals (args, formals, fn (z, (_, t)) =>
- Type.equals (t, Operand.ty z))
+ Type.isSubtype (Operand.ty z, t))
andalso
(case return of
Return.Dead =>
@@ -1224,8 +1210,10 @@
andalso labelIsNullaryJump overflow
andalso labelIsNullaryJump success
andalso
- Vector.forall (args, fn x =>
- Type.equals (ty, Operand.ty x))
+ (case (Prim.typeCheck
+ (prim, Vector.map (args, Operand.ty))) of
+ NONE => false
+ | SOME t => Type.isSubtype (t, ty))
end
| CCall {args, func, return} =>
let
@@ -1233,6 +1221,11 @@
in
CFunction.isOk func
andalso
+ Vector.equals (args, CFunction.args func,
+ fn (z, t) =>
+ Type.isSubtype
+ (Operand.ty z, t))
+ andalso
case return of
NONE => true
| SOME l =>
@@ -1262,7 +1255,7 @@
| SOME ts =>
Vector.equals
(zs, ts, fn (z, t) =>
- Type.equals (t, Operand.ty z))))
+ Type.isSubtype (Operand.ty z, t))))
| Return zs =>
(checkOperands zs
; (case returns of
@@ -1270,24 +1263,40 @@
| SOME ts =>
Vector.equals
(zs, ts, fn (z, t) =>
- Type.equals (t, Operand.ty z))))
+ Type.isSubtype (Operand.ty z, t))))
| Switch s =>
Switch.isOk (s, {checkUse = checkOperand,
labelIsOk = labelIsNullaryJump})
end
- fun blockOk (Block.T {kind, statements, transfer, ...}): bool =
+ fun blockOk (Block.T {args, kind, 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
+ case k of
+ Cont _ => true
+ | CReturn {func} =>
+ let
+ val return = CFunction.return func
+ in
+ 0 = Vector.length args
+ orelse
+ (1 = Vector.length args
+ andalso
+ let
+ val expects =
+ #2 (Vector.sub (args, 0))
+ in
+ Type.isSubtype (return, expects)
+ andalso
+ CType.equals (Type.toCType return,
+ Type.toCType expects)
+ end)
+ end
+ | Handler => true
+ | Jump => true
end
val _ = check' (kind, "kind", kindOk, Kind.layout)
val _ =
1.29 +18 -27 mlton/mlton/backend/rssa.sig
Index: rssa.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/rssa.sig,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- rssa.sig 16 Mar 2004 06:38:27 -0000 1.28
+++ rssa.sig 4 Apr 2004 06:50:17 -0000 1.29
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -7,23 +7,15 @@
*)
type int = Int.t
type word = Word.t
-
+
signature RSSA_STRUCTS =
sig
- include MACHINE_ATOMS
+ include ATOMS
- structure Const: CONST
- structure Func: ID
structure Handler: HANDLER
- structure ProfileExp: PROFILE_EXP
structure Return: RETURN
- structure Var: VAR
sharing Handler = Return.Handler
- sharing IntX = Const.IntX
sharing Label = Handler.Label
- sharing RealX = Const.RealX
- sharing SourceInfo = ProfileExp.SourceInfo
- sharing WordX = Const.WordX
end
signature RSSA =
@@ -31,11 +23,10 @@
include RSSA_STRUCTS
structure Switch: SWITCH
- sharing IntX = Switch.IntX
- sharing Label = Switch.Label
- sharing PointerTycon = Switch.PointerTycon
- sharing Type = Switch.Type
- sharing WordX = Switch.WordX
+ sharing Atoms = Switch
+
+ structure Type: REP_TYPE
+ sharing Type = RepType
structure Operand:
sig
@@ -56,17 +47,17 @@
| GCState
| Line (* expand by codegen into int constant *)
| Offset of {base: t,
- offset: int,
+ offset: Bytes.t,
ty: Type.t}
| PointerTycon of PointerTycon.t
| Runtime of Runtime.GCField.t
| SmallIntInf of word
- | Var of {var: Var.t,
- ty: Type.t}
+ | Var of {ty: Type.t,
+ var: Var.t}
val bool: bool -> t
val caseBytes: t * {big: t -> 'a,
- small: word -> 'a} -> 'a
+ small: Bytes.t -> 'a} -> 'a
val cast: t * Type.t -> t
val int: IntX.t -> t
val layout: t -> Layout.t
@@ -84,13 +75,12 @@
var: Var.t}
| Move of {dst: Operand.t,
src: Operand.t}
- | Object of {dst: Var.t,
- size: int, (* in bytes, including header *)
+ | Object of {dst: Var.t * Type.t,
+ header: word,
+ size: Bytes.t, (* including header *)
(* The stores are in increasing order of offset. *)
- stores: {offset: int, (* bytes *)
- value: Operand.t} vector,
- ty: Type.t,
- tycon: PointerTycon.t}
+ stores: {offset: Bytes.t,
+ value: Operand.t} vector}
| PrimApp of {args: Operand.t vector,
dst: (Var.t * Type.t) option,
prim: Prim.t}
@@ -158,7 +148,8 @@
val foreachLabel: t * (Label.t -> unit) -> unit
val foreachUse: t * (Var.t -> unit) -> unit
val ifBool: Operand.t * {falsee: Label.t, truee: Label.t} -> t
- val ifInt: Operand.t * {falsee: Label.t, truee: Label.t} -> t
+ (* in ifZero, the operand should be of type defaultWord *)
+ val ifZero: Operand.t * {falsee: Label.t, truee: Label.t} -> t
val layout: t -> Layout.t
end
1.17 +27 -35 mlton/mlton/backend/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/sources.cm,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- sources.cm 19 Jul 2003 01:23:26 -0000 1.16
+++ sources.cm 4 Apr 2004 06:50:17 -0000 1.17
@@ -8,9 +8,7 @@
Group
signature MACHINE
-signature PROFILE_LABEL
-signature RUNTIME
-
+
functor Backend
functor Machine
@@ -22,40 +20,34 @@
../control/sources.cm
../ssa/sources.cm
-allocate-registers.fun
-allocate-registers.sig
-backend.fun
-backend.sig
-chunkify.fun
-chunkify.sig
-equivalence-graph.fun
-equivalence-graph.sig
+switch.sig
+switch.fun
err.sml
-implement-handlers.fun
+rssa.sig
+rssa.fun
+representation.sig
+representation.fun
+ssa-to-rssa.sig
+ssa-to-rssa.fun
implement-handlers.sig
-limit-check.fun
+implement-handlers.fun
limit-check.sig
-live.fun
-live.sig
-machine.fun
+limit-check.fun
+signal-check.sig
+signal-check.fun
machine.sig
-machine-atoms.fun
-machine-atoms.sig
-parallel-move.fun
-parallel-move.sig
-profile.fun
+machine.fun
profile.sig
-profile-label.fun
-profile-label.sig
-representation.fun
-representation.sig
-rssa.fun
-rssa.sig
-runtime.fun
-runtime.sig
-signal-check.fun
-signal-check.sig
-ssa-to-rssa.fun
-ssa-to-rssa.sig
-switch.fun
-switch.sig
+profile.fun
+live.sig
+live.fun
+allocate-registers.sig
+allocate-registers.fun
+equivalence-graph.sig
+equivalence-graph.fun
+chunkify.sig
+chunkify.fun
+parallel-move.sig
+parallel-move.fun
+backend.sig
+backend.fun
1.66 +319 -296 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.65
retrieving revision 1.66
diff -u -r1.65 -r1.66
--- ssa-to-rssa.fun 2 Apr 2004 02:49:52 -0000 1.65
+++ ssa-to-rssa.fun 4 Apr 2004 06:50:17 -0000 1.66
@@ -31,17 +31,18 @@
open CFunction
local
- open CType
+ open Type
in
- val Int32 = Int (IntSize.I 32)
- val Word32 = Word (WordSize.W 32)
+ val gcState = gcState
+ val Int32 = int (IntSize.I (Bits.fromInt 32))
+ val Word32 = word (Bits.fromInt 32)
+ val unit = unit
end
- datatype z = datatype CType.t
datatype z = datatype Convention.t
-
+
val copyCurrentThread =
- T {args = Vector.new1 Pointer,
+ T {args = Vector.new1 gcState,
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = false,
@@ -50,10 +51,10 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyCurrentThread",
- return = NONE}
+ return = unit}
val copyThread =
- T {args = Vector.new2 (Pointer, Pointer),
+ T {args = Vector.new2 (gcState, Type.thread),
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = false,
@@ -62,7 +63,7 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_copyThread",
- return = SOME Pointer}
+ return = Type.thread}
val exit =
T {args = Vector.new1 Int32,
@@ -74,10 +75,10 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "MLton_exit",
- return = NONE}
+ return = unit}
- val gcArrayAllocate =
- T {args = Vector.new4 (Pointer, Word32, Word32, Word32),
+ fun gcArrayAllocate {return} =
+ T {args = Vector.new4 (gcState, Word32, Int32, Word32),
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = true,
@@ -86,11 +87,11 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_arrayAllocate",
- return = SOME Pointer}
+ return = return}
local
fun make name =
- T {args = Vector.new1 Pointer,
+ T {args = Vector.new1 gcState,
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = false,
@@ -99,14 +100,14 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = name,
- return = NONE}
+ return = unit}
in
val pack = make "GC_pack"
val unpack = make "GC_unpack"
end
val threadSwitchTo =
- T {args = Vector.new2 (Pointer, Word32),
+ T {args = Vector.new2 (Type.thread, Word32),
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = true,
@@ -115,20 +116,20 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "Thread_switchTo",
- return = NONE}
+ return = unit}
- val weakCanGet =
- vanilla {args = Vector.new1 Pointer,
+ fun weakCanGet t =
+ vanilla {args = Vector.new1 t,
name = "GC_weakCanGet",
- return = SOME CType.bool}
+ return = Type.bool}
- val weakGet =
- vanilla {args = Vector.new1 Pointer,
+ fun weakGet {arg, return} =
+ vanilla {args = Vector.new1 arg,
name = "GC_weakGet",
- return = SOME Pointer}
+ return = return}
- val weakNew =
- T {args = Vector.new3 (Pointer, Word32, Pointer),
+ fun weakNew {arg, return} =
+ T {args = Vector.new3 (gcState, Word32, arg),
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = false,
@@ -137,10 +138,10 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_weakNew",
- return = SOME Pointer}
+ return = return}
val worldSave =
- T {args = Vector.new2 (Pointer, Int32),
+ T {args = Vector.new2 (gcState, Word32),
bytesNeeded = NONE,
convention = Cdecl,
ensuresBytesFree = false,
@@ -149,7 +150,12 @@
modifiesFrontier = true,
modifiesStackTop = true,
name = "GC_saveWorld",
- return = NONE}
+ return = unit}
+
+ fun size t =
+ vanilla {args = Vector.new1 t,
+ name = "MLton_size",
+ return = Int32}
end
structure Name =
@@ -159,37 +165,38 @@
fun cFunctionRaise (n: t): CFunction.t =
let
datatype z = datatype CFunction.Convention.t
+ val word = Type.word o WordSize.bits
val vanilla = CFunction.vanilla
- val int = ("Int", CType.Int, IntSize.toString)
- val real = ("Real", CType.Real, RealSize.toString)
- val word = ("Word", CType.Word, WordSize.toString)
+ val intC = ("Int", Type.int, IntSize.toString)
+ val realC = ("Real", Type.real, RealSize.toString)
+ val wordC = ("Word", word, WordSize.toString)
fun coerce (s1, (fromName, fromType, fromString),
s2, (toName, toType, toString)) =
vanilla {args = Vector.new1 (fromType s1),
name = concat [fromName, fromString s1,
"_to", toName, toString s2],
- return = SOME (toType s2)}
+ return = toType s2}
fun coerceX (s1, (fromName, fromType, fromString),
s2, (toName, toType, toString)) =
vanilla {args = Vector.new1 (fromType s1),
name = concat [fromName, fromString s1,
"_to", toName, toString s2, "X"],
- return = SOME (toType s2)}
+ return = toType s2}
fun intBinary (s, name) =
let
- val t = CType.Int s
+ val t = Type.int s
in
vanilla {args = Vector.new2 (t, t),
name = concat ["Int", IntSize.toString s, "_", name],
- return = SOME t}
+ return = t}
end
fun intCompare (s, name) =
- vanilla {args = Vector.new2 (CType.Int s, CType.Int s),
+ vanilla {args = Vector.new2 (Type.int s, Type.int s),
name = concat ["Int", IntSize.toString s, "_", name],
- return = SOME CType.bool}
+ return = Type.bool}
fun intInfBinary name =
- CFunction.T {args = Vector.new3 (CType.pointer, CType.pointer,
- CType.defaultWord),
+ CFunction.T {args = Vector.new3 (Type.intInf, Type.intInf,
+ Type.defaultWord),
bytesNeeded = SOME 2,
convention = Cdecl,
ensuresBytesFree = false,
@@ -198,15 +205,11 @@
modifiesFrontier = true,
modifiesStackTop = false,
name = concat ["IntInf_", name],
- return = SOME CType.pointer}
- fun intInfCompare name =
- vanilla {args = Vector.new2 (CType.pointer, CType.pointer),
- name = concat ["IntInf_", name],
- return = SOME CType.defaultInt}
+ return = Type.intInf}
fun intInfShift name =
- CFunction.T {args = Vector.new3 (CType.pointer,
- CType.defaultWord,
- CType.defaultWord),
+ CFunction.T {args = Vector.new3 (Type.intInf,
+ Type.defaultWord,
+ Type.defaultWord),
bytesNeeded = SOME 2,
convention = Cdecl,
ensuresBytesFree = false,
@@ -215,11 +218,11 @@
modifiesFrontier = true,
modifiesStackTop = false,
name = concat ["IntInf_", name],
- return = SOME CType.pointer}
+ return = Type.intInf}
val intInfToString =
- CFunction.T {args = Vector.new3 (CType.pointer,
- CType.defaultInt,
- CType.defaultWord),
+ CFunction.T {args = Vector.new3 (Type.intInf,
+ Type.defaultInt,
+ Type.defaultWord),
bytesNeeded = SOME 2,
convention = Cdecl,
ensuresBytesFree = false,
@@ -228,10 +231,9 @@
modifiesFrontier = true,
modifiesStackTop = false,
name = "IntInf_toString",
- return = SOME CType.pointer}
+ return = Type.string}
fun intInfUnary name =
- CFunction.T {args = Vector.new2 (CType.pointer,
- CType.defaultWord),
+ CFunction.T {args = Vector.new2 (Type.intInf, Type.defaultWord),
bytesNeeded = SOME 1,
convention = Cdecl,
ensuresBytesFree = false,
@@ -240,28 +242,28 @@
modifiesFrontier = true,
modifiesStackTop = false,
name = concat ["IntInf_", name],
- return = SOME CType.pointer}
+ return = Type.intInf}
fun wordBinary (s, name) =
let
- val t = CType.Word s
+ val t = word s
in
vanilla {args = Vector.new2 (t, t),
name = concat ["Word", WordSize.toString s,
"_", name],
- return = SOME t}
+ return = t}
end
fun wordCompare (s, name) =
- vanilla {args = Vector.new2 (CType.Word s, CType.Word s),
+ vanilla {args = Vector.new2 (word s, word s),
name = concat ["Word", WordSize.toString s, "_", name],
- return = SOME CType.bool}
+ return = Type.bool}
fun wordShift (s, name) =
- vanilla {args = Vector.new2 (CType.Word s, CType.defaultWord),
+ vanilla {args = Vector.new2 (word s, Type.defaultWord),
name = concat ["Word", WordSize.toString s, "_", name],
- return = SOME (CType.Word s)}
+ return = word s}
fun wordUnary (s, name) =
- vanilla {args = Vector.new1 (CType.Word s),
+ vanilla {args = Vector.new1 (word s),
name = concat ["Word", WordSize.toString s, "_", name],
- return = SOME (CType.Word s)}
+ return = word s}
in
case n of
Int_add s => intBinary (s, "add")
@@ -269,10 +271,10 @@
let
val s = IntSize.roundUpToPrim s
in
- vanilla {args = Vector.new2 (CType.Int s, CType.Int s),
+ vanilla {args = Vector.new2 (Type.int s, Type.int s),
name = concat ["Int", IntSize.toString s,
"_equal"],
- return = SOME CType.defaultInt}
+ return = Type.bool}
end
| Int_ge s => intCompare (s, "ge")
| Int_gt s => intCompare (s, "gt")
@@ -281,14 +283,20 @@
| Int_mul s => intBinary (s, "mul")
| Int_quot s => intBinary (s, "quot")
| Int_rem s => intBinary (s, "rem")
- | Int_toInt (s1, s2) => coerce (s1, int, s2, int)
- | Int_toReal (s1, s2) => coerce (s1, int, s2, real)
- | Int_toWord (s1, s2) => coerce (s1, int, s2, word)
+ | Int_toInt (s1, s2) => coerce (s1, intC, s2, intC)
+ | Int_toReal (s1, s2) => coerce (s1, intC, s2, realC)
+ | Int_toWord (s1, s2) => coerce (s1, intC, s2, wordC)
| IntInf_add => intInfBinary "add"
| IntInf_andb => intInfBinary "andb"
| IntInf_arshift => intInfShift "arshift"
- | IntInf_compare => intInfCompare "compare"
- | IntInf_equal => intInfCompare "equal"
+ | IntInf_compare =>
+ vanilla {args = Vector.new2 (Type.intInf, Type.intInf),
+ name = "IntInf_compare",
+ return = Type.defaultInt}
+ | IntInf_equal =>
+ vanilla {args = Vector.new2 (Type.intInf, Type.intInf),
+ name = "IntInf_equal",
+ return = Type.bool}
| IntInf_gcd => intInfBinary "gcd"
| IntInf_lshift => intInfShift "lshift"
| IntInf_mul => intInfBinary "mul"
@@ -301,7 +309,6 @@
| IntInf_toString => intInfToString
| IntInf_xorb => intInfBinary "xorb"
| MLton_bug => CFunction.bug
- | MLton_size => CFunction.size
| Thread_returnToC => CFunction.returnToC
| Word_add s => wordBinary (s, "add")
| Word_andb s => wordBinary (s, "andb")
@@ -322,10 +329,10 @@
| Word_ror s => wordShift (s, "ror")
| Word_rshift s => wordShift (s, "rshift")
| Word_sub s => wordBinary (s, "sub")
- | Word_toInt (s1, s2) => coerce (s1, word, s2, int)
- | Word_toIntX (s1, s2) => coerceX (s1, word, s2, int)
- | Word_toWord (s1, s2) => coerce (s1, word, s2, word)
- | Word_toWordX (s1, s2) => coerceX (s1, word, s2, word)
+ | Word_toInt (s1, s2) => coerce (s1, wordC, s2, intC)
+ | Word_toIntX (s1, s2) => coerceX (s1, wordC, s2, intC)
+ | Word_toWord (s1, s2) => coerce (s1, wordC, s2, wordC)
+ | Word_toWordX (s1, s2) => coerceX (s1, wordC, s2, wordC)
| Word_xorb s => wordBinary (s, "xorb")
| _ => raise Fail "cFunctionRaise"
end
@@ -595,21 +602,76 @@
structure Representation = Representation (structure Rssa = Rssa
structure Ssa = Ssa)
-local
- open Representation
-in
- structure ConRep = ConRep
- structure TupleRep = TupleRep
- structure TyconRep = TyconRep
-end
+
+fun updateCard (addr: Operand.t): Statement.t list =
+ let
+ val index = Var.newNoname ()
+ val indexTy = Type.defaultWord
+ in
+ [PrimApp {args = (Vector.new2
+ (addr,
+ Operand.word
+ (WordX.fromIntInf (IntInf.fromInt
+ (!Control.cardSizeLog2),
+ WordSize.default)))),
+ dst = SOME (index, indexTy),
+ prim = Prim.wordRshift WordSize.default},
+ Move {dst = (Operand.ArrayOffset
+ {base = Operand.Runtime GCField.CardMap,
+ index = (Operand.Cast
+ (Operand.Var {ty = indexTy, var = index},
+ Type.defaultInt)),
+ ty = Type.word Bits.inByte}),
+ src = Operand.word (WordX.one (WordSize.fromBits Bits.inByte))}]
+ end
+
+fun arrayUpdate {array, index, elt, ty}: Statement.t list =
+ if not (!Control.markCards) orelse not (Type.isPointer ty)
+ then
+ [Move {dst = ArrayOffset {base = array, index = index, ty = ty},
+ src = elt}]
+ else
+ let
+ val bytes = Bytes.toIntInf (Type.bytes ty)
+ val shift = IntInf.log2 bytes
+ val _ =
+ if bytes = IntInf.pow (2, shift)
+ then ()
+ else Error.bug "can't handle shift"
+ val shift = Bits.fromInt shift
+ val addr = Var.newNoname ()
+ val addrTy = Type.address ty
+ val addrOp = Operand.Var {ty = addrTy, var = addr}
+ val temp = Var.newNoname ()
+ val tempTy =
+ Type.seq
+ (Vector.new2 (Type.constant (WordX.zero (WordSize.fromBits shift)),
+ Type.word (Bits.- (Bits.inWord, shift))))
+ val tempOp = Operand.Var {ty = tempTy, var = temp}
+ in
+ [PrimApp {args = Vector.new2 (Operand.cast (index, Type.defaultWord),
+ Operand.word (WordX.fromIntInf
+ (Bits.toIntInf shift,
+ WordSize.default))),
+ dst = SOME (temp, tempTy),
+ prim = Prim.wordLshift WordSize.default},
+ PrimApp {args = Vector.new2 (Cast (array, addrTy), tempOp),
+ dst = SOME (addr, addrTy),
+ prim = Prim.wordAdd WordSize.default}]
+ @ updateCard addrOp
+ @ [Move {dst = Operand.Offset {base = addrOp,
+ offset = Bytes.zero,
+ ty = ty},
+ src = elt}]
+ end
+
+val word = Type.word o WordSize.bits
fun convert (program as S.Program.T {functions, globals, main, ...})
: Rssa.Program.t =
let
- val {conRep, objectTypes, refRep, toRtype, tupleRep, tyconRep} =
+ val {conApp, genCase, objectTypes, reff, select, toRtype, tuple} =
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)
val {get = varInfo: Var.t -> {ty: S.Type.t},
@@ -648,15 +710,15 @@
: Statement.t list * Transfer.t =
let
fun id x = x
- fun simple (s, cs, make, branch, le) =
+ fun simple (s, cs, cast) =
([],
Switch
- (make {cases = (QuickSort.sortVector
- (Vector.map (cs, fn (i, j) => (branch i, j)),
- fn ((i, _), (i', _)) => le (i, i'))),
- default = default,
- size = s,
- test = varOp test}))
+ (Switch.T
+ {cases = (QuickSort.sortVector
+ (cs, fn ((w, _), (w', _)) => WordX.<= (w, w'))),
+ default = default,
+ size = s,
+ test = cast (varOp test)}))
in
case cases of
S.Cases.Con cases =>
@@ -669,17 +731,12 @@
if Vector.isEmpty tys
then
let
- val cases =
- Vector.map
- (cases, fn (c, l) =>
- (conRep c, l))
val test = fn () => varOp test
val (ss, t, blocks) =
- TyconRep.genCase
- (tyconRep tycon,
- {cases = cases,
- default = default,
- test = test})
+ genCase {cases = cases,
+ default = default,
+ test = test,
+ tycon = tycon}
val () =
extraBlocks := blocks @ !extraBlocks
in
@@ -687,8 +744,18 @@
end
else Error.bug "strange type in case"
end)
- | S.Cases.Int (s, cs) => simple (s, cs, Switch.Int, id, IntX.<=)
- | S.Cases.Word (s, cs) => simple (s, cs, Switch.Word, id, WordX.<=)
+ | S.Cases.Int (s, cs) =>
+ let
+ val s = WordSize.fromBits (IntSize.bits s)
+ val cs = Vector.map (cs, fn (i, l) =>
+ (WordX.fromIntInf (IntX.toIntInf i, s),
+ l))
+ val t = word s
+ in
+ simple (s, cs, fn z => Operand.Cast (z, t))
+ end
+ | S.Cases.Word (s, cs) =>
+ simple (s, cs, fn z => z)
end
val {get = labelInfo: (Label.t ->
{args: (Var.t * S.Type.t) vector,
@@ -847,22 +914,25 @@
fun bogus (t: Type.t): Operand.t =
let
val c = Operand.Const
+ datatype z = datatype Type.dest
in
- case t of
- Type.EnumPointers _ =>
+ case Type.dest t of
+ Constant w => c (Const.word w)
+ | Int s => c (Const.int (IntX.zero s))
+ | Pointer _ =>
Operand.Cast (Operand.int (IntX.one IntSize.default), t)
- | Type.ExnStack => Error.bug "bogus ExnStack"
- | Type.Int s => c (Const.int (IntX.zero s))
- | Type.IntInf => SmallIntInf 0wx1
- | Type.Label _ => Error.bug "bogus Label"
- | Type.MemChunk _ => Error.bug "bogus MemChunk"
- | Type.Real s => c (Const.real (RealX.zero s))
- | Type.Word s => c (Const.word (WordX.zero s))
+ | Real s => c (Const.real (RealX.zero s))
+ | Sum ts => bogus (Vector.sub (ts, 0))
+ | Word s => c (Const.word (WordX.zero (WordSize.fromBits s)))
+ | _ => Error.bug (concat ["no bogus value of type ",
+ Layout.toString (Type.layout t)])
end
val handlesSignals =
S.Program.hasPrim
(program, fn p =>
- Prim.name p = Prim.Name.MLton_installSignalHandler)
+ case Prim.name p of
+ Prim.Name.MLton_installSignalHandler => true
+ | _ => false)
fun translateStatementsTransfer (statements, ss, transfer) =
let
fun loop (i, ss, t): Statement.t vector * Transfer.t =
@@ -887,11 +957,6 @@
in
loop (i - 1, ss, t)
end
- fun allocate (ys: Var.t vector, tr) =
- adds (TupleRep.tuple
- (tr, {components = ys,
- dst = valOf var,
- oper = varOp}))
fun move (oper: Operand.t) =
add (Bind {isMutable = false,
oper = oper,
@@ -899,12 +964,12 @@
in
case exp of
S.Exp.ConApp {con, args} =>
- adds (ConRep.con
- (conRep con,
- {args = args,
- dst = fn () => valOf var,
- oper = varOp,
- ty = fn () => valOf (toRtype ty)}))
+ adds (conApp
+ {args = args,
+ con = con,
+ dst = fn () => valOf var,
+ oper = varOp,
+ ty = fn () => valOf (toRtype ty)})
| S.Exp.Const c =>
let
datatype z = datatype Const.t
@@ -935,7 +1000,7 @@
NONE => no ()
| SOME t =>
if Type.isPointer t
- then yes ()
+ then yes t
else no ()
fun arrayOrVectorLength () =
move (Operand.Offset
@@ -963,20 +1028,21 @@
val canHandle =
Operand.Runtime GCField.CanHandle
val res = Var.newNoname ()
+ val resTy = Operand.ty canHandle
in
[Statement.PrimApp
{args = (Vector.new2
(canHandle,
- (Operand.int
- (IntX.make
+ (Operand.word
+ (WordX.fromIntInf
(IntInf.fromInt n,
- IntSize.default))))),
- dst = SOME (res, Type.defaultInt),
- prim = Prim.intAdd IntSize.default},
+ WordSize.default))))),
+ dst = SOME (res, resTy),
+ prim = Prim.wordAdd WordSize.default},
Statement.Move
{dst = canHandle,
src = Operand.Var {var = res,
- ty = Type.defaultInt}}]
+ ty = resTy}}]
end
fun ccallGen
{args: Operand.t vector,
@@ -1027,105 +1093,30 @@
end)
end
fun ccall {args, func} =
- ccallGen {args = args,
- func = func,
- prefix = fn t => ([], t)}
+ ccallGen {args = args,
+ func = func,
+ prefix = fn t => ([], t)}
fun simpleCCall (f: CFunction.t) =
ccall {args = vos args,
func = f}
fun array (numElts: Operand.t) =
let
+ val result = valOf (toRtype ty)
val pt =
- case (Type.dePointer
- (valOf (toRtype ty))) of
- NONE => Error.bug "strange array"
- | SOME pt => PointerTycon pt
+ case Type.dest result of
+ Type.Pointer pt => PointerTycon pt
+ | _ => Error.bug "strange array"
val args =
Vector.new4 (Operand.GCState,
Operand.EnsuresBytesFree,
numElts,
pt)
+ val func =
+ CFunction.gcArrayAllocate
+ {return = result}
in
- ccall {args = args,
- func = CFunction.gcArrayAllocate}
+ ccall {args = args, func = func}
end
- fun updateCard (addr: Operand.t, prefix, assign) =
- let
- val index = Var.newNoname ()
- val ss =
- (PrimApp
- {args = (Vector.new2
- (Operand.Cast (addr, Type.defaultWord),
- Operand.word
- (WordX.fromIntInf
- (IntInf.fromInt
- (!Control.cardSizeLog2),
- WordSize.default)))),
- dst = SOME (index, Type.defaultInt),
- prim = Prim.wordRshift WordSize.default})
- :: (Move
- {dst = (Operand.ArrayOffset
- {base = (Operand.Runtime
- GCField.CardMap),
- index = (Operand.Var
- {ty = Type.defaultInt,
- var = index}),
- ty = Type.word (WordSize.W 8)}),
- src = Operand.word (WordX.one (WordSize.W 8))})
- :: assign
- :: ss
- in
- loop (i - 1, prefix ss, t)
- end
- fun arrayUpdate (ty: Type.t) =
- if !Control.markCards andalso Type.isPointer ty
- then let
- val arrayOp = varOp (a 0)
- val temp = Var.newNoname ()
- val tempOp =
- Operand.Var {var = temp,
- ty = Type.defaultWord}
- val addr = Var.newNoname ()
- 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.Cast (varOp (a 1),
- Type.defaultWord),
- Operand.word
- (WordX.fromIntInf
- (IntInf.fromInt (Type.size ty),
- WordSize.default))),
- dst = SOME (temp, Type.defaultWord),
- prim = Prim.wordMul WordSize.default})
- :: (PrimApp
- {args = (Vector.new2
- (Operand.Cast (arrayOp,
- Type.defaultWord),
- tempOp)),
- dst = SOME (addr, Type.MemChunk mc),
- prim = Prim.wordAdd WordSize.default})
- :: ss
- 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 = varOp (a 2)})
fun pointerGet ty =
move (ArrayOffset {base = varOp (a 0),
index = varOp (a 1),
@@ -1138,14 +1129,18 @@
fun refAssign (ty, src) =
let
val addr = varOp (a 0)
- val assign = Move {dst = Operand.Offset {base = addr,
- offset = 0,
- ty = ty},
- src = src}
+ val ss =
+ Move {dst = Operand.Offset {base = addr,
+ offset = Bytes.zero,
+ ty = ty},
+ src = src}
+ :: ss
+ val ss =
+ if !Control.markCards andalso Type.isPointer ty
+ then updateCard addr @ ss
+ else ss
in
- if !Control.markCards andalso Type.isPointer ty
- then updateCard (addr, fn ss => ss, assign)
- else loop (i - 1, assign::ss, t)
+ loop (i - 1, ss, t)
end
fun nativeOrC (p: Prim.t) =
let
@@ -1161,12 +1156,18 @@
Name.toString n])
| SOME f => simpleCCall f)
end
+ val arrayUpdate =
+ fn ty =>
+ loop (i - 1,
+ arrayUpdate {array = varOp (a 0),
+ index = varOp (a 1),
+ elt = varOp (a 2),
+ ty = ty}
+ @ ss, t)
datatype z = datatype Prim.Name.t
in
case Prim.name prim of
- Array_array =>
- array (Operand.Var {var = a 0,
- ty = Type.defaultInt})
+ Array_array => array (varOp (a 0))
| Array_length => arrayOrVectorLength ()
| Array_sub =>
(case targ () of
@@ -1177,9 +1178,9 @@
val array = varOp (a 0)
val vecTy = valOf (toRtype ty)
val pt =
- case Type.dePointer vecTy of
- NONE => Error.bug "strange Array_toVector"
- | SOME pt => pt
+ case Type.dest vecTy of
+ Type.Pointer pt => pt
+ | _ => Error.bug "strange Array_toVector"
in
loop
(i - 1,
@@ -1241,21 +1242,24 @@
NONE => move (Operand.bool true)
| SOME _ => primApp prim)
| MLton_installSignalHandler => none ()
+ | MLton_size =>
+ simpleCCall
+ (CFunction.size (Operand.ty (varOp (a 0))))
| MLton_touch => none ()
- | Pointer_getInt s => pointerGet (Type.Int s)
+ | Pointer_getInt s => pointerGet (Type.int s)
| Pointer_getPointer =>
(case targ () of
NONE => Error.bug "getPointer"
| SOME t => pointerGet t)
- | Pointer_getReal s => pointerGet (Type.Real s)
- | Pointer_getWord s => pointerGet (Type.Word s)
- | Pointer_setInt s => pointerSet (Type.Int s)
+ | Pointer_getReal s => pointerGet (Type.real s)
+ | Pointer_getWord s => pointerGet (word s)
+ | Pointer_setInt s => pointerSet (Type.int s)
| Pointer_setPointer =>
(case targ () of
NONE => Error.bug "setPointer"
| SOME t => pointerSet t)
- | Pointer_setReal s => pointerSet (Type.Real s)
- | Pointer_setWord s => pointerSet (Type.Word s)
+ | Pointer_setReal s => pointerSet (Type.real s)
+ | Pointer_setWord s => pointerSet (word s)
| Ref_assign =>
(case targ () of
NONE => none ()
@@ -1265,19 +1269,20 @@
NONE => none ()
| SOME ty =>
move (Offset {base = varOp (a 0),
- offset = 0,
+ offset = Bytes.zero,
ty = ty}))
| Ref_ref =>
- allocate
- (Vector.new1 (a 0),
- refRep (Vector.sub (targs, 0)))
+ adds (reff {arg = fn () => varOp (a 0),
+ dst = valOf var,
+ ty = Vector.sub (targs, 0)})
| Thread_atomicBegin =>
(* gcState.canHandle++;
* if (gcState.signalIsPending)
* gcState.limit = gcState.limitPlusSlop - LIMIT_SLOP;
*)
split
- (Vector.new0 (), Kind.Jump, ss, fn l =>
+ (Vector.new0 (), Kind.Jump, ss,
+ fn continue =>
let
datatype z = datatype GCField.t
val tmp = Var.newNoname ()
@@ -1291,7 +1296,7 @@
Operand.word
(WordX.fromIntInf
(IntInf.fromInt
- Runtime.limitSlop,
+ (Bytes.toInt Runtime.limitSlop),
size)))),
dst = SOME (tmp, ty),
prim = Prim.wordSub size},
@@ -1299,25 +1304,25 @@
{dst = Operand.Runtime Limit,
src = Operand.Var {var = tmp,
ty = ty}})
- val l' =
+ val signalIsPending =
newBlock
{args = Vector.new0 (),
kind = Kind.Jump,
statements = statements,
transfer = (Transfer.Goto
{args = Vector.new0 (),
- dst = l})}
+ dst = continue})}
in
- if handlesSignals
- then (bumpCanHandle 1,
- Transfer.ifInt
- (Operand.Runtime SignalIsPending,
- {falsee = l,
- truee = l'}))
- else (bumpCanHandle 1,
- Transfer.Goto
- {args = Vector.new0 (),
- dst = l})
+ (bumpCanHandle 1,
+ if handlesSignals
+ then
+ Transfer.ifBool
+ (Operand.Runtime SignalIsPending,
+ {falsee = continue,
+ truee = signalIsPending})
+ else
+ Transfer.Goto {args = Vector.new0 (),
+ dst = continue})
end)
| Thread_atomicEnd =>
(* gcState.canHandle--;
@@ -1326,56 +1331,64 @@
* gc;
*)
split
- (Vector.new0 (), Kind.Jump, ss, fn l =>
+ (Vector.new0 (), Kind.Jump, ss,
+ fn continue =>
let
datatype z = datatype GCField.t
- val func = CFunction.gc {maySwitchThreads = true}
+ val func =
+ CFunction.gc {maySwitchThreads = true}
+ val returnFromHandler =
+ newBlock
+ {args = Vector.new0 (),
+ kind = Kind.CReturn {func = func},
+ statements = Vector.new0 (),
+ transfer =
+ Goto {args = Vector.new0 (),
+ dst = continue}}
val args =
Vector.new5
(Operand.GCState,
- Operand.int (IntX.zero IntSize.default),
+ Operand.int (IntX.zero
+ IntSize.default),
Operand.bool false,
Operand.File,
Operand.Line)
- val l''' =
- newBlock
- {args = Vector.new0 (),
- kind = Kind.CReturn {func = func},
- statements = Vector.new0 (),
- transfer = Goto {args = Vector.new0 (),
- dst = l}}
- val l'' =
+ val switchToHandler =
newBlock
{args = Vector.new0 (),
kind = Kind.Jump,
statements = Vector.new0 (),
- transfer = Transfer.CCall {args = args,
- func = func,
- return = SOME l'''}}
- val l' =
+ transfer =
+ Transfer.CCall
+ {args = args,
+ func = func,
+ return = SOME returnFromHandler}}
+ val testCanHandle =
newBlock
{args = Vector.new0 (),
kind = Kind.Jump,
statements = Vector.new0 (),
transfer =
- Transfer.ifInt
+ Transfer.ifZero
(Operand.Runtime CanHandle,
- {falsee = l'',
- truee = l})}
+ {falsee = continue,
+ truee = switchToHandler})}
in
- if handlesSignals
- then (bumpCanHandle ~1,
- Transfer.ifInt
- (Operand.Runtime SignalIsPending,
- {falsee = l,
- truee = l'}))
- else (bumpCanHandle ~1,
- Transfer.Goto
- {args = Vector.new0 (),
- dst = l})
+ (bumpCanHandle ~1,
+ if handlesSignals
+ then
+ Transfer.ifBool
+ (Operand.Runtime SignalIsPending,
+ {falsee = continue,
+ truee = testCanHandle})
+ else
+ Transfer.Goto {args = Vector.new0 (),
+ dst = continue})
end)
| Thread_canHandle =>
- move (Operand.Runtime GCField.CanHandle)
+ move (Operand.Cast
+ (Operand.Runtime GCField.CanHandle,
+ Type.defaultInt))
| Thread_copy =>
ccall {args = (Vector.concat
[Vector.new1 Operand.GCState,
@@ -1393,28 +1406,37 @@
| SOME t => sub t)
| Weak_canGet =>
ifTargIsPointer
- (fn () => simpleCCall CFunction.weakCanGet,
+ (fn _ => (simpleCCall
+ (CFunction.weakCanGet
+ (Operand.ty (varOp (a 0))))),
fn () => move (Operand.bool false))
| Weak_get =>
ifTargIsPointer
- (fn () => simpleCCall CFunction.weakGet,
+ (fn t => (simpleCCall
+ (CFunction.weakGet
+ {arg = Operand.ty (varOp (a 0)),
+ return = t})),
none)
| Weak_new =>
ifTargIsPointer
- (fn () =>
+ (fn t =>
let
+ val result = valOf (toRtype ty)
val header =
Operand.PointerTycon
- (valOf
- (Type.dePointer
- (valOf (toRtype ty))))
+ (case Type.dest result of
+ Type.Pointer pt => pt
+ | _ => Error.bug "Weak_new")
+ val func =
+ CFunction.weakNew {arg = t,
+ return = result}
in
ccall {args = (Vector.concat
[Vector.new2
(Operand.GCState,
header),
vos args]),
- func = CFunction.weakNew}
+ func = func}
end,
none)
| Word_equal s =>
@@ -1444,15 +1466,16 @@
end
| S.Exp.Profile e => add (Statement.Profile e)
| S.Exp.Select {tuple, offset} =>
- adds (TupleRep.select
- (tupleRep (varType tuple),
- {dst = fn () => valOf var,
- offset = offset,
- tuple = fn () => varOp tuple}))
+ adds (select {dst = fn () => valOf var,
+ offset = offset,
+ tuple = fn () => varOp tuple,
+ tupleTy = varType tuple})
| S.Exp.Tuple ys =>
if 0 = Vector.length ys
then none ()
- else allocate (ys, tupleRep ty)
+ else adds (tuple {components = ys,
+ dst = (valOf var, ty),
+ oper = varOp})
| S.Exp.Var y =>
(case toRtype ty of
NONE => none ()
1.5 +42 -157 mlton/mlton/backend/switch.fun
Index: switch.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/switch.fun,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- switch.fun 19 Feb 2004 22:42:09 -0000 1.4
+++ switch.fun 4 Apr 2004 06:50:17 -0000 1.5
@@ -30,175 +30,60 @@
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 =
- EnumPointers of {enum: Label.t,
- pointers: Label.t,
- test: Use.t}
- | Int of {cases: (IntX.t * Label.t) vector,
- default: Label.t option,
- size: IntSize.t,
- 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: (WordX.t * Label.t) vector,
- default: Label.t option,
- size: WordSize.t,
- test: Use.t}
+ T of {cases: (WordX.t * Label.t) vector,
+ default: Label.t option,
+ size: WordSize.t,
+ test: Use.t}
-fun layout s =
+fun layout (T {cases, default, test, ...})=
let
open Layout
- fun simple ({cases, default, size = _, 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
- 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", IntX.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", WordX.layout)
+ seq [str "switch ",
+ record [("test", Use.layout test),
+ ("default", Option.layout Label.layout default),
+ ("cases",
+ Vector.layout
+ (Layout.tuple2 (fn w => seq [str "0x", WordX.layout w],
+ Label.layout))
+ cases)]]
end
-fun isOk (s, {checkUse, labelIsOk}): bool =
- case s of
- EnumPointers {enum, pointers, test, ...} =>
- (checkUse test
- ; (labelIsOk enum
- andalso labelIsOk pointers
- andalso (case Use.ty test of
- Type.EnumPointers _ => true
- | _ => false)))
- | Int {cases, default, size, test} =>
- (checkUse test
- ; ((case default of
- NONE => true
- | SOME l => labelIsOk l)
- andalso Vector.forall (cases, labelIsOk o #2)
- andalso Vector.isSorted (cases, fn ((i, _), (i', _)) =>
- IntX.<= (i, i'))
- andalso
- (case Use.ty test of
- Type.EnumPointers {enum, pointers} =>
- 0 = Vector.length pointers
- andalso
- exhaustiveAndIrredundant
- {all = Vector.map (enum, fn i =>
- IntX.make (IntInf.fromInt i, size)),
- cases = Vector.map (cases, #1),
- default = default,
- equals = IntX.equals}
- | Type.Int s =>
- IntSize.equals (size, s)
- andalso Option.isSome default
- andalso not (isRedundant
- {cases = cases,
- equals = fn ((i, _), (i', _)) =>
- IntX.equals (i, i')})
-
- | _ => false)))
- | Pointer {cases, default, tag, test} =>
- (checkUse tag
- ; checkUse test
- ; (Type.equals (Use.ty tag, Type.defaultInt)
- 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, size, test} =>
- (checkUse test
- ; (Type.equals (Use.ty test, Type.word size)
- andalso (case default of
- NONE => false
- | SOME l => labelIsOk l)
- andalso Vector.forall (cases, labelIsOk o #2)
- andalso Vector.isSorted (cases, fn ((w, _), (w', _)) =>
- WordX.<= (w, w'))
- andalso
- not (isRedundant
- {cases = cases,
- equals = fn ((w, _), (w', _)) => WordX.equals (w, w')})))
-
-fun foldLabelUse (s: t, a: 'a, {label, use}): 'a =
+fun isOk (T {cases, default, size, test}, {checkUse, labelIsOk}): bool =
let
- fun simple {cases, default, size = _, test} =
+ val () = checkUse test
+ val ty = Use.ty test
+ in
+ Vector.forall (cases, labelIsOk o #2)
+ andalso (case default of
+ NONE => true
+ | SOME l => labelIsOk l)
+ andalso Vector.isSorted (cases, fn ((w, _), (w', _)) => WordX.<= (w, w'))
+ andalso not (isRedundant
+ {cases = cases,
+ equals = fn ((w, _), (w', _)) => WordX.equals (w, w')})
+ andalso
+ if 0 = Vector.length cases
+ then isSome default
+ else
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))
+ val casesTy =
+ Type.sum (Vector.map (cases, fn (w, _) => Type.constant w))
in
- a
+ Bits.equals (Type.width ty, Type.width casesTy)
+ andalso (isSome default orelse Type.isSubtype (ty, casesTy))
end
+ end
+
+fun foldLabelUse (T {cases, default, test, ...}, a: 'a, {label, use}): 'a =
+ 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
- case s of
- 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
+ a
end
fun foreachLabel (s, f) =
1.5 +11 -22 mlton/mlton/backend/switch.sig
Index: switch.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/switch.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- switch.sig 18 Mar 2004 03:22:23 -0000 1.4
+++ switch.sig 4 Apr 2004 06:50:17 -0000 1.5
@@ -1,4 +1,4 @@
-(* Copyright (C) 2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2002-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under the GNU General Public License (GPL).
@@ -8,7 +8,11 @@
signature SWITCH_STRUCTS =
sig
- include MACHINE_ATOMS
+ structure Label: LABEL
+ structure Type: REP_TYPE
+ structure WordSize: WORD_SIZE
+ structure WordX: WORD_X
+ sharing WordX = Type.WordX
structure Use: sig
type t
@@ -23,26 +27,11 @@
include SWITCH_STRUCTS
datatype t =
- EnumPointers of {enum: Label.t,
- pointers: Label.t,
- test: Use.t}
- | Int of {(* Cases are in increasing order of int. *)
- cases: (IntX.t * Label.t) vector,
- default: Label.t option,
- size: IntSize.t,
- 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 word. *)
- cases: (WordX.t * Label.t) vector,
- default: Label.t option,
- size: WordSize.t,
- test: Use.t}
+ T of {(* Cases are in increasing order of word. *)
+ cases: (WordX.t * Label.t) vector,
+ default: Label.t option,
+ size: WordSize.t,
+ test: Use.t}
val foldLabelUse: t * 'a * {label: Label.t * 'a -> 'a,
use: Use.t * 'a -> 'a} -> 'a
1.4 +5 -5 mlton/mlton/closure-convert/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/closure-convert/sources.cm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sources.cm 16 Apr 2002 12:10:52 -0000 1.3
+++ sources.cm 4 Apr 2004 06:50:17 -0000 1.4
@@ -17,11 +17,11 @@
../ssa/sources.cm
../xml/sources.cm
-abstract-value.fun
abstract-value.sig
-closure-convert.fun
-closure-convert.sig
-globalize.fun
+abstract-value.fun
globalize.sig
-lambda-free.fun
+globalize.fun
lambda-free.sig
+lambda-free.fun
+closure-convert.sig
+closure-convert.fun
1.76 +54 -84 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.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- c-codegen.fun 18 Mar 2004 03:22:23 -0000 1.75
+++ c-codegen.fun 4 Apr 2004 06:50:18 -0000 1.76
@@ -35,6 +35,7 @@
structure RealSize = RealSize
structure RealX = RealX
structure Register = Register
+ structure RepType = RepType
structure Runtime = Runtime
structure Statement = Statement
structure Switch = Switch
@@ -159,6 +160,8 @@
fun int (i: int) =
IntX.toC (IntX.make (IntInf.fromInt i, IntSize.default))
+ val bytes = int o Bytes.toInt
+
fun string s =
let val quote = "\""
in concat [quote, String.escapeC s, quote]
@@ -166,8 +169,8 @@
fun word (w: Word.t) = "0x" ^ Word.toString w
- fun push (i, print) =
- call ("\tPush", [int i], print)
+ fun push (size: Bytes.t, print) =
+ call ("\tPush", [bytes size], print)
end
structure Operand =
@@ -184,8 +187,8 @@
| _ => false
end
-fun creturn (t: CType.t): string =
- concat ["CReturn", CType.name t]
+fun creturn (t: RepType.t): string =
+ concat ["CReturn", CType.name (RepType.toCType t)]
fun outputIncludes (includes, print) =
(List.foreach (includes, fn i => (print "#include <";
@@ -283,7 +286,7 @@
(frameOffsets, fn (i, v) =>
(print (concat ["static ushort frameOffsets", C.int i, "[] = {"])
; print (C.int (Vector.length v))
- ; Vector.foreach (v, fn i => (print ","; print (C.int i)))
+ ; Vector.foreach (v, fn i => (print ","; print (C.bytes i)))
; print "};\n"))
fun declareArray (ty: string,
name: string,
@@ -298,7 +301,7 @@
fn (_, {frameOffsetsIndex, isC, size}) =>
concat ["{",
C.bool isC,
- ", ", C.int size,
+ ", ", C.bytes size,
", frameOffsets", C.int frameOffsetsIndex,
"}"])
fun declareAtMLtons () =
@@ -308,13 +311,13 @@
("GC_ObjectType", "objectTypes", objectTypes,
fn (_, ty) =>
let
- datatype z = datatype Runtime.ObjectType.t
+ datatype z = datatype Runtime.RObjectType.t
val (tag, nonPointers, pointers) =
case ObjectType.toRuntime ty of
- Array {numBytesNonPointers, numPointers} =>
- (0, numBytesNonPointers, numPointers)
- | Normal {numPointers, numWordsNonPointers} =>
- (1, numWordsNonPointers, numPointers)
+ Array {nonPointer, pointers} =>
+ (0, Bytes.toInt nonPointer, pointers)
+ | Normal {nonPointer, pointers} =>
+ (1, Words.toInt nonPointer, pointers)
| Stack =>
(2, 0, 0)
| Weak =>
@@ -340,7 +343,7 @@
[C.int align,
C.int (!Control.cardSizeLog2),
magic,
- C.int maxFrameSize,
+ C.bytes maxFrameSize,
C.bool (!Control.markCards),
C.bool (!Control.profileStack)]
@ additionalMainArgs,
@@ -401,28 +404,8 @@
struct
open Type
- local
- fun make (name, memo, toString) =
- memo (fn s => concat [name, toString s])
- val int = make ("Int", IntSize.memoize, IntSize.toString)
- val real = make ("Real", RealSize.memoize, RealSize.toString)
- val word = make ("Word", WordSize.memoize, WordSize.toString)
- val pointer = "Pointer"
- in
- fun toC (t: t): string =
- case t of
- EnumPointers {pointers, ...} =>
- if 0 = Vector.length pointers
- then int (IntSize.I 32)
- else pointer
- | ExnStack => word WordSize.default
- | Int s => int s
- | IntInf => pointer
- | Label _ => word WordSize.default
- | Real s => real s
- | Word s => word s
- | _ => Error.bug (concat ["Type.toC strange type: ", toString t])
- end
+ fun toC (t: t): string =
+ CType.toString (Type.toCType t)
end
fun contents (ty, z) = concat ["C", C.args [Type.toC ty, z]]
@@ -548,7 +531,9 @@
| Label l => labelToStringIndex l
| Line => "__LINE__"
| Offset {base, offset, ty} =>
- concat ["O", C.args [Type.toC ty, toString base, C.int offset]]
+ concat ["O", C.args [Type.toC ty,
+ toString base,
+ C.bytes offset]]
| Real r => RealX.toC r
| Register r =>
concat [Type.name (Register.ty r), "_",
@@ -556,7 +541,7 @@
| SmallIntInf w =>
concat ["SmallIntInf", C.args [concat ["0x", Word.toString w]]]
| StackOffset {offset, ty} =>
- concat ["S", C.args [Type.toC ty, C.int offset]]
+ concat ["S", C.args [Type.toC ty, C.bytes offset]]
| StackTop => "StackTop"
| Word w => WordX.toC w
in
@@ -597,9 +582,10 @@
contents
(Operand.ty value,
concat ["Frontier + ",
- C.int
- (offset
- + Runtime.normalHeaderSize)])
+ C.bytes
+ (Bytes.+
+ (offset,
+ Runtime.normalHeaderSize))])
in
print "\t"
; (print
@@ -610,13 +596,13 @@
ty = ty}))
end))
; print "\t"
- ; C.call ("EndObject", [C.int size], print))
+ ; C.call ("EndObject", [C.bytes size], print))
| PrimApp {args, dst, prim} =>
let
fun call (): string =
concat
[Prim.toString prim,
- "(",
+ " (",
concat
(List.separate
(Vector.toListMap (args, fetchOperand),
@@ -671,7 +657,8 @@
doit
(name, fn () =>
concat
- ["extern ", CType.toString ty,
+ ["extern ",
+ CType.toString (RepType.toCType ty),
" ", name, ";\n"])
| _ => ())
| _ => ())
@@ -753,16 +740,16 @@
| Return => ()
| Switch s => Switch.foreachLabel (s, jump)
end)
- fun push (return: Label.t, size: int) =
+ fun push (return: Label.t, size: Bytes.t) =
(print "\t"
; print (move {dst = (operandToString
(Operand.StackOffset
- {offset = size - Runtime.labelSize,
+ {offset = Bytes.- (size, Runtime.labelSize),
ty = Type.label return})),
dstIsMem = true,
src = operandToString (Operand.Label return),
srcIsMem = false,
- ty = Type.Label return})
+ ty = Type.label return})
; C.push (size, print)
; if profiling
then print "\tFlushStackTop();\n"
@@ -837,7 +824,7 @@
end
| _ => ()
fun pop (fi: FrameInfo.t) =
- (C.push (~ (Program.frameSize (program, fi)), print)
+ (C.push (Bytes.~ (Program.frameSize (program, fi)), print)
; if profiling
then print "\tFlushStackTop();\n"
else ())
@@ -858,7 +845,7 @@
["\t",
move {dst = operandToString x,
dstIsMem = Operand.isMem x,
- src = creturn (Type.toCType ty),
+ src = creturn ty,
srcIsMem = false,
ty = ty}])
end)))
@@ -984,9 +971,9 @@
else ()
val _ = print "\t"
val _ =
- case returnTy of
- NONE => ()
- | SOME t => print (concat [creturn t, " = "])
+ if RepType.isUnit returnTy
+ then ()
+ else print (concat [creturn returnTy, " = "])
val _ = C.call (name, args, print)
val _ = afterCall ()
val _ =
@@ -1058,46 +1045,29 @@
#2 (Vector.sub (cases, 0)))
| (_, SOME l) => switch (cases, l)
end
- fun simple ({cases, default, size = _, test}, f) =
+ val Switch.T {cases, default, test, ...} = switch
+ fun normal () =
doit {cases = Vector.map (cases, fn (c, l) =>
- (f c, l)),
+ (WordX.toC c, l)),
default = default,
test = test}
- datatype z = datatype Switch.t
in
- case switch of
- EnumPointers {enum, pointers, test} =>
- iff (concat
- ["IsInt (", operandToString test, ")"],
- enum, pointers)
- | Int (z as {cases, default, test, ...}) =>
+ if 2 = Vector.length cases
+ andalso Option.isNone default
+ then
let
- fun normal () = simple (z, IntX.toC)
+ val (c0, l0) = Vector.sub (cases, 0)
+ val (c1, l1) = Vector.sub (cases, 1)
+ val i0 = WordX.toIntInf c0
+ val i1 = WordX.toIntInf c1
in
- if 2 = Vector.length cases
- andalso Option.isNone default
- then
- let
- val (c0, l0) = Vector.sub (cases, 0)
- val (c1, l1) = Vector.sub (cases, 1)
- in
- if IntX.isZero c0
- andalso IntX.isOne c1
- then bool (test, l1, l0)
- else if (IntX.isOne c0
- andalso IntX.isZero c1)
- then bool (test, l0, l1)
- else normal ()
- end
- else normal ()
+ if i0 = 0 andalso i1 = 1
+ then bool (test, l1, l0)
+ else if i0 = 1 andalso i1 = 0
+ then bool (test, l0, l1)
+ 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, WordX.toC)
+ else normal ()
end
end
fun declareRegisters () =
@@ -1118,7 +1088,7 @@
("StackTopOffset", GCField.StackTop)],
fn (name, f) =>
print (concat ["#define ", name, " ",
- Int.toString (GCField.offset f), "\n"]))
+ Bytes.toString (GCField.offset f), "\n"]))
in
outputIncludes (["c-chunk.h"], print)
; outputOffsets ()
1.11 +0 -1 mlton/mlton/codegen/c-codegen/c-codegen.sig
Index: c-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.sig,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- c-codegen.sig 18 Mar 2004 03:22:23 -0000 1.10
+++ c-codegen.sig 4 Apr 2004 06:50:18 -0000 1.11
@@ -9,7 +9,6 @@
sig
structure Ffi: FFI
structure Machine: MACHINE
- sharing Machine.CType = Machine.Prim.CFunction.CType
sharing Ffi.CFunction = Machine.CFunction
end
1.5 +0 -2 mlton/mlton/codegen/c-codegen/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/sources.cm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- sources.cm 24 Jun 2003 20:14:22 -0000 1.4
+++ sources.cm 4 Apr 2004 06:50:18 -0000 1.5
@@ -19,5 +19,3 @@
c-codegen.sig
c-codegen.fun
-
-
1.8 +15 -15 mlton/mlton/codegen/x86-codegen/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/sources.cm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- sources.cm 6 Jul 2002 17:22:06 -0000 1.7
+++ sources.cm 4 Apr 2004 06:50:19 -0000 1.8
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -17,34 +17,34 @@
../../backend/sources.cm
../c-codegen/sources.cm
-x86-codegen.sig
+peephole.sig
+peephole.fun
x86.sig
x86.fun
x86-pseudo.sig
-x86-mlton-basic.fun
x86-mlton-basic.sig
+x86-mlton-basic.fun
x86-liveness.sig
x86-liveness.fun
-x86-jump-info.sig
-x86-jump-info.fun
-x86-entry-transfer.sig
-x86-entry-transfer.fun
x86-mlton.sig
x86-mlton.fun
-x86-translate.sig
-x86-translate.fun
-peephole.sig
-peephole.fun
-x86-simplify.sig
-x86-simplify.fun
+x86-allocate-registers.sig
+x86-allocate-registers.fun
+x86-entry-transfer.sig
+x86-entry-transfer.fun
+x86-jump-info.sig
+x86-jump-info.fun
x86-loop-info.sig
x86-loop-info.fun
x86-live-transfers.sig
x86-live-transfers.fun
x86-generate-transfers.sig
x86-generate-transfers.fun
-x86-allocate-registers.sig
-x86-allocate-registers.fun
+x86-simplify.sig
+x86-simplify.fun
+x86-translate.sig
+x86-translate.fun
x86-validate.sig
x86-validate.fun
+x86-codegen.sig
x86-codegen.fun
1.52 +30 -33 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.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- x86-codegen.fun 24 Feb 2004 02:28:04 -0000 1.51
+++ x86-codegen.fun 4 Apr 2004 06:50:19 -0000 1.52
@@ -1,68 +1,64 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor x86Codegen(S: X86_CODEGEN_STRUCTS): X86_CODEGEN =
+functor x86Codegen (S: X86_CODEGEN_STRUCTS): X86_CODEGEN =
struct
open S
structure CType = Machine.CType
- structure x86
- = x86 (structure CFunction = Machine.CFunction
- structure Label = Machine.Label
- structure ProfileLabel = Machine.ProfileLabel
- structure Runtime = Machine.Runtime)
+ structure x86 = x86 (Machine)
structure x86MLtonBasic
- = x86MLtonBasic(structure x86 = x86
- structure Machine = Machine)
+ = x86MLtonBasic (structure x86 = x86
+ structure Machine = Machine)
structure x86Liveness
- = x86Liveness(structure x86 = x86
- structure x86MLtonBasic = x86MLtonBasic)
+ = x86Liveness (structure x86 = x86
+ structure x86MLtonBasic = x86MLtonBasic)
structure x86JumpInfo
- = x86JumpInfo(structure x86 = x86)
+ = x86JumpInfo (structure x86 = x86)
structure x86LoopInfo
- = x86LoopInfo(structure x86 = x86)
+ = x86LoopInfo (structure x86 = x86)
structure x86EntryTransfer
- = x86EntryTransfer(structure x86 = x86)
+ = x86EntryTransfer (structure x86 = x86)
structure x86MLton
- = x86MLton(structure x86MLtonBasic = x86MLtonBasic
- structure x86Liveness = x86Liveness)
+ = x86MLton (structure x86MLtonBasic = x86MLtonBasic
+ structure x86Liveness = x86Liveness)
structure x86Translate
- = x86Translate(structure x86 = x86
- structure x86MLton = x86MLton
- structure x86Liveness = x86Liveness)
+ = x86Translate (structure x86 = x86
+ structure x86MLton = x86MLton
+ structure x86Liveness = x86Liveness)
structure x86Simplify
- = x86Simplify(structure x86 = x86
- structure x86Liveness = x86Liveness
- structure x86JumpInfo = x86JumpInfo
- structure x86EntryTransfer = x86EntryTransfer)
+ = x86Simplify (structure x86 = x86
+ structure x86Liveness = x86Liveness
+ structure x86JumpInfo = x86JumpInfo
+ structure x86EntryTransfer = x86EntryTransfer)
structure x86GenerateTransfers
- = x86GenerateTransfers(structure x86 = x86
- structure x86MLton = x86MLton
- structure x86Liveness = x86Liveness
- structure x86JumpInfo = x86JumpInfo
- structure x86LoopInfo = x86LoopInfo
- structure x86EntryTransfer = x86EntryTransfer)
+ = x86GenerateTransfers (structure x86 = x86
+ structure x86MLton = x86MLton
+ structure x86Liveness = x86Liveness
+ structure x86JumpInfo = x86JumpInfo
+ structure x86LoopInfo = x86LoopInfo
+ structure x86EntryTransfer = x86EntryTransfer)
structure x86AllocateRegisters
- = x86AllocateRegisters(structure x86 = x86
- structure x86MLton = x86MLton)
+ = x86AllocateRegisters (structure x86 = x86
+ structure x86MLton = x86MLton)
structure x86Validate
- = x86Validate(structure x86 = x86)
+ = x86Validate (structure x86 = x86)
structure C =
struct
@@ -193,7 +189,8 @@
fun frameInfoToX86 (Machine.FrameInfo.T {frameLayoutsIndex, ...}) =
x86.FrameInfo.T
{frameLayoutsIndex = frameLayoutsIndex,
- size = #size (Vector.sub (frameLayouts, frameLayoutsIndex))}
+ size = Bytes.toInt (#size (Vector.sub (frameLayouts,
+ frameLayoutsIndex)))}
fun outputChunk (chunk as Machine.Chunk.T {blocks, chunkLabel, ...},
print)
1.10 +1 -1 mlton/mlton/codegen/x86-codegen/x86-codegen.sig
Index: x86-codegen.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-codegen.sig,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- x86-codegen.sig 18 Mar 2004 10:31:47 -0000 1.9
+++ x86-codegen.sig 4 Apr 2004 06:50:19 -0000 1.10
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.47 +9 -13 mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun
Index: x86-generate-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-generate-transfers.fun,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- x86-generate-transfers.fun 24 Feb 2004 02:28:04 -0000 1.46
+++ x86-generate-transfers.fun 4 Apr 2004 06:50:19 -0000 1.47
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -505,12 +505,11 @@
then AppendList.empty
else let
val srcs =
- case CFunction.return func of
- NONE => Vector.new0 ()
- | SOME ty =>
- (Vector.fromList o List.map)
- (Operand.cReturnTemps ty,
- fn {dst,...} => dst)
+ Vector.fromList
+ (List.map
+ (Operand.cReturnTemps
+ (CFunction.return func),
+ #dst))
in
(AppendList.fromList o Vector.fold2)
(dsts, srcs, [], fn ((dst,dstsize),src,stmts) =>
@@ -1282,12 +1281,9 @@
end,
dead_classes = ccallflushClasses})
val getResult =
- case returnTy of
- NONE => AppendList.empty
- | SOME ty =>
- AppendList.single
- (Assembly.directive_return
- {returns = Operand.cReturnTemps ty})
+ AppendList.single
+ (Assembly.directive_return
+ {returns = Operand.cReturnTemps returnTy})
val fixCStack =
if size_args > 0
andalso convention = CFunction.Convention.Cdecl
1.16 +26 -15 mlton/mlton/codegen/x86-codegen/x86-live-transfers.fun
Index: x86-live-transfers.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-live-transfers.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- x86-live-transfers.fun 24 Feb 2004 02:28:04 -0000 1.15
+++ x86-live-transfers.fun 4 Apr 2004 06:50:19 -0000 1.16
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -24,6 +24,12 @@
structure CFunction = CFunction
end
+ local
+ open CFunction
+ in
+ structure RepType = RepType
+ end
+
structure LiveSet = x86Liveness.LiveSet
structure LiveInfo = x86Liveness.LiveInfo
open x86JumpInfo
@@ -845,20 +851,25 @@
liveFltRegsTransfers)}
fun doit'' label = enque {label = label,
hints = ([],[])}
- fun doit''' func label
- = enque {label = label,
- hints = case CFunction.return func of
- NONE => ([],[])
- | SOME ty =>
- List.fold
- (Operand.cReturnTemps ty,
- ([],[]), fn ({src, dst}, (regHints, fltregHints)) =>
- case src of
- Operand.Register reg =>
- ((dst, reg, ref true)::regHints, fltregHints)
- | Operand.FltRegister _ =>
- (regHints, (dst, ref true)::fltregHints)
- | _ => (regHints, fltregHints))}
+ fun doit''' func label =
+ let
+ val hints =
+ List.fold
+ (Operand.cReturnTemps (CFunction.return func),
+ ([],[]),
+ fn ({src, dst}, (regHints, fltregHints)) =>
+ case src of
+ Operand.Register reg =>
+ ((dst, reg, ref true) :: regHints,
+ fltregHints)
+ | Operand.FltRegister _ =>
+ (regHints,
+ (dst, ref true) :: fltregHints)
+ | _ => (regHints, fltregHints))
+ in
+ enque {hints = hints,
+ label = label}
+ end
datatype z = datatype Transfer.t
in
case transfer
1.28 +41 -45 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.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- x86-mlton-basic.fun 3 Mar 2004 02:09:05 -0000 1.27
+++ x86-mlton-basic.fun 4 Apr 2004 06:50:19 -0000 1.28
@@ -11,29 +11,26 @@
open S
open x86
- structure Runtime = Machine.Runtime
- structure CFunction = Machine.CFunction
- structure CType = CFunction.CType
local
- open CType
+ open Machine
in
- structure IntSize = IntSize
- structure RealSize = RealSize
- structure WordSize = WordSize
+ structure CFunction = CFunction
+ structure CType = CType
+ structure Runtime = Runtime
end
(*
* x86.Size.t equivalents
*)
- val wordBytes = Runtime.wordSize
+ val wordBytes = Bytes.toInt Bytes.inWord
val wordSize = Size.fromBytes wordBytes
val wordScale = Scale.fromBytes wordBytes
- val pointerBytes = Runtime.pointerSize
+ val pointerBytes = Bytes.toInt Runtime.pointerSize
val pointerSize = Size.fromBytes pointerBytes
val pointerScale = Scale.fromBytes pointerBytes
- val normalHeaderBytes = Runtime.normalHeaderSize
- val arrayHeaderBytes = Runtime.arrayHeaderSize
- val intInfOverheadBytes = Runtime.intInfOverheadSize
+ val normalHeaderBytes = Bytes.toInt Runtime.normalHeaderSize
+ val arrayHeaderBytes = Bytes.toInt Runtime.arrayHeaderSize
+ val intInfOverheadBytes = Bytes.toInt Runtime.intInfOverhead
(*
* Memory classes
@@ -304,44 +301,43 @@
local
- val localI_base =
- IntSize.memoize
- (fn s => Label.fromString (concat ["localInt", IntSize.toString s]))
- val localP_base = Label.fromString "localPointer"
- val localR_base =
- RealSize.memoize
- (fn s => Label.fromString (concat ["localReal", RealSize.toString s]))
- val localW_base =
- WordSize.memoize
- (fn s => Label.fromString (concat ["localWord", WordSize.toString s]))
- datatype z = datatype CType.t
+ fun make name size =
+ Label.fromString (concat ["local", name, size])
+ val r = make "Real"
+ val w = make "Word"
+ datatype z = datatype CType.t
in
- fun local_base ty =
- case ty of
- Int s => localI_base s
- | Pointer => localP_base
- | Real s => localR_base s
- | Word s => localW_base s
+ val local_base =
+ CType.memo
+ (fn t =>
+ case t of
+ Pointer => Label.fromString "localPointer"
+ | Real32 => r "32"
+ | Real64 => r "64"
+ | Word8 => w "8"
+ | Word16 => w "16"
+ | Word32 => w "32"
+ | Word64 => w "64")
end
local
- fun make (name, memo, toString) =
- memo (fn s => Label.fromString (concat ["global", name, toString s]))
- val globalI_base =
- make ("Int", IntSize.memoize, IntSize.toString)
- val globalP_base = Label.fromString "globalPointer"
- val globalR_base =
- make ("Real", RealSize.memoize, RealSize.toString)
- val globalW_base =
- make ("Word", WordSize.memoize, WordSize.toString)
+ fun make name size =
+ Label.fromString (concat ["global", name, size])
+ val r = make "Real"
+ val w = make "Word"
datatype z = datatype CType.t
in
- fun global_base ty =
- case ty of
- Int s => globalI_base s
- | Pointer => globalP_base
- | Real s => globalR_base s
- | Word s => globalW_base s
+ val global_base =
+ CType.memo
+ (fn t =>
+ case t of
+ Pointer => Label.fromString "globalPointer"
+ | Real32 => r "32"
+ | Real64 => r "64"
+ | Word8 => w "8"
+ | Word16 => w "16"
+ | Word32 => w "32"
+ | Word64 => w "64")
end
val globalPointerNonRoot_base = Label.fromString "globalPointerNonRoot"
@@ -400,7 +396,7 @@
Immediate.binexp
{oper = Immediate.Addition,
exp1 = Immediate.label gcState_label,
- exp2 = Immediate.const_int (Field.offset f)}
+ exp2 = Immediate.const_int (Bytes.toInt (Field.offset f))}
fun contents () =
makeContents {base = imm (),
size = size,
1.29 +3 -3 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.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- x86-mlton-basic.sig 18 Mar 2004 03:22:24 -0000 1.28
+++ x86-mlton-basic.sig 4 Apr 2004 06:50:19 -0000 1.29
@@ -88,8 +88,8 @@
val eq2TempContentsOperand : x86.Operand.t
(* Static arrays defined in main.h and x86-main.h *)
- val local_base : x86.CFunction.CType.t -> x86.Label.t
- val global_base : x86.CFunction.CType.t -> x86.Label.t
+ val local_base : x86.CType.t -> x86.Label.t
+ val global_base : x86.CType.t -> x86.Label.t
val globalPointerNonRoot_base : x86.Label.t
(* Static functions defined in main.h *)
@@ -103,7 +103,7 @@
(* gcState relative locations defined in gc.h *)
val gcState_label: x86.Label.t
- val gcState_offset: {offset: int, ty: x86.CFunction.CType.t} -> x86.Operand.t
+ val gcState_offset: {offset: int, ty: x86.CType.t} -> x86.Operand.t
val gcState_exnStackContents: unit -> x86.MemLoc.t
val gcState_exnStackContentsOperand: unit -> x86.Operand.t
val gcState_frontierContents: unit -> x86.MemLoc.t
1.22 +5 -4 mlton/mlton/codegen/x86-codegen/x86-pseudo.sig
Index: x86-pseudo.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86-pseudo.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- x86-pseudo.sig 5 Feb 2004 06:11:41 -0000 1.21
+++ x86-pseudo.sig 4 Apr 2004 06:50:19 -0000 1.22
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -11,9 +11,10 @@
signature X86_PSEUDO =
sig
structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
structure Label: ID
structure Runtime: RUNTIME
- sharing CFunction.CType = Runtime.CType
+ sharing CType = CFunction.RepType.CType
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
@@ -29,7 +30,7 @@
| FPIS | FPIL | FPIQ
val fromBytes : int -> t
val toBytes : t -> int
- val fromCType : CFunction.CType.t -> t vector
+ val fromCType : CType.t -> t vector
val class : t -> class
val eq : t * t -> bool
val lt : t * t -> bool
@@ -75,7 +76,7 @@
sig
datatype t = One | Two | Four | Eight
val fromBytes : int -> t
- val fromCType : CFunction.CType.t -> t
+ val fromCType : CType.t -> t
end
structure MemLoc :
1.55 +15 -62 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.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- x86-translate.fun 18 Mar 2004 03:22:24 -0000 1.54
+++ x86-translate.fun 4 Apr 2004 06:50:19 -0000 1.55
@@ -248,6 +248,7 @@
Vector.new1 (x86MLton.fileLine (), x86MLton.wordSize)
| Offset {base = GCState, offset, ty} =>
let
+ val offset = Bytes.toInt offset
val ty = Type.toCType ty
val offset = x86MLton.gcState_offset {offset = offset, ty = ty}
in
@@ -255,6 +256,7 @@
end
| Offset {base, offset, ty} =>
let
+ val offset = Bytes.toInt offset
val ty = Type.toCType ty
val base = toX86Operand base
val _ = Assert.assert("x86Translate.Operand.toX86Operand: Contents/base",
@@ -309,6 +311,7 @@
Vector.new1 (x86.Operand.immediate_const_word ii,x86.Size.LONG)
| StackOffset {offset, ty} =>
let
+ val offset = Bytes.toInt offset
val ty = Type.toCType ty
val origin =
x86.MemLoc.simple
@@ -557,6 +560,7 @@
fun stores_toX86Assembly ({offset, value}, l)
= let
+ val offset = Bytes.toInt offset
val origin =
x86.MemLoc.simple
{base = dst',
@@ -613,7 +617,8 @@
x86.Assembly.instruction_binal
{oper = x86.Instruction.ADD,
dst = frontier,
- src = x86.Operand.immediate_const_int size,
+ src = x86.Operand.immediate_const_int
+ (Bytes.toInt size),
size = x86MLton.pointerSize}],
stores_toX86Assembly)),
transfer = NONE}),
@@ -826,67 +831,15 @@
(x86.MemLocSet.empty,
x86MLton.gcState_stackBottomContents ()),
x86MLton.gcState_exnStackContents ())})}))
- | Switch switch
+ | Switch (Machine.Switch.T {cases, default, test, ...})
=> 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
- EnumPointers {enum, pointers, test} =>
- let
- val (test,testsize) =
- Vector.sub(Operand.toX86Operand test, 0)
- in
- AppendList.append
- (comments transfer,
- AppendList.single
- ((* if (test & 0x3) goto int
- * goto pointer
- *)
- x86.Block.mkBlock'
- {entry = NONE,
- statements
- = [x86.Assembly.instruction_test
- {src1 = test,
- src2 = x86.Operand.immediate_const_word 0wx3,
- size = testsize}],
- transfer
- = SOME (x86.Transfer.iff
- {condition = x86.Instruction.NZ,
- truee = enum,
- falsee = pointers})}))
- end
- | Int {cases, default, size, test} =>
- (Assert.assert("x86Translate.Transfer.toX86Blocks: Switch/Int",
- fn () =>
- not (IntSize.equals
- (size, IntSize.I 64)))
- ; simple ({cases = (Vector.map
- (cases, fn (i, l) =>
- (IntX.toInt i, l))),
- default = default,
- test = test},
- doSwitchInt))
- | Pointer {cases, default, tag, ...} =>
- simple ({cases = (Vector.map
- (cases, fn {dst, tag, ...} =>
- (tag, dst))),
- default = default,
- test = tag},
- doSwitchInt)
- | Word {cases, default, test, ...} =>
- simple ({cases = (Vector.map
- (cases, fn (w, l) =>
- (Word.fromIntInf
- (WordX.toIntInf w),
- l))),
- default = default,
- test = test},
- doSwitchWord)
+ val cases =
+ Vector.toListMap (cases, fn (w, l) =>
+ (Word.fromIntInf (WordX.toIntInf w), l))
+ in
+ AppendList.append
+ (comments transfer,
+ doSwitchWord (test, cases, default))
end
| Goto label
=> (AppendList.append
@@ -917,7 +870,7 @@
live = live,
return = return,
handler = handler,
- size = size}
+ size = Bytes.toInt size}
in
AppendList.append
(com,
1.51 +44 -124 mlton/mlton/codegen/x86-codegen/x86.fun
Index: x86.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/x86-codegen/x86.fun,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- x86.fun 5 Mar 2004 03:50:54 -0000 1.50
+++ x86.fun 4 Apr 2004 06:50:19 -0000 1.51
@@ -1,14 +1,14 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-functor x86(S: X86_STRUCTS): X86 =
+functor x86 (S: X86_STRUCTS): X86 =
struct
- val tracerTop
+ val tracerTop
= fn s => Control.traceBatch (Control.Pass, s)
(*
= fn s => fn f => (Control.trace (Control.Pass, s) f, fn () => ())
@@ -43,20 +43,8 @@
open S
- local
- open Runtime
- in
- structure CFunction = CFunction
- end
- structure CType = CFunction.CType
- local
- open CType
- in
- structure IntSize = IntSize
- structure RealSize = RealSize
- structure WordSize = WordSize
- end
-
+ structure RepType = CFunction.RepType
+
structure Label =
struct
open Label
@@ -140,33 +128,13 @@
in
fun fromCType t =
case t of
- Int s =>
- let
- datatype z = datatype IntSize.prim
- in
- case IntSize.prim s of
- I8 => Vector.new1 BYTE
- | I16 => Vector.new1 WORD
- | I32 => Vector.new1 LONG
- | I64 => Vector.new2 (LONG, LONG)
- end
- | Pointer => Vector.new1 LONG
- | Real s =>
- let datatype z = datatype RealSize.t
- in case s of
- R32 => Vector.new1 SNGL
- | R64 => Vector.new1 DBLE
- end
- | Word s =>
- let
- datatype z = datatype WordSize.prim
- in
- case WordSize.prim s of
- W8 => Vector.new1 BYTE
- | W16 => Vector.new1 WORD
- | W32 => Vector.new1 LONG
- | W64 => Vector.new2 (LONG, LONG)
- end
+ Pointer => Vector.new1 LONG
+ | Real32 => Vector.new1 SNGL
+ | Real64 => Vector.new1 DBLE
+ | Word8 => Vector.new1 BYTE
+ | Word16 => Vector.new1 WORD
+ | Word32 => Vector.new1 LONG
+ | Word64 => Vector.new2 (LONG, LONG)
end
val class
@@ -701,33 +669,13 @@
in
fun fromCType t =
case t of
- Int s =>
- let
- datatype z = datatype IntSize.prim
- in
- case IntSize.prim s of
- I8 => One
- | I16 => Two
- | I32 => Four
- | I64 => Eight
- end
- | Pointer => Four
- | Real s =>
- let datatype z = datatype RealSize.t
- in case s of
- R32 => Four
- | R64 => Eight
- end
- | Word s =>
- let
- datatype z = datatype WordSize.prim
- in
- case WordSize.prim s of
- W8 => One
- | W16 => Two
- | W32 => Four
- | W64 => Eight
- end
+ Pointer => Four
+ | Real32 => Four
+ | Real64 => Eight
+ | Word8 => One
+ | Word16 => Two
+ | Word32 => Four
+ | Word64 => Eight
end
fun eq(s1, s2) = s1 = s2
@@ -1445,46 +1393,26 @@
datatype z = datatype Size.t
in
fun cReturnTemps ty =
- case ty of
- Int s => let
- datatype z = datatype IntSize.prim
- in
- case IntSize.prim s of
- I8 => [{src = register Register.al,
- dst = cReturnTempContent (0, BYTE)}]
- | I16 => [{src = register Register.ax,
- dst = cReturnTempContent (0, WORD)}]
- | I32 => [{src = register Register.eax,
- dst = cReturnTempContent (0, LONG)}]
- | I64 => [{src = register Register.eax,
- dst = cReturnTempContent (0, LONG)},
- {src = register Register.edx,
- dst = cReturnTempContent (4, LONG)}]
- end
- | Pointer => [{src = register Register.eax,
- dst = cReturnTempContent (0, LONG)}]
- | Real s => let datatype z = datatype RealSize.t
- in case s of
- R32 => [{src = fltregister FltRegister.top,
- dst = cReturnTempContent (0, SNGL)}]
- | R64 => [{src = fltregister FltRegister.top,
- dst = cReturnTempContent (0, DBLE)}]
- end
- | Word s => let
- datatype z = datatype WordSize.prim
- in
- case WordSize.prim s of
- W8 => [{src = register Register.al,
- dst = cReturnTempContent (0, BYTE)}]
- | W16 => [{src = register Register.ax,
- dst = cReturnTempContent (0, WORD)}]
- | W32 => [{src = register Register.eax,
- dst = cReturnTempContent (0, LONG)}]
- | W64 => [{src = register Register.eax,
- dst = cReturnTempContent (0, LONG)},
- {src = register Register.edx,
- dst = cReturnTempContent (4, LONG)}]
- end
+ if RepType.isUnit ty
+ then []
+ else
+ case RepType.toCType ty of
+ Pointer => [{src = register Register.eax,
+ dst = cReturnTempContent (0, LONG)}]
+ | Real32 => [{src = fltregister FltRegister.top,
+ dst = cReturnTempContent (0, SNGL)}]
+ | Real64 => [{src = fltregister FltRegister.top,
+ dst = cReturnTempContent (0, DBLE)}]
+ | Word8 => [{src = register Register.al,
+ dst = cReturnTempContent (0, BYTE)}]
+ | Word16 => [{src = register Register.ax,
+ dst = cReturnTempContent (0, WORD)}]
+ | Word32 => [{src = register Register.eax,
+ dst = cReturnTempContent (0, LONG)}]
+ | Word64 => [{src = register Register.eax,
+ dst = cReturnTempContent (0, LONG)},
+ {src = register Register.edx,
+ dst = cReturnTempContent (4, LONG)}]
end
end
@@ -3848,14 +3776,10 @@
val uses_defs_kills
= fn CReturn {dsts, func, ...}
- => let
+ => let
val uses =
- case CFunction.return func of
- NONE => []
- | SOME ty =>
- List.map
- (Operand.cReturnTemps ty,
- fn {dst, ...} => Operand.memloc dst)
+ List.map (Operand.cReturnTemps (CFunction.return func),
+ fn {dst, ...} => Operand.memloc dst)
in
{uses = uses,
defs = Vector.toListMap(dsts, fn (dst, _) => dst),
@@ -4152,12 +4076,8 @@
| CCall {args, func, ...}
=> let
val defs =
- case CFunction.return func of
- NONE => []
- | SOME ty =>
- List.map
- (Operand.cReturnTemps ty,
- fn {dst, ...} => Operand.memloc dst)
+ List.map (Operand.cReturnTemps (CFunction.return func),
+ fn {dst, ...} => Operand.memloc dst)
in
{uses = List.map(args, fn (oper,_) => oper),
defs = defs, kills = []}
1.31 +8 -6 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.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- x86.sig 5 Feb 2004 06:11:42 -0000 1.30
+++ x86.sig 4 Apr 2004 06:50:19 -0000 1.31
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -11,10 +11,11 @@
signature X86_STRUCTS =
sig
structure CFunction: C_FUNCTION
+ structure CType: C_TYPE
structure Label: ID
structure ProfileLabel: PROFILE_LABEL
structure Runtime: RUNTIME
- sharing CFunction.CType = Runtime.CType
+ sharing CType = CFunction.RepType.CType
end
signature X86 =
@@ -22,7 +23,8 @@
structure CFunction: C_FUNCTION
structure Label: ID
structure Runtime: RUNTIME
- sharing CFunction.CType = Runtime.CType
+ structure CType: C_TYPE
+ sharing CType = CFunction.RepType.CType
val tracer : string -> ('a -> 'b) ->
(('a -> 'b) * (unit -> unit))
@@ -43,7 +45,7 @@
val toString' : t -> string
val fromBytes : int -> t
val toBytes : t -> int
- val fromCType : CFunction.CType.t -> t vector
+ val fromCType : CType.t -> t vector
val class : t -> class
val toFPI : t -> t
val eq : t * t -> bool
@@ -172,7 +174,7 @@
val eq : t * t -> bool
val toImmediate : t -> Immediate.t
val fromBytes : int -> t
- val fromCType : CFunction.CType.t -> t
+ val fromCType : CType.t -> t
end
structure Address :
@@ -305,7 +307,7 @@
val size : t -> Size.t option
val eq : t * t -> bool
- val cReturnTemps: CFunction.CType.t -> {src: t, dst: MemLoc.t} list
+ val cReturnTemps: CFunction.RepType.t -> {src: t, dst: MemLoc.t} list
end
structure Instruction :
1.6 +11 -7 mlton/mlton/control/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm 9 Oct 2003 18:17:32 -0000 1.5
+++ sources.cm 4 Apr 2004 06:50:20 -0000 1.6
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -9,26 +9,30 @@
signature REGION
+structure Bits
+structure Bytes
structure Control
structure Pretty
structure Region
structure Source
structure SourcePos
structure System
+structure Words
is
../../lib/mlton/sources.cm
-control.sig
-control.sml
-pretty.sig
-pretty.sml
-region.sig
-region.sml
+bits.sml
source-pos.sig
source-pos.sml
+region.sig
+region.sml
source.sig
source.sml
+control.sig
+control.sml
system.sig
system.sml
+pretty.sig
+pretty.sml
1.1 mlton/mlton/control/bits.sml
Index: bits.sml
===================================================================
(* Copyright (C) 2004 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.
*)
local
type int = Int.t
type word = Word.t
structure All:>
sig
type bytes
type words
structure Bits:
sig
eqtype t
val + : t * t -> t
val - : t * t -> t
val < : t * t -> bool
val <= : t * t -> bool
val > : t * t -> bool
val >= : t * t -> bool
val compare: t * t -> Relation.t
val equals: t * t -> bool
val fromInt: int -> t
val fromIntInf: IntInf.t -> t
val fromWord: word -> t
val inByte: t
val inPointer: t
val inWord: t
val isByteAligned: t -> bool
val isWordAligned: t -> bool
val isZero: t -> bool
val layout: t -> Layout.t
val toBytes: t -> bytes
val toInt: t -> int
val toIntInf: t -> IntInf.t
val toString: t -> string
val toWord: t -> word
val zero: t
end
structure Bytes:
sig
type t
val + : t * t -> t
val - : t * t -> t
val ~ : t -> t
val < : t * t -> bool
val <= : t * t -> bool
val > : t * t -> bool
val >= : t * t -> bool
val align: t * {alignment: t} -> t
val equals: t * t -> bool
val fromInt: int -> t
val fromIntInf: IntInf.t -> t
val fromWord: word -> t
val inPointer: t
val inWord: t
val isWordAligned: t -> bool
val isZero: t -> bool
val layout: t -> Layout.t
val max: t * t -> t
val scale: t * int -> t
val toBits: t -> Bits.t
val toInt: t -> int
val toIntInf: t -> IntInf.t
val toString: t -> string
val toWord: t -> word
val toWords: t -> words
val wordAlign: t -> t
val zero: t
end
structure Words:
sig
type t
val layout: t -> Layout.t
val toInt: t -> int
val toBytes: t -> Bytes.t
end
sharing type bytes = Bytes.t
sharing type words = Words.t
end =
struct
val rem = IntInf.rem
fun align (b, {alignment = a}) =
let
val b = b + (a - 1)
in
b - rem (b, a)
end
structure Bits =
struct
open IntInf
val fromWord = Word.toIntInf
val inByte: t = 8
val inWord: t = 32
val inPointer = inWord
fun isByteAligned b = 0 = rem (b, inByte)
fun isWordAligned b = 0 = rem (b, inWord)
fun toBytes b =
if isByteAligned b
then quot (b, inByte)
else Error.bug "Bits.toBytes"
val toWord = Word.fromIntInf
end
structure Bytes =
struct
open IntInf
val fromWord = Word.toIntInf
val inWord: t = 4
val inPointer = inWord
fun isWordAligned b = 0 = rem (b, inWord)
fun scale (b, i) = b * Int.toIntInf i
fun toBits b = b * Bits.inByte
val toWord = Word.fromIntInf
fun toWords b =
if isWordAligned b
then quot (b, inWord)
else Error.bug "Bytes.toWords"
val align = align
fun wordAlign b = align (b, {alignment = inWord})
end
type bytes = Bytes.t
structure Words =
struct
open IntInf
fun toBytes w = w * Bytes.inWord
end
type words = Words.t
end
open All
in
structure Bits = Bits
structure Bytes = Bytes
structure Words = Words
end
1.6 +2 -2 mlton/mlton/core-ml/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/core-ml/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm 13 Oct 2003 22:15:12 -0000 1.5
+++ sources.cm 4 Apr 2004 06:50:20 -0000 1.6
@@ -18,7 +18,7 @@
../control/sources.cm
../../lib/mlton/sources.cm
-core-ml.fun
core-ml.sig
-dead-code.fun
+core-ml.fun
dead-code.sig
+dead-code.fun
1.2 +1 -1 mlton/mlton/defunctorize/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/defunctorize/sources.cm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- sources.cm 9 Oct 2003 18:17:33 -0000 1.1
+++ sources.cm 4 Apr 2004 06:50:20 -0000 1.2
@@ -10,5 +10,5 @@
../match-compile/sources.cm
../xml/sources.cm
-defunctorize.fun
defunctorize.sig
+defunctorize.fun
1.96 +36 -29 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.95
retrieving revision 1.96
diff -u -r1.95 -r1.96
--- elaborate-core.fun 18 Mar 2004 04:07:05 -0000 1.95
+++ elaborate-core.fun 4 Apr 2004 06:50:20 -0000 1.96
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -62,6 +62,7 @@
open CoreML
in
structure CFunction = CFunction
+ structure CType = CType
structure Convention = CFunction.Convention
structure Con = Con
structure Const = Const
@@ -226,7 +227,7 @@
Aconst.Bool b => if b then t else f
| Aconst.Char c =>
now (Const.Word (WordX.fromIntInf (IntInf.fromInt (Char.toInt c),
- WordSize.W 8)),
+ WordSize.byte)),
Type.char)
| Aconst.Int i =>
let
@@ -386,9 +387,9 @@
seq [str "variable ",
Avar.layout x,
str " occurs in multiple patterns"],
- align [seq [str "pattern: ",
+ align [seq [str "in: ",
approximate (Apat.layout p)],
- seq [str "pattern: ",
+ seq [str "and in: ",
approximate (Apat.layout p')]])
end
@@ -438,7 +439,7 @@
fn _ =>
(region,
str "constant constructor applied to argument",
- seq [str "pattern: ", lay ()]))
+ seq [str "in: ", lay ()]))
val _ =
unify
(Cpat.ty p, argType, fn (l, l') =>
@@ -446,7 +447,7 @@
str "constructor applied to incorrect argument",
align [seq [str "expects: ", l'],
seq [str "but got: ", l],
- seq [str "pattern: ", lay ()]]))
+ seq [str "in: ", lay ()]]))
in
Cpat.make (Cpat.Con {arg = SOME p,
con = con,
@@ -471,7 +472,7 @@
end
| Apat.FlatApp items =>
loop (Parse.parsePat
- (items, E, fn () => seq [str "pattern: ", lay ()]))
+ (items, E, fn () => seq [str "in: ", lay ()]))
| Apat.Layered {var = x, constraint, pat, ...} =>
let
val t =
@@ -496,7 +497,7 @@
(Vector.map2 (ps, ps', fn (p, p') =>
(Cpat.ty p', Apat.region p)),
preError,
- fn () => seq [str "pattern: ", lay ()]))
+ fn () => seq [str "in: ", lay ()]))
end
| Apat.Record {flexible, items} =>
(* rules 36, 38, 39 and Appendix A, p.57 *)
@@ -540,7 +541,7 @@
Control.error
(region,
str "unresolved ... in record pattern",
- seq [str "pattern: ", lay ()])
+ seq [str "in: ", lay ()])
val _ = List.push (overloads, (Priority.default, resolve))
in
t
@@ -627,9 +628,9 @@
val info = Trace.info "elaborateDec"
val elabExpInfo = Trace.info "elaborateExp"
-structure CType =
+structure RepType =
struct
- open CoreML.CType
+ open CoreML.RepType
fun sized (all: 'a list,
toString: 'a -> string,
@@ -642,12 +643,14 @@
val nullary: (t * string * Tycon.t) list =
[(bool, "Bool", Tycon.bool),
(char, "Char", Tycon.char),
- (pointer, "Pointer", Tycon.pointer),
- (pointer, "Pointer", Tycon.preThread),
- (pointer, "Pointer", Tycon.thread)]
- @ sized (IntSize.all, IntSize.toString, "Int", Int, Tycon.int)
- @ sized (RealSize.all, RealSize.toString, "Real", Real, Tycon.real)
- @ sized (WordSize.all, WordSize.toString, "Word", Word, Tycon.word)
+ (cPointer (), "Pointer", Tycon.pointer),
+ (thread, "Pointer", Tycon.preThread),
+ (thread, "Pointer", Tycon.thread)]
+ @ sized (IntSize.all, IntSize.toString, "Int", int, Tycon.int)
+ @ sized (RealSize.all, RealSize.toString, "Real", real, Tycon.real)
+ @ sized (WordSize.all, WordSize.toString, "Word",
+ word o WordSize.bits,
+ Tycon.word)
val unary: Tycon.t list =
[Tycon.array, Tycon.reff, Tycon.vector]
@@ -661,12 +664,12 @@
if List.exists (unary, fn c' => Tycon.equals (c, c'))
andalso 1 = Vector.length ts
andalso isSome (fromType (Vector.sub (ts, 0)))
- then SOME (Pointer, "Pointer")
+ then SOME (cPointer (), "Pointer")
else NONE
| SOME (t, s, _) => SOME (t, s)
val fromType =
- Trace.trace ("Ctype.fromType",
+ Trace.trace ("RepType.fromType",
Type.layoutPretty,
Option.layout (Layout.tuple2 (layout, String.layout)))
fromType
@@ -723,9 +726,9 @@
error (seq [str "invalid attributes for import: ",
List.layout Attribute.layout attributes])
in
- case CType.parse ty of
+ case RepType.parse ty of
NONE =>
- (case CType.fromType ty of
+ (case RepType.fromType ty of
NONE =>
let
val _ =
@@ -762,7 +765,9 @@
mayGC = true,
maySwitchThreads = false,
name = name,
- return = Option.map (result, #1)}
+ return = (case result of
+ NONE => RepType.unit
+ | SOME (t, _) => t)}
in
Prim.ffi func
end
@@ -780,7 +785,7 @@
; Convention.Cdecl)
| SOME c => c
val (exportId, args, res) =
- case CType.parse ty of
+ case RepType.parse ty of
NONE =>
(Control.error
(region,
@@ -790,10 +795,11 @@
; (0, Vector.new0 (), NONE))
| SOME (us, t) =>
let
- val id = Ffi.addExport {args = Vector.map (us, #1),
- convention = convention,
- name = name,
- res = Option.map (t, #1)}
+ val id =
+ Ffi.addExport {args = Vector.map (us, RepType.toCType o #1),
+ convention = convention,
+ name = name,
+ res = Option.map (t, RepType.toCType o #1)}
in
(id, us, t)
end
@@ -825,6 +831,7 @@
(Vector.map
(args, fn (u, name) =>
let
+ val u = RepType.toCType u
val x =
Var.fromSymbol
(Symbol.fromString
@@ -1942,7 +1949,7 @@
(ty, {con = Type.con,
expandOpaque = true,
record = Type.record,
- replaceCharWithWord8 = true,
+ replaceSynonyms = true,
var = Type.var})
(* We use expandedTy to get the underlying primitive right
* but we use wrap in the end to make the result of the
@@ -2099,7 +2106,7 @@
name = name,
region = region,
ty = expandedTy})
- | Prim => eta (Prim.new name)
+ | Prim => eta (Prim.fromString name)
end
| Aexp.Raise exn =>
let
1.86 +3 -3 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.85
retrieving revision 1.86
diff -u -r1.85 -r1.86
--- elaborate-env.fun 18 Mar 2004 04:07:05 -0000 1.85
+++ elaborate-env.fun 4 Apr 2004 06:50:21 -0000 1.86
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -409,7 +409,7 @@
Etype.hom (t, {con = con,
expandOpaque = false,
record = record,
- replaceCharWithWord8 = false,
+ replaceSynonyms = false,
var = var})
end
end
@@ -2789,7 +2789,7 @@
Type.hom (t, {con = con,
expandOpaque = false,
record = Type.record,
- replaceCharWithWord8 = false,
+ replaceSynonyms = false,
var = Type.var})
end
fun replaceScheme (s: Scheme.t): Scheme.t =
1.7 +14 -14 mlton/mlton/elaborate/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/sources.cm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- sources.cm 16 Feb 2004 22:42:10 -0000 1.6
+++ sources.cm 4 Apr 2004 06:50:21 -0000 1.7
@@ -21,21 +21,21 @@
../../lib/mlton/sources.cm
const-type.sig
-decs.fun
decs.sig
-elaborate-core.fun
-elaborate-core.sig
-elaborate-env.fun
-elaborate-env.sig
-elaborate-sigexp.fun
-elaborate-sigexp.sig
-elaborate.fun
-elaborate.sig
-interface.fun
+decs.fun
+type-env.sig
+type-env.fun
interface.sig
-precedence-parse.fun
+interface.fun
+elaborate-env.sig
+elaborate-env.fun
precedence-parse.sig
-scope.fun
+precedence-parse.fun
scope.sig
-type-env.fun
-type-env.sig
+scope.fun
+elaborate-core.sig
+elaborate-core.fun
+elaborate-sigexp.sig
+elaborate-sigexp.fun
+elaborate.sig
+elaborate.fun
1.33 +14 -11 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -r1.32 -r1.33
--- type-env.fun 18 Mar 2004 03:22:25 -0000 1.32
+++ type-env.fun 4 Apr 2004 06:50:21 -0000 1.33
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -1171,12 +1171,12 @@
UnifyResult.NotUnifiable ((l, _), (l', _)) => NotUnifiable (l, l')
| UnifyResult.Unified => Unified
- val word8 = word (WordSize.W 8)
+ val word8 = word WordSize.byte
fun 'a simpleHom {con: t * Tycon.t * 'a vector -> 'a,
expandOpaque: bool,
record: t * (Field.t * 'a) vector -> 'a,
- replaceCharWithWord8: bool,
+ replaceSynonyms: bool,
var: t * Tyvar.t -> 'a} =
let
val unit = con (unit, Tycon.tuple, Vector.new0 ())
@@ -1218,10 +1218,13 @@
val word = default (word WordSize.default, Tycon.defaultWord)
val con =
fn (t, c, ts) =>
- if replaceCharWithWord8 andalso Tycon.equals (c, Tycon.char)
- then con (word8,
- Tycon.word (WordSize.W 8),
- Vector.new0 ())
+ if replaceSynonyms
+ then if Tycon.equals (c, Tycon.char)
+ then con (word8, Tycon.word WordSize.byte,
+ Vector.new0 ())
+ else if Tycon.equals (c, Tycon.preThread)
+ then con (thread, Tycon.thread, Vector.new0 ())
+ else con (t, c, ts)
else con (t, c, ts)
in
makeHom {con = con,
@@ -1615,7 +1618,7 @@
simpleHom {con = con,
expandOpaque = expandOpaque,
record = fn (t, fs) => tuple (t, Vector.map (fs, #2)),
- replaceCharWithWord8 = true,
+ replaceSynonyms = true,
var = var}
end
@@ -1633,7 +1636,7 @@
record = fn (t, fs) => (t,
SOME (Vector.map (fs, fn (f, (t, _)) =>
(f, t)))),
- replaceCharWithWord8 = true,
+ replaceSynonyms = true,
var = fn (t, _) => (t, NONE)}
val res =
case #2 (hom t) of
@@ -1667,14 +1670,14 @@
val deTuple = valOf o deTupleOpt
- fun hom (t, {con, expandOpaque = e, record, replaceCharWithWord8 = r,
+ fun hom (t, {con, expandOpaque = e, record, replaceSynonyms = r,
var}) =
let
val {hom, destroy} =
simpleHom {con = fn (_, c, v) => con (c, v),
expandOpaque = e,
record = fn (_, fs) => record (Srecord.fromVector fs),
- replaceCharWithWord8 = r,
+ replaceSynonyms = r,
var = fn (_, a) => var a}
val res = hom t
val _ = destroy ()
1.18 +2 -2 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- type-env.sig 18 Mar 2004 03:22:25 -0000 1.17
+++ type-env.sig 4 Apr 2004 06:50:21 -0000 1.18
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -28,7 +28,7 @@
val hom: t * {con: Tycon.t * 'a vector -> 'a,
expandOpaque: bool,
record: 'a SortedRecord.t -> 'a,
- replaceCharWithWord8: bool,
+ replaceSynonyms: bool,
var: Tyvar.t -> 'a} -> 'a
val isChar: t -> bool
val isUnit: t -> bool
1.29 +12 -5 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- compile.fun 18 Mar 2004 10:31:48 -0000 1.28
+++ compile.fun 4 Apr 2004 06:50:21 -0000 1.29
@@ -1,10 +1,11 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+
functor Compile (S: COMPILE_STRUCTS): COMPILE =
struct
@@ -504,9 +505,9 @@
(* Set GC_state offsets. *)
val _ =
let
- fun get (s: string): int =
+ fun get (s: string): Bytes.t =
case lookupConstant (s, ConstType.Int) of
- Const.Int i => IntX.toInt i
+ Const.Int i => Bytes.fromInt (IntX.toInt i)
| _ => Error.bug "GC_state offset must be an int"
in
Runtime.GCField.setOffsets
@@ -596,8 +597,14 @@
else ()
end
val _ =
- Control.trace (Control.Pass, "machine type check")
- Machine.Program.typeCheck machine
+ (*
+ * For now, machine type check is too slow to run.
+ *)
+ if true
+ then ()
+ else
+ Control.trace (Control.Pass, "machine type check")
+ Machine.Program.typeCheck machine
in
machine
end
1.30 +2 -1 mlton/mlton/main/main.fun
Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- main.fun 19 Mar 2004 04:40:08 -0000 1.29
+++ main.fun 4 Apr 2004 06:50:21 -0000 1.30
@@ -1,10 +1,11 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
+
functor Main (S: MAIN_STRUCTS): MAIN =
struct
1.6 +3 -3 mlton/mlton/main/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm 9 Oct 2003 18:17:33 -0000 1.5
+++ sources.cm 4 Apr 2004 06:50:21 -0000 1.6
@@ -43,10 +43,10 @@
../ssa/sources.cm
../xml/sources.cm
-compile.fun
-compile.sig
lookup-constant.sig
lookup-constant.fun
-main.fun
+compile.sig
+compile.fun
main.sig
+main.fun
main.sml
1.10 +4 -2 mlton/mlton/match-compile/match-compile.fun
Index: match-compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/match-compile.fun,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- match-compile.fun 5 Mar 2004 03:50:55 -0000 1.9
+++ match-compile.fun 4 Apr 2004 06:50:21 -0000 1.10
@@ -143,12 +143,14 @@
Vector.fromList infos))))))
in
val directCases =
- make (List.remove (IntSize.all, fn s => IntSize.equals (s, IntSize.I 64)),
+ make (List.remove (IntSize.all, fn s =>
+ IntSize.equals (s, IntSize.I (Bits.fromInt 64))),
IntSize.cardinality, Type.int, Cases.int,
fn Const.Int i => i
| _ => Error.bug "caseInt type error")
@ make (List.remove (WordSize.all, fn s =>
- WordSize.equals (s, WordSize.W 64)),
+ WordSize.equals
+ (s, WordSize.fromBits (Bits.fromInt 64))),
WordSize.cardinality, Type.word, Cases.word,
fn Const.Word w => w
| _ => Error.bug "caseWord type error")
1.2 +3 -4 mlton/mlton/match-compile/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/match-compile/sources.cm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- sources.cm 9 Oct 2003 18:17:34 -0000 1.1
+++ sources.cm 4 Apr 2004 06:50:21 -0000 1.2
@@ -9,8 +9,7 @@
../control/sources.cm
../../lib/mlton/sources.cm
-match-compile.fun
-match-compile.sig
-nested-pat.fun
nested-pat.sig
-
+nested-pat.fun
+match-compile.sig
+match-compile.fun
1.38 +1 -1 mlton/mlton/ssa/shrink.fun
Index: shrink.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/shrink.fun,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -r1.37 -r1.38
--- shrink.fun 18 Mar 2004 03:22:25 -0000 1.37
+++ shrink.fun 4 Apr 2004 06:50:21 -0000 1.38
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.35 +43 -43 mlton/mlton/ssa/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/sources.cm,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- sources.cm 2 Mar 2004 03:24:33 -0000 1.34
+++ sources.cm 4 Apr 2004 06:50:21 -0000 1.35
@@ -20,67 +20,67 @@
../control/sources.cm
../../lib/mlton/sources.cm
-analyze.fun
+ssa-tree.sig
+ssa-tree.fun
+direct-exp.sig
+direct-exp.fun
analyze.sig
+analyze.fun
+type-check.sig
+type-check.fun
+shrink.sig
+shrink.fun
+flat-lattice.sig
+flat-lattice.fun
common-arg.sig
common-arg.fun
common-block.sig
common-block.fun
-common-subexp.fun
common-subexp.sig
-constant-propagation.fun
+common-subexp.fun
+global.sig
+global.fun
+two-point-lattice.sig
+two-point-lattice.fun
+multi.sig
+multi.fun
constant-propagation.sig
-contify.fun
+constant-propagation.fun
contify.sig
-direct-exp.fun
-direct-exp.sig
-flatten.fun
+contify.fun
flatten.sig
-flat-lattice.fun
-flat-lattice.sig
-global.fun
-global.sig
-inline.fun
+flatten.fun
inline.sig
-introduce-loops.fun
+inline.fun
introduce-loops.sig
-known-case.fun
+introduce-loops.fun
+n-point-lattice.sig
+n-point-lattice.fun
+three-point-lattice.sig
+three-point-lattice.fun
+restore.sig
+restore.fun
known-case.sig
-local-flatten.fun
+known-case.fun
local-flatten.sig
+local-flatten.fun
local-ref.sig
local-ref.fun
-loop-invariant.fun
loop-invariant.sig
-multi.fun
-multi.sig
-n-point-lattice.fun
-n-point-lattice.sig
-poly-equal.fun
+loop-invariant.fun
poly-equal.sig
-redundant.fun
-redundant.sig
-redundant-tests.fun
+poly-equal.fun
redundant-tests.sig
-remove-unused.fun
+redundant-tests.fun
+redundant.sig
+redundant.fun
remove-unused.sig
-restore.fun
-restore.sig
-shrink.fun
-shrink.sig
-simplify.fun
-simplify.sig
-simplify-types.fun
+remove-unused.fun
simplify-types.sig
-ssa-tree.fun
-ssa-tree.sig
-ssa.fun
-ssa.sig
-three-point-lattice.fun
-three-point-lattice.sig
-two-point-lattice.fun
-two-point-lattice.sig
-type-check.fun
-type-check.sig
-useless.fun
+simplify-types.fun
useless.sig
+useless.fun
+simplify.sig
+simplify.fun
+ssa.sig
+ssa.fun
1.68 +3 -19 mlton/mlton/ssa/ssa-tree.fun
Index: ssa-tree.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.fun,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -r1.67 -r1.68
--- ssa-tree.fun 18 Mar 2004 03:22:26 -0000 1.67
+++ ssa-tree.fun 4 Apr 2004 06:50:21 -0000 1.68
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -28,7 +28,6 @@
| Datatype of Tycon.t
| Int of IntSize.t
| IntInf
- | PreThread
| Real of RealSize.t
| Ref of t
| Thread
@@ -54,8 +53,7 @@
val tycons =
[(Tycon.array, unary Array)]
@ Vector.toListMap (Tycon.ints, fn (t, s) => (t, nullary (Int s)))
- @ [(Tycon.intInf, nullary IntInf),
- (Tycon.preThread, nullary PreThread)]
+ @ [(Tycon.intInf, nullary IntInf)]
@ Vector.toListMap (Tycon.reals, fn (t, s) => (t, nullary (Real s)))
@ [(Tycon.reff, unary Ref),
(Tycon.thread, nullary Thread),
@@ -88,7 +86,6 @@
| Datatype t => Tycon.layout t
| Int s => str (concat ["int", IntSize.toString s])
| IntInf => str "IntInf.int"
- | PreThread => str "preThread"
| Real s => str (concat ["real", RealSize.toString s])
| Ref t => seq [layout t, str " ref"]
| Thread => str "thread"
@@ -103,19 +100,6 @@
end
end
-structure Func =
- struct
- open Var (* Id (structure AstId = Ast.Var) *)
-
- fun newNoname () = newString "F"
- end
-
-structure Label =
- struct
- open Func
- fun newNoname () = newString "L"
- end
-
structure Cases =
struct
datatype t =
@@ -611,7 +595,7 @@
fun iff (test: Var.t, {truee, falsee}) =
let
- val s = IntSize.I 32
+ val s = IntSize.I (Bits.fromInt 32)
in
Case
{cases = Cases.Int (s, Vector.new2 ((IntX.zero s, falsee),
1.55 +24 -38 mlton/mlton/ssa/ssa-tree.sig
Index: ssa-tree.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/ssa-tree.sig,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- ssa-tree.sig 18 Mar 2004 03:22:26 -0000 1.54
+++ ssa-tree.sig 4 Apr 2004 06:50:21 -0000 1.55
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -12,8 +12,6 @@
include ATOMS
end
-signature LABEL = ID
-
signature HANDLER =
sig
structure Label: LABEL
@@ -64,7 +62,6 @@
| Datatype of Tycon.t
| Int of IntSize.t
| IntInf
- | PreThread
| Real of RealSize.t
| Ref of t
| Thread
@@ -78,22 +75,18 @@
end
sharing Atoms = Type.Atoms
- structure Func: ID
- structure Label: LABEL
-(* sharing Symbol = Func.Symbol = Label.Symbol *)
-
structure Exp:
sig
datatype t =
- ConApp of {con: Con.t,
- args: Var.t vector}
+ ConApp of {args: Var.t vector,
+ con: Con.t}
| Const of Const.t
- | PrimApp of {prim: Prim.t,
- targs: Type.t vector,
- args: Var.t vector}
+ | PrimApp of {args: Var.t vector,
+ prim: Prim.t,
+ targs: Type.t vector}
| Profile of ProfileExp.t
- | Select of {tuple: Var.t,
- offset: int}
+ | Select of {offset: int,
+ tuple: Var.t}
| Tuple of Var.t vector
| Var of Var.t
@@ -110,9 +103,9 @@
structure Statement:
sig
- datatype t = T of {var: Var.t option,
+ datatype t = T of {exp: Exp.t,
ty: Type.t,
- exp: Exp.t}
+ var: Var.t option}
val clear: t -> unit (* clear the var *)
val equals: t * t -> bool
@@ -147,31 +140,28 @@
structure Transfer:
sig
datatype t =
- Arith of {prim: Prim.t,
- args: Var.t vector,
+ Arith of {args: Var.t vector,
overflow: Label.t, (* Must be nullary. *)
+ prim: Prim.t,
success: Label.t, (* Must be unary. *)
ty: Type.t} (* int or word *)
| Bug (* MLton thought control couldn't reach here. *)
| Call of {args: Var.t vector,
func: Func.t,
return: Return.t}
- | Case of {test: Var.t,
- cases: Cases.t,
- default: Label.t option (* Must be nullary. *)
- }
- | Goto of {dst: Label.t,
- args: Var.t vector
- }
+ | Case of {cases: Cases.t,
+ default: Label.t option, (* Must be nullary. *)
+ test: Var.t}
+ | Goto of {args: Var.t vector,
+ dst: Label.t}
(* Raise implicitly raises to the caller.
* I.E. the local handler stack must be empty.
*)
| Raise of Var.t vector
| Return of Var.t vector
- | Runtime of {prim: Prim.t,
- args: Var.t vector,
- return: Label.t (* Must be nullary. *)
- }
+ | Runtime of {args: Var.t vector,
+ prim: Prim.t,
+ return: Label.t} (* Must be nullary. *)
val equals: t * t -> bool
val foreachFunc : t * (Func.t -> unit) -> unit
@@ -189,12 +179,10 @@
structure Block:
sig
datatype t =
- T of {
- args: (Var.t * Type.t) vector,
+ T of {args: (Var.t * Type.t) vector,
label: Label.t,
statements: Statement.t vector,
- transfer: Transfer.t
- }
+ transfer: Transfer.t}
val args: t -> (Var.t * Type.t) vector
val clear: t -> unit
@@ -259,12 +247,10 @@
structure Program:
sig
datatype t =
- T of {
- datatypes: Datatype.t vector,
+ T of {datatypes: Datatype.t vector,
functions: Function.t list,
globals: Statement.t vector,
- main: Func.t (* Must be nullary. *)
- }
+ main: Func.t (* Must be nullary. *)}
val clear: t -> unit
val clearTop: t -> unit
1.30 +23 -5 mlton/mlton/ssa/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ssa/type-check.fun,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- type-check.fun 18 Mar 2004 03:22:26 -0000 1.29
+++ type-check.fun 4 Apr 2004 06:50:21 -0000 1.30
@@ -323,7 +323,7 @@
val print = Out.outputc out
exception TypeError
fun error (msg, lay) =
- (print ("Type error: " ^ msg ^ "\n")
+ (print (concat ["Type error: ", msg, "\n"])
; Layout.output (lay, out)
; print "\n"
; raise TypeError)
@@ -336,7 +336,6 @@
fun coerces (from, to) =
Vector.foreach2 (from, to, fn (from, to) =>
coerce {from = from, to = to})
- val error = fn s => error (s, Layout.empty)
val coerce =
Trace.trace ("TypeCheck.coerce",
fn {from, to} => let open Layout
@@ -346,7 +345,7 @@
Unit.layout) coerce
fun select {tuple: Type.t, offset: int, resultType = _}: Type.t =
case Type.deTupleOpt tuple of
- NONE => error "select of non tuple"
+ NONE => error ("select of non tuple", Layout.empty)
| SOME ts => Vector.sub (ts, offset)
val {get = conInfo: Con.t -> {args: Type.t vector,
result: Type.t},
@@ -376,6 +375,24 @@
val _ = coerces (args', args)
in ()
end
+ fun primApp {args, prim, resultType, resultVar, targs} =
+ let
+ datatype z = datatype Prim.Name.t
+ val () =
+ if Type.checkPrimApp {args = args,
+ prim = prim,
+ result = resultType}
+ then ()
+ else error ("bad primapp",
+ let
+ open Layout
+ in
+ seq [Prim.layout prim,
+ tuple (Vector.toListMap (args, Type.layout))]
+ end)
+ in
+ resultType
+ end
val _ =
analyze {
coerce = coerce,
@@ -388,14 +405,15 @@
to = Type.word s},
fromType = fn x => x,
layout = Type.layout,
- primApp = #resultType,
+ primApp = primApp,
program = program,
select = select,
tuple = Type.tuple,
useFromTypeOnBinds = true
}
handle e => error (concat ["analyze raised exception ",
- Layout.toString (Exn.layout e)])
+ Layout.toString (Exn.layout e)],
+ Layout.empty)
val _ = Program.clear program
in
()
1.4 +1 -1 mlton/mlton/xml/polyvariance.sig
Index: polyvariance.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/polyvariance.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- polyvariance.sig 21 Apr 2003 15:16:19 -0000 1.3
+++ polyvariance.sig 4 Apr 2004 06:50:22 -0000 1.4
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
1.6 +20 -21 mlton/mlton/xml/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/sources.cm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sources.cm 18 Dec 2003 02:46:08 -0000 1.5
+++ sources.cm 4 Apr 2004 06:50:22 -0000 1.6
@@ -11,7 +11,6 @@
signature XML
signature XML_TYPE
-(*functor CallCount *)
functor Monomorphise
functor Xml
functor Sxml
@@ -22,30 +21,30 @@
../control/sources.cm
../../lib/mlton/sources.cm
-implement-exceptions.fun
-implement-exceptions.sig
-monomorphise.fun
-monomorphise.sig
-polyvariance.fun
-polyvariance.sig
-scc-funs.fun
+xml-type.sig
+xml-tree.sig
+xml-tree.fun
+type-check.sig
+type-check.fun
scc-funs.sig
-simplify-types.fun
+scc-funs.fun
simplify-types.sig
-shrink.fun
+simplify-types.fun
shrink.sig
+shrink.fun
+xml-simplify.sig
+xml-simplify.fun
+xml.sig
+xml.fun
sxml-exns.sig
-sxml-simplify.fun
-sxml-simplify.sig
+monomorphise.sig
+monomorphise.fun
sxml-tree.sig
+implement-exceptions.sig
+implement-exceptions.fun
+polyvariance.sig
+polyvariance.fun
+sxml-simplify.sig
+sxml-simplify.fun
sxml.sig
sxml.fun
-type-check.fun
-type-check.sig
-xml-tree.fun
-xml-tree.sig
-xml-type.sig
-xml-simplify.fun
-xml-simplify.sig
-xml.fun
-xml.sig
1.16 +8 -2 mlton/mlton/xml/type-check.fun
Index: type-check.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/xml/type-check.fun,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- type-check.fun 18 Feb 2004 04:24:24 -0000 1.15
+++ type-check.fun 4 Apr 2004 06:50:22 -0000 1.16
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
@@ -223,9 +223,15 @@
else error "bad handle"
end
| Lambda l => checkLambda l
- | PrimApp {targs, ...} =>
+ | PrimApp {args, prim, targs} =>
let
val _ = checkTypes targs
+ val () =
+ if Type.checkPrimApp {args = checkVarExps args,
+ prim = prim,
+ result = ty}
+ then ()
+ else error "bad primapp"
in
ty
end