[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