[MLton-devel] cvs commit: first checkin of SunOS/SPARC port
Stephen Weeks
sweeks@users.sourceforge.net
Wed, 09 Apr 2003 19:03:12 -0700
sweeks 03/04/09 19:03:12
Modified: . Makefile
basis-library/misc primitive.sml
basis-library/mlton mlton.sig random.sig random.sml
basis-library/real real.sml
basis-library/sml-nj sml-nj.sml
bin add-cross build-cross-gcc clean hosttype mlton
mlton-basis-version regression
doc/user-guide Makefile compiling.tex credits.tex
cross-compiling.tex cygwin.tex extensions.tex
freebsd.tex main.tex
include ccodegen.h
lib/mlton/basic random.sig
lib/mlton-stubs mlton.sig mlton.sml random.sig random.sml
mlton/backend machine.fun machine.sig
mlton/codegen/c-codegen c-codegen.fun
mlton/codegen/x86-codegen x86-codegen.fun
x86-mlton-basic.fun x86-translate.fun x86.fun
mlton/control control.sig control.sml
mlton/main main.sml
runtime IntInf.h Makefile basis-constants.h gc.c
mlton-basis.h my-lib.c net-constants.h
posix-constants.h
runtime/Posix/FileSys open.c
runtime/Posix/ProcEnv getgroups.c setenv.c
runtime/Posix/Signal Signal.c
runtime/basis IEEEReal.c Real.c Real_const.S
runtime/basis/Int quot.c rem.c
Added: doc/user-guide platform.tex sunos.tex
Log:
Added support for SunOS/SPARC platform using the C codegenerator. It
passes all the regressions and a cross-self compile as well as normal
self compile on a SPARC. I have not gone through a full bootstrap on
a SPARC because it is ridiculously slow (5 hours and counting) for the
version built with stubs to self compile. There's still a lot of
cleanup and performance tuning left.
Here's a more detailed list of changes.
Added MLton.hostType Sun.
Changed the type of Random.{seed,useed} so that they return a word
option instead of a word. They now return NONE if
/dev/{random,urandom} can't be read from (which may be the case on
SunOS).
Changed all shell scripts to /usr/bin/env bash. I needed to do this
because sh on SunOS doesn't have !.
Rewrote add-cross and build-cross-gcc to work for multiple targets.
Moved handling of gcc flags from shell script into the compiler
proper. This was done because we need different sets of flags for
different platforms. It shouldn't cause any problems, since you can
always use -cc-opt to override them.
Eliminated Machine.{SetExnStackLocal,SetExnStackSlot,SetSlotExnStack},
which were vestigal. They had been replaced by moves in the backend
a while ago.
Added -align-doubles {no|pad|skip}. For now, only -align-doubles no
is implemented. On SPARCs, which give a bus error for misaligned
doubles, this requires the C codegen to treat memory accesses to
doubles as two word accesses, which of course slows stuff down. In
the near future, I plan to implement pad and skip.
Rewrote many of the switch usage messages so that <> is used to
indicate a variable that should be substituted for.
Eliminated -D. You can use instead: -cc-opt '-D<SYM>'
Changed -build-constants to -build-constants {false|true}, for
uniformity's sake.
Revision Changes Path
1.85 +18 -4 mlton/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/Makefile,v
retrieving revision 1.84
retrieving revision 1.85
diff -u -r1.84 -r1.85
--- Makefile 12 Feb 2003 03:08:05 -0000 1.84
+++ Makefile 10 Apr 2003 02:03:00 -0000 1.85
@@ -62,7 +62,7 @@
.PHONY: constants
constants:
@echo 'Creating constants file.'
- $(BIN)/mlton -build-constants >tmp.c
+ $(BIN)/mlton -build-constants true >tmp.c
$(BIN)/mlton -output tmp tmp.c
./tmp >$(LIB)/$(HOST)/constants
rm -f tmp tmp.c
@@ -195,6 +195,9 @@
# puts them.
DESTDIR = $(CURDIR)/install
PREFIX = /usr
+ifeq ($(HOSTTYPE), sun)
+PREFIX = /usr/local
+endif
prefix = $(PREFIX)
MAN_PREFIX_EXTRA =
TBIN = $(DESTDIR)$(prefix)/bin
@@ -202,6 +205,14 @@
TLIB = $(DESTDIR)$(prefix)/$(ULIB)
TMAN = $(DESTDIR)$(prefix)$(MAN_PREFIX_EXTRA)/man/man1
TDOC = $(DESTDIR)$(prefix)/share/doc/mlton
+ifeq ($(HOSTTYPE), sun)
+TDOC = $(DESTDIR)$(prefix)/doc/mlton
+endif
+
+GZIP_MAN = true
+ifeq ($(HOSTTYPE), sun)
+GZIP_MAN = false
+endif
.PHONY: install
install:
@@ -225,9 +236,12 @@
$(CP) $(BIN)/$(LEX) $(BIN)/$(PROF) $(BIN)/$(YACC) $(TBIN)/
( cd $(SRC)/man && tar cf - mllex.1 mlprof.1 mlton.1 mlyacc.1 ) | \
( cd $(TMAN)/ && tar xf - )
- cd $(TMAN) && $(GZIP) mllex.1 mlprof.1 mlton.1 mlyacc.1
- find $(TDOC)/ -name CVS -type d | xargs --no-run-if-empty rm -rf
- find $(TDOC)/ -name .cvsignore -type f | xargs --no-run-if-empty rm -rf
+ if $(GZIP_MAN); then \
+ cd $(TMAN) && $(GZIP) mllex.1 mlprof.1 mlton.1 \
+ mlyacc.1; \
+ fi
+ find $(TDOC)/ -name CVS -type d | xargs rm -rf
+ find $(TDOC)/ -name .cvsignore -type f | xargs rm -rf
for f in $(TLIB)/$(AOUT) \
$(TBIN)/$(LEX) $(TBIN)/$(PROF) $(TBIN)/$(YACC); do \
strip --remove-section=.comment --remove-section=.note $$f; \
1.47 +11 -2 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -r1.46 -r1.47
--- primitive.sml 25 Mar 2003 04:31:22 -0000 1.46
+++ primitive.sml 10 Apr 2003 02:03:00 -0000 1.47
@@ -56,7 +56,6 @@
val halt = _prim "MLton_halt": int -> unit;
val handlesSignals = _prim "MLton_handlesSignals": bool;
val installSignalHandler = _prim "MLton_installSignalHandler": unit -> unit;
- val isLittleEndian = _const "MLton_isLittleEndian": bool;
val safe = _build_const "MLton_safe": bool;
val usesCallcc: bool ref = ref false;
@@ -290,13 +289,23 @@
structure MLton =
struct
datatype hostType =
- Cygwin | FreeBSD | Linux
+ Cygwin | FreeBSD | Linux | Sun
+
val hostType: hostType =
case _const "MLton_hostType": int; of
0 => Cygwin
| 1 => FreeBSD
| 2 => Linux
+ | 3 => Sun
+ | _ => raise Fail "strange hostType constant"
+ val isBigEndian =
+ case hostType of
+ Cygwin => false
+ | FreeBSD => false
+ | Linux => false
+ | Sun => true
+
val native = _build_const "MLton_native": bool;
structure Profile =
1.19 +1 -1 mlton/basis-library/mlton/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/mlton.sig,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- mlton.sig 25 Mar 2003 04:31:22 -0000 1.18
+++ mlton.sig 10 Apr 2003 02:03:01 -0000 1.19
@@ -17,7 +17,7 @@
*)
val eq: 'a * 'a -> bool
val errno: unit -> int (* the value of the C errno global *)
- datatype hostType = Cygwin | FreeBSD | Linux
+ datatype hostType = Cygwin | FreeBSD | Linux | Sun
val hostType: hostType
val isMLton: bool
val safe: bool
1.3 +8 -4 mlton/basis-library/mlton/random.sig
Index: random.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/random.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- random.sig 28 Mar 2002 18:52:07 -0000 1.2
+++ random.sig 10 Apr 2003 02:03:01 -0000 1.3
@@ -11,12 +11,16 @@
(* Get the next pseudrandom. *)
val rand: unit -> word
- (* Use /dev/random to get a word. Useful as an arg to srand. *)
- val seed: unit -> word
+ (* Use /dev/random to get a word. Useful as an arg to srand.
+ * Return NONE if /dev/random can't be read.
+ *)
+ val seed: unit -> word option
(* Set the seed used by rand. *)
val srand: word -> unit
- (* Use /dev/urandom to get a word. Useful as an arg to srand. *)
- val useed: unit -> word
+ (* Use /dev/urandom to get a word. Useful as an arg to srand.
+ * Return NONE if /dev/urandom can't be read.
+ *)
+ val useed: unit -> word option
end
1.3 +29 -28 mlton/basis-library/mlton/random.sml
Index: random.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/random.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- random.sml 29 Dec 2002 01:22:58 -0000 1.2
+++ random.sml 10 Apr 2003 02:03:01 -0000 1.3
@@ -1,7 +1,7 @@
structure MLtonRandom: MLTON_RANDOM =
struct
- (* Linux specific. Uses /dev/random and /dev/urandom to get a
- * random word.
+ (* Uses /dev/random and /dev/urandom to get a random word.
+ * If they can't be read from, return 0w13.
*)
local
fun make (file, name) =
@@ -9,32 +9,33 @@
val buf = Word8Array.array (4, 0w0)
in
fn () =>
- let
- val fd =
- let
- open Posix.FileSys
- in
- openf (file, O_RDONLY, O.flags [])
- end
- fun loop rem =
- let
- val n = Posix.IO.readArr (fd, {buf = buf,
- i = 4 - rem,
- sz = SOME rem})
- val _ = if n = 0
- then (Posix.IO.close fd; raise Fail name)
- else ()
- val rem = rem - n
- in
- if rem = 0
- then ()
- else loop rem
- end
- val _ = loop 4
- val _ = Posix.IO.close fd
- in
- Pack32Little.subArr (buf, 0)
- end
+ (let
+ val fd =
+ let
+ open Posix.FileSys
+ in
+ openf (file, O_RDONLY, O.flags [])
+ end
+ fun loop rem =
+ let
+ val n = Posix.IO.readArr (fd, {buf = buf,
+ i = 4 - rem,
+ sz = SOME rem})
+ val _ = if n = 0
+ then (Posix.IO.close fd; raise Fail name)
+ else ()
+ val rem = rem - n
+ in
+ if rem = 0
+ then ()
+ else loop rem
+ end
+ val _ = loop 4
+ val _ = Posix.IO.close fd
+ in
+ SOME (Pack32Little.subArr (buf, 0))
+ end
+ handle OS.SysErr _ => NONE)
end
in
val seed = make ("/dev/random", "Random.seed")
1.16 +7 -3 mlton/basis-library/real/real.sml
Index: real.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/real/real.sml,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- real.sml 24 Nov 2002 01:19:39 -0000 1.15
+++ real.sml 10 Apr 2003 02:03:01 -0000 1.16
@@ -28,11 +28,15 @@
open Math
structure MLton = Primitive.MLton
- (* Patches for Cygwin newlib, which does not handle out of range
- * args.
+ (* Patches for Cygwin and Sun, whose math libraries do not handle
+ * out of range args.
*)
val (acos, asin, ln, log10) =
- if not MLton.native andalso MLton.hostType = MLton.Cygwin
+ if not MLton.native
+ andalso (case MLton.hostType of
+ MLton.Cygwin => true
+ | MLton.Sun => true
+ | _ => false)
then
let
fun patch f x =
1.7 +12 -1 mlton/basis-library/sml-nj/sml-nj.sml
Index: sml-nj.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/sml-nj/sml-nj.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- sml-nj.sml 29 Dec 2002 01:22:59 -0000 1.6
+++ sml-nj.sml 10 Apr 2003 02:03:02 -0000 1.7
@@ -21,7 +21,17 @@
exception UNKNOWN
datatype os_kind = BEOS | MACOS | OS2 | UNIX | WIN32
- fun getHostArch () = "X86"
+ fun getHostArch () =
+ let
+ open Primitive.MLton
+ in
+ case hostType of
+ Cygwin => "X86"
+ | FreeBSD => "X86"
+ | Linux => "X86"
+ | Sun => "SPARC"
+ end
+
fun getOSKind () = UNIX
fun getOSName () =
let
@@ -31,6 +41,7 @@
Cygwin => "Cygwin"
| FreeBSD => "FreeBSD"
| Linux => "Linux"
+ | Sun => "Solaris"
end
end
1.9 +57 -44 mlton/bin/add-cross
Index: add-cross
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/add-cross,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- add-cross 26 Feb 2003 03:09:09 -0000 1.8
+++ add-cross 10 Apr 2003 02:03:02 -0000 1.9
@@ -1,62 +1,71 @@
-#!/bin/sh
+#!/usr/bin/env bash
# This script adds a new crosscompiler target for MLton.
-# You may need to set installLibDir, crossHost, or cygwin.
-# This script builds an executable in the current directory that you must
-# run on the target machine. This executable prints on standard output
-# the values of the compile time constants needed by the MLton when
-# cross compiling. You must place the output of running the executable in
-# $libDir/$crossHost/constants.
+#
+# It takes three arguments.
+#
+# 1. <crossHost>, will be used via the -b flag passed to the GCC
+# cross-compiler tools. You must already have installed the GCC
+# cross-compiler tools. This script does not do that, although you
+# may find the script build-cross-gcc helpful. <crossHost> here
+# should be the same as target in build-cross-gcc. Examples are
+# i386-pc-cygwin and sparc-sun-solaris.
+#
+# 2. {cygwin|sun}, specifies the kind of system. There are only two
+# possibilities.
+#
+# 3. <machine> specifies a remote machine of the cross type. After
+# cross compiling the runtime, this script will ssh to that machine to
+# get the values of the constants that the MLton basis library needs.
+# Of course, you must be able to ssh to this machine.
+#
+# You also may need to set $libDir, which determines where the
+# cross-compiler target will be installed.
set -e
+die () {
+ echo >&2 "$1"
+ exit 1
+}
+
+usage () {
+ die "usage: $name <crossHost> {cygwin|sun} <machine>"
+}
+
+case "$#" in
+3)
+ crossHost="$1"
+ crossType="$2"
+ machine="$3"
+ ;;
+*)
+ usage
+ ;;
+esac
+
+name=`basename $0`
original=`pwd`
dir=`dirname $0`
src=`cd $dir/.. && pwd`
-# libDir is the mlton lib directory where you would like the
-# cross-compiler information to be installed. If you have installed from the
-# rpms, this will usually be /usr/local/lib/mlton. You must have write
-# permission there.
+# libDir is the mlton lib directory where you would like the
+# cross-compiler information to be installed. If you have installed
+# from the rpms, this will usually be /usr/lib/mlton. You must have
+# write permission there.
lib="$src/build/lib"
-# crossHost will be used via the -b flag passed to the GCC cross-compiler tools.
-# You must already have installed the GCC cross-compiler tools. This script
-# does not do that, although you may find the script build-cross-gcc helpful.
-# crossHost here should be the same as target in build-cross-gcc.
-crossHost='i386-pc-cygwin'
-
-# There are two possible types for the target machine: cygwin and linux.
-# It should be obvious which of those you want.
-
-crossType='cygwin'
-
# You shouldn't need to change anything below this line.
-name=`basename $0`
-
-function die {
- echo >&2 $1
- exit 1
-}
-
-function usage {
- die "usage: $name"
-}
-
-case "$#" in
-0)
+case "$crossType" in
+cygwin|sun)
;;
*)
- usage
+ die "invalid crossType: $crossType"
;;
esac
-if [ "$crossType" != 'linux' -a "$crossType" != 'cygwin' ]; then
- die "invalid crossType: $crossType"
-fi
-
PATH=$src/build/bin:$PATH
mkdir -p "$lib/$crossHost/include" ||
@@ -72,10 +81,14 @@
exe='print-constants'
echo 'Building print-constants executable.'
(
- mlton -build-constants >$exe.c
- mlton -output $original/$exe.exe -host $crossHost $exe.c
+ mlton -build-constants true >$exe.c
+ mlton -output $original/$exe -host $crossHost $exe.c
rm -f $exe.c
) || die "Unable to build $exe executable."
-echo "You must now run $exe.exe on the $crossHost machine"
-echo "and put the output in $lib/$crossHost/constants."
+echo "Running print-constants on $machine."
+tar cf - $exe |
+ ssh $machine "tar xf - && ./$exe && rm -f $exe" \
+ >"$lib/$crossHost/constants"
+
+rm -f $original/$exe
1.7 +86 -48 mlton/bin/build-cross-gcc
Index: build-cross-gcc
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/build-cross-gcc,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- build-cross-gcc 17 Jan 2003 02:35:11 -0000 1.6
+++ build-cross-gcc 10 Apr 2003 02:03:02 -0000 1.7
@@ -1,52 +1,82 @@
-#!/bin/sh
+#!/usr/bin/env bash
-# This script builds and installs a gcc cross-compiler with a cygwin target.
-#
-# It requires that you have obtained the following packages, whose
-# tarfiles shoud be in the current directory:
-# binutils, cygwin, gcc, w32api
-# You can find ftp sites to download binutils and gcc-core at gnu.org.
-# I got cygwin and w32api by installing cygwin in a Windows machine (using
-# Cygwin's setup.exe program) and then getting the bzip'ed tar files out of
-# their Cygwin packages dir.
+# This script builds and installs a gcc cross compiler.
-set -e
-
-# You may need to change the version numbers below.
-# You also might want to change the installation prefix.
-#
-# I had problems with cygwin-1.3.18-1, since its libcygwin.a contained a
-# a file, pseudo-reloc.o, with some strangeness that binutils didn't
-# correctly handle.
-
-binutils='binutils-2.12'
-cygwin='cygwin-1.3.17-1'
-gccVers='2.95.3'
-gcc="gcc-$gccVers"
-gccTar="gcc-core-$gccVers.tar"
-w32api='w32api-2.1-1'
+# It has been used to build cross compilers from Linux to Cygwin and
+# from Linux to SunOS. It is unlikely that this script will work
+# out-of-the-box. It is only intended as a template. You should read
+# through it and understand what it does, and make changes as
+# necessary. Feel free to add another targetType if you modify this
+# script for another target.
-root=`pwd`
-target='i386-pc-cygwin'
-prefix='/usr'
-
-name=`basename $0`
+set -e
die () {
echo >&2 "$1"
exit 1
}
+root=`pwd`
+name=`basename $0`
+
usage () {
- die "usage: $name"
+ die "usage: $name {cygwin|sun}"
}
case "$#" in
-0)
+1)
+ case "$1" in
+ cygwin|sun)
+ targetType="$1"
+ ;;
+ *)
+ usage
;;
+ esac
+;;
*)
usage
- ;;
+esac
+
+# You may want to change the installation prefix, which is where the
+# script will install the cross-compiler tools.
+prefix='/usr'
+
+# You must have have the sources to binutils and gcc, and place the
+# tarfiles in the current directory. You can find ftp sites to
+# download binutils and gcc-core at gnu.org. You may need to change
+# the version numbers below to match what you download.
+binutils='binutils-2.12'
+gccVers='2.95.3'
+gccTar="gcc-core-$gccVers.tar"
+
+# You may want to set the target.
+case "$targetType" in
+cygwin)
+ target='i386-pc-cygwin'
+ # For Cygwin, we also need the cygwin and w32api packages,
+ # which contain necessary header files and libraries. I got
+ # them by installing cygwin in a Windows machine (using #
+ # Cygwin's setup.exe program) and then getting the bzip'ed tar
+ # files out of their Cygwin packages dir. I had problems with
+ # cygwin-1.3.18-1, since its libcygwin.a contained a file,
+ # pseudo-reloc.o, with some strangeness that binutils didn't
+ # correctly handle.
+ cygwin='cygwin-1.3.17-1'
+ w32api='w32api-2.1-1'
+;;
+sun)
+ target='sparc-sun-solaris'
+ # For sun, we assume that you have already copied the includes
+ # and libraries from a SunOS machine to the host machine.
+ if ! [ -d "$prefix/$target/include" -a -d "$prefix/$target/lib" ]; then
+ die "Must create $prefix/$target/{include,lib}."
+ fi
+ # The GCC tools expect limits.h to be in sys-include, not include.
+ ( cd $prefix/$target &&
+ mkdir -p sys-include &&
+ mv include/limits.h sys-include )
+;;
esac
exists () {
@@ -57,19 +87,24 @@
echo 'Checking that needed files exist.'
exists $binutils.tar
-exists $cygwin.tar
exists $gccTar
-exists $w32api.tar
-
-echo 'Copying include files and libraries needed by cross compiler.'
-cd $root
-mkdir -p cygwin
-cd cygwin
-tar x <../$cygwin.tar
-tar x <../$w32api.tar
-mkdir -p $prefix/$target ||
- die "Cannot create $prefix/$target."
-(cd usr && tar c include lib) | (cd $prefix/$target/ && tar x)
+case "$targetType" in
+cygwin)
+ exists $cygwin.tar
+ exists $w32api.tar
+ echo 'Copying include files and libraries needed by cross compiler.'
+ cd $root
+ mkdir -p cygwin
+ cd cygwin
+ tar x <../$cygwin.tar
+ tar x <../$w32api.tar
+ mkdir -p $prefix/$target ||
+ die "Cannot create $prefix/$target."
+ (cd usr && tar c include lib) | (cd $prefix/$target/ && tar x)
+;;
+*)
+;;
+esac
echo 'Building binutils.'
cd $root
@@ -89,10 +124,13 @@
tar x <$gccTar
mkdir -p build-gcc
cd build-gcc
-../$gcc/configure --enable-languages=c --prefix=$prefix --target=$target \
- >$root/configure-gcc-log 2>&1 ||
+../gcc-$gccVers/configure \
+ --enable-languages=c \
+ --prefix=$prefix \
+ --target=$target \
+ >$root/configure-gcc-log 2>&1 ||
die "Configure of gcc failed."
-make all install >$root/build-gcc-log 2>&1 ||
+make all install >$root/build-gcc-log 2>&1 ||
die "Build of gcc failed."
echo 'Success.'
1.13 +12 -2 mlton/bin/clean
Index: clean
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/clean,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- clean 29 Oct 2002 06:08:23 -0000 1.12
+++ clean 10 Apr 2003 02:03:02 -0000 1.13
@@ -1,7 +1,16 @@
-#!/bin/sh
+#!/usr/bin/env bash
set -e
+case `hosttype` in
+cygwin|freebsd|linux)
+ grepFlags='-q'
+;;
+sun)
+ grepFlags=''
+;;
+esac
+
doit () {
rm -rf '.#'* .*~ *~ *.a *.o CM core mlmon.out
if [ -r .cvsignore ]; then
@@ -10,7 +19,8 @@
for f in `ls`; do
if [ -d $f ]; then
cd $f;
- if [ -r Makefile ] && grep -q '^clean:' Makefile ; then
+ if [ -r Makefile ] &&
+ grep $grepFlags '^clean:' Makefile ; then
gmake clean
else
doit
1.4 +4 -1 mlton/bin/hosttype
Index: hosttype
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/hosttype,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- hosttype 29 Oct 2002 06:08:23 -0000 1.3
+++ hosttype 10 Apr 2003 02:03:02 -0000 1.4
@@ -1,4 +1,4 @@
-#!/bin/sh
+#!/usr/bin/env bash
set -e
@@ -11,6 +11,9 @@
;;
FreeBSD*)
hosttype=freebsd
+ ;;
+SunOS)
+ hosttype=sun
;;
*)
hosttype=unknown
1.21 +3 -16 mlton/bin/mlton
Index: mlton
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/mlton,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- mlton 12 Feb 2003 03:08:05 -0000 1.20
+++ mlton 10 Apr 2003 02:03:02 -0000 1.21
@@ -1,4 +1,4 @@
-#!/bin/sh
+#!/usr/bin/env bash
# This script calls MLton.
@@ -35,22 +35,9 @@
exit 1
}
-# You may need to add -L/path/to/libgmp before the "$@" so that the linker
-# can find the gmp.
-
-# -mcpu=pentiumpro is the same as -mcpu=i686
+# You may need to add -lib-search /path/to/libgmp before the "$@" so that the
+# linker can find the gmp.
doit "$lib" \
-cc "$gcc" \
- -ccopt '-malign-functions=5
- -malign-jumps=2
- -fno-strict-aliasing
- -fno-strength-reduce
- -fomit-frame-pointer
- -fschedule-insns
- -fschedule-insns2
- -malign-loops=2
- -mcpu=pentiumpro
- -w' \
- -link m \
"$@"
1.2 +1 -1 mlton/bin/mlton-basis-version
Index: mlton-basis-version
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/mlton-basis-version,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- mlton-basis-version 24 Nov 2002 17:56:42 -0000 1.1
+++ mlton-basis-version 10 Apr 2003 02:03:02 -0000 1.2
@@ -1,4 +1,4 @@
-#!/bin/sh
+#!/usr/bin/env bash
tmp="$$.sml"
1.57 +2 -2 mlton/bin/regression
Index: regression
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/regression,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -r1.56 -r1.57
--- regression 25 Feb 2003 02:05:25 -0000 1.56
+++ regression 10 Apr 2003 02:03:02 -0000 1.57
@@ -1,4 +1,4 @@
-#!/bin/sh
+#!/usr/bin/env bash
# This script runs the regression tests in src/regression.
# It also compiles the tests in benchmark/tests
@@ -56,7 +56,7 @@
echo "compilation of $f failed with $flags"
}
-$mlton -verbose 1
+$mlton -verbose 1 || echo 'no mlton present'
echo "flags = $flags"
cd $src/regression
1.14 +2 -0 mlton/doc/user-guide/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/Makefile,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- Makefile 29 Sep 2002 01:46:31 -0000 1.13
+++ Makefile 10 Apr 2003 02:03:03 -0000 1.14
@@ -17,7 +17,9 @@
main.tex \
man-page.tex \
nj-deviations.tex \
+ platform.tex \
profiling.tex \
+ sunos.tex
all: main.ps main/main.html
1.11 +4 -2 mlton/doc/user-guide/compiling.tex
Index: compiling.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/compiling.tex,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- compiling.tex 12 Mar 2003 20:35:40 -0000 1.10
+++ compiling.tex 10 Apr 2003 02:03:03 -0000 1.11
@@ -1,7 +1,9 @@
\sec{Compiling {\mlton}}{compiling}
-If you want to compile {\mlton}, you need either the source {\tt rpm} or {\tt
-tgz}. You can compile with either {\mlton} or {\smlnj}.
+If you want to compile {\mlton}, you need either the source {\tt rpm}
+or {\tt tgz}. You can compile with either {\mlton} or {\smlnj}, but
+we strongly recommend using {\mlton}, since it generates a much faster
+executable.
\subsection{Compiling with {\mlton}}
1.22 +2 -1 mlton/doc/user-guide/credits.tex
Index: credits.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/credits.tex,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- credits.tex 10 Apr 2003 01:32:40 -0000 1.21
+++ credits.tex 10 Apr 2003 02:03:03 -0000 1.22
@@ -38,7 +38,8 @@
\item
Alain Deutsch (\mailto{deutsch}{polyspace.com}) and \htmladdnormallink{PolySpace
Technologies}{http://www.polyspace.com/} provided many bug fixes and
-runtime system improvements.
+runtime system improvements, as well as some code to help the SPARC
+port.
\item
Simon Helsen (\mailto{shelsen}{acm.org}) has provided bug reports, suggestions,
1.7 +35 -35 mlton/doc/user-guide/cross-compiling.tex
Index: cross-compiling.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/cross-compiling.tex,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- cross-compiling.tex 12 Mar 2003 20:35:41 -0000 1.6
+++ cross-compiling.tex 10 Apr 2003 02:03:03 -0000 1.7
@@ -1,57 +1,57 @@
-\subsec{Cross compiling applications from Linux to Cygwin/Windows}
- {cross-compiling}
+\sec{Cross compiling}{cross-compiling}
-With {\mlton} running on Linux, you can use the {\tt -host} flag to cross
-compile applications and produce executables that run on Cygwin/Windows.
-In order to use {\mlton} as a
-cross compiler, you need to do several things.
+You can use the {\mlton}'s {\tt -host} flag to cross compile
+applications. By default, {\mlton} is only able to compile for the
+machine it is running on. In order to use {\mlton} as a cross
+compiler, you need to do two things. To make the terminology clear,
+we refer to the the {\em host} as the machine {\mlton} is running on
+and the {\em target} as the machine that {\mlton} is compiling for.
\begin{enumerate}
-\item Install the Cygwin {\tt dll} in the Windows machine.
+\item Install the GCC cross-compiler tools on the host so that GCC can
+compile to the target.
-\item Install the GCC cross-compiler tools on your Linux machine.
-
-\item Cross compile the {\mlton} runtime system for your Windows machine.
+\item Cross compile the {\mlton} runtime system to build the runtime
+libraries for the target.
\end{enumerate}
-To build a GCC cross-compiler toolset on your machine, you can use the script
-{\tt bin/build-cross-gcc} available in the {\mlton} sources. There are some
-comments at the top of the script that tell you what to download and what
-variables to set in order to build the toolset. In particular, the {\tt target}
-variable is important, since that is what you will pass to {\mlton}'s {\tt
+To build a GCC cross-compiler toolset on the host, you can use the
+script {\tt bin/build-cross-gcc}, available in the {\mlton} sources,
+as a template. The value of the {\tt target} variable in that script
+is important, since that is what you will pass to {\mlton}'s {\tt
-host} flag.
-Once you have the toolset built, you should be able to test it by cross
-compiling a simple hello world program on your Linux machine.
+Once you have the toolset built, you should be able to test it by
+cross compiling a simple hello world program on your host machine.
\begin{verbatim}
-gcc -b i386-pc-cygwin -o hello-world.exe hello-world.c
+gcc -b i386-pc-cygwin -o hello-world hello-world.c
\end{verbatim}
-You should now be able to run {\tt hello-world.exe} from a Cygwin shell on your
-Windows Machine.
+You should now be able to run {\tt hello-world} on the target machine,
+in this case, a Cygwin machine.
-Next, you must cross compile the {\mlton} runtime system and inform {\mlton} of
-the availability of the new target. The script {\tt bin/add-cross} from
-the {\mlton} sources will help you do this. Please read the comments at
-the top of the script. Here is a sample run.
+Next, you must cross compile the {\mlton} runtime system and inform
+{\mlton} of the availability of the new target. The script {\tt
+bin/add-cross} from the {\mlton} sources will help you do this.
+Please read the comments at the top of the script. Here is a sample
+run adding a SunOS cross compiler.
\begin{verbatim}
-% add-cross
+% add-cross sparc-sun-solaris sun blade
Making runtime.
Building print-constants executable.
-You must now run print-constants.exe on the i386-pc-cygwin machine
-and put the output in /tmp/mlton/build/lib/i386-pc-cygwin/constants.
+Running print-constants on blade.
\end{verbatim}
-Running {\tt add-cross} installs the cross-compiled runtime and creates a
-cross-compiled executable, {\tt print-constants.exe}, which prints out all of
-the constants that {\mlton} needs in order to implement the basis library. The
-final step is to run {\tt print-constants.exe} on your Windows machine, and save
-the output in the file indicated by {\tt add-cross}.
+Running {\tt add-cross} installs the cross-compiled runtime and
+creates a cross-compiled executable, {\tt print-constants}, which
+prints out all of the constants that {\mlton} needs in order to
+implement the basis library. Then, it runs {\tt print-constants} on
+the target machine ({\tt blade} in this case, and saves the output.
Once you have done all this, you should be able to cross compile SML
-applications. For example
+applications. For example,
\begin{verbatim}
mlton -host i386-pc-cygwin hello-world.sml
\end{verbatim}
-will create {\tt hello-world.exe}, which you should be able to run from a Cygwin
-shell on your Windows machine.
+will create {\tt hello-world}, which you should be able to run from a
+Cygwin shell on your Windows machine.
1.11 +7 -7 mlton/doc/user-guide/cygwin.tex
Index: cygwin.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/cygwin.tex,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- cygwin.tex 11 Feb 2003 22:27:01 -0000 1.10
+++ cygwin.tex 10 Apr 2003 02:03:03 -0000 1.11
@@ -1,4 +1,4 @@
-\sec{Running on Cygwin/Windows}{cygwin}
+\subsec{Running on Cygwin/Windows}{cygwin}
{\mlton} uses the \htmladdnormallink{Cygwin}{http://www.cygwin.com/}
emulation layer to provide a Posix-like environment while running on a
@@ -8,10 +8,12 @@
unpack the {\mlton} binary tgz in your Cygwin environment. This
version of {\mlton} was built against the Cygwin 1.3.17 header files.
-{\mlton} under Cygwin mostly behaves like {\mlton} under Linux. There are,
-however, a few missing features and known problems.
+To run {\mlton} cross-compiled executables on Windows, you must
+install the Cygwin {\tt dll} on the Windows machine.
-\begin{enumerate}
+Here are the known problems using {\mlton} on Cygwin.
+
+\begin{itemize}
\item Time profiling is disabled.
@@ -24,6 +26,4 @@
\item We have seen some strangeness in Cygwin's emulation of signals and
signal handlers, but have not been able to pin it down.
-\end{enumerate}
-
-\input{cross-compiling}
+\end{itemize}
1.40 +9 -4 mlton/doc/user-guide/extensions.tex
Index: extensions.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/extensions.tex,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- extensions.tex 12 Mar 2003 20:35:42 -0000 1.39
+++ extensions.tex 10 Apr 2003 02:03:04 -0000 1.40
@@ -443,9 +443,9 @@
sig
val alphaNumString: int -> string
val rand: unit -> word
- val seed: unit -> word
+ val seed: unit -> word option
val srand: word -> unit
- val useed: unit -> word
+ val useed: unit -> word option
end
\end{verbatim}
@@ -457,13 +457,18 @@
return the next pseudrandom number.
\entry{seed ()}
-return a random word from {\tt /dev/random}. Useful as an arg to {\tt srand}.
+return a random word from {\tt /dev/random}. Useful as an arg to {\tt
+srand}. If {\tt /dev/random} can not be read from, {\tt seed ()}
+returns {\tt NONE}.
\entry{srand w}
set the seed used by {\tt rand} to {\tt w}.
\entry{useed ()}
-return a random word from {\tt /dev/urandom}. Useful as an arg to {\tt srand}.
+return a random word from {\tt /dev/urandom}. Useful as an arg to
+{\tt srand}. If {\tt /dev/urandom} can not be read from, {\tt useed
+()} returns {\tt NONE}.
+
\end{description}
\subsubsection{\tt MLton.Rlimit}
1.9 +3 -4 mlton/doc/user-guide/freebsd.tex
Index: freebsd.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/freebsd.tex,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- freebsd.tex 11 Feb 2003 04:49:21 -0000 1.8
+++ freebsd.tex 10 Apr 2003 02:03:04 -0000 1.9
@@ -1,6 +1,6 @@
-\sec{Running on FreeBSD}{freebsd}
+\subsec{Running on FreeBSD}{freebsd}
-We have noticed a few issues when running {\mlton} on FreeBSD.
+Here are the known problems using {\mlton} on FreeBSD.
\begin{itemize}
@@ -12,8 +12,7 @@
\end{itemize}
-We have also noticed a few issues when compiling {\mlton} on FreeBSD. These
-only arise if you are working with the {\mlton} sources.
+Here are the known problems building {\mlton} on FreeBSD.
\begin{itemize}
1.7 +2 -2 mlton/doc/user-guide/main.tex
Index: main.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/main.tex,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- main.tex 14 Jan 2003 20:34:52 -0000 1.6
+++ main.tex 10 Apr 2003 02:03:04 -0000 1.7
@@ -28,12 +28,12 @@
%\input{performance}
\input{ffi}
\input{profiling}
-\input{freebsd}
-\input{cygwin}
\input{basis}
\input{extensions}
\input{cm}
\input{compiling}
+\input{platform}
+\input{cross-compiling}
\input{bugs}
\input{credits}
\bibliographystyle{alpha}
1.1 mlton/doc/user-guide/platform.tex
Index: platform.tex
===================================================================
\sec{Platform-specific notes}{platform}
This section discusses issues that arise when running or building
MLton on various platforms.
\input{cygwin}
\input{freebsd}
\input{sunos}
1.1 mlton/doc/user-guide/sunos.tex
Index: sunos.tex
===================================================================
\subsec{Running on SunOS}{sunos}
Here are the known problems using {\mlton} on SunOS.
\begin{itemize}
\item {\mlton} only supports the C code generator when running on
SPARCs. So, performance is not as good as it might be. Compile times
are also longer.
\end{itemize}
Here are the known problems building {\mlton} on SunOS.
\begin{itemize}
\item You must install the {\tt binutils}, {\tt gcc}, and {\tt make}
packages. You can find out how to get these at
\htmladdnormallink{Sunfreeware.com}{http://www.sunfreeware.com}.
\item Bootstrapping is so slow as to be impractical (many hours on a
500MhZ UltraSPARC). For this reason, we strongly recommend building
with a Linux to SunOS cross compiler (\secref{cross-compiling}).
\item Making the documentation requires that you install {\tt latex}
and {\tt dvips}, which are available in the {\tt tetex} package. It
also requires {\tt latex2html}, which we haven't yet tracked down a
package for yet.
\end{itemize}
1.54 +90 -47 mlton/include/ccodegen.h
Index: ccodegen.h
===================================================================
RCS file: /cvsroot/mlton/mlton/include/ccodegen.h,v
retrieving revision 1.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- ccodegen.h 2 Apr 2003 02:55:55 -0000 1.53
+++ ccodegen.h 10 Apr 2003 02:03:05 -0000 1.54
@@ -18,20 +18,20 @@
#define IsInt(p) (0x3 & (int)(p))
-#define BZ(x, l) \
- do { \
- if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%d BZ(%d, %s)\n", \
- __LINE__, (x), #l); \
- if (0 == (x)) goto l; \
+#define BZ(x, l) \
+ do { \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "%s: %d BZ(%d, %s)\n", \
+ __FILE__, __LINE__, (x), #l); \
+ if (0 == (x)) goto l; \
} while (0)
-#define BNZ(x, l) \
- do { \
- if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%d BNZ(%d, %s)\n", \
- __LINE__, (x), #l); \
- if (x) goto l; \
+#define BNZ(x, l) \
+ do { \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "%s: %d BNZ(%d, %s)\n", \
+ __FILE__, __LINE__, (x), #l); \
+ if (x) goto l; \
} while (0)
/* ------------------------------------------------- */
@@ -58,8 +58,8 @@
#define ChunkSwitch(n) \
if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%d entering chunk %d\n", \
- __LINE__, n); \
+ fprintf (stderr, "%s: %d entering chunk %d\n", \
+ __FILE__, __LINE__, n); \
CacheFrontier(); \
CacheStackTop(); \
while (1) { \
@@ -83,13 +83,13 @@
/* Calling SML from C */
/* ------------------------------------------------- */
-#define Thread_returnToC() \
- do { \
- if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%d Thread_returnToC()\n", \
- __LINE__); \
- returnToC = TRUE; \
- return cont; \
+#define Thread_returnToC() \
+ do { \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "%s: %d Thread_returnToC()\n", \
+ __FILE__, __LINE__); \
+ returnToC = TRUE; \
+ return cont; \
} while (0)
/* ------------------------------------------------- */
@@ -227,17 +227,18 @@
do { \
l_nextFun = *(word*)(stackTop - WORD_SIZE); \
if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%d Return() l_nextFun = %d\n", \
- __LINE__, l_nextFun); \
+ fprintf (stderr, "%s: %d Return() l_nextFun = %d\n", \
+ __FILE__, __LINE__, l_nextFun); \
goto top; \
} while (0)
-#define Raise() \
- do { \
- if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%d Raise\n", __LINE__); \
- stackTop = StackBottom + ExnStack; \
- Return(); \
+#define Raise() \
+ do { \
+ if (DEBUG_CCODEGEN) \
+ fprintf (stderr, "%s: %d Raise\n", \
+ __FILE__, __LINE__); \
+ stackTop = StackBottom + ExnStack; \
+ Return(); \
} while (0)
/* ------------------------------------------------- */
@@ -286,22 +287,11 @@
*(word*)frontier = (h); \
x = frontier + GC_NORMAL_HEADER_SIZE; \
if (DEBUG_CCODEGEN) \
- fprintf (stderr, "%d 0x%x = Object(%d)\n", \
- __LINE__, x, h); \
+ fprintf (stderr, "%s: %d 0x%x = Object(%d)\n", \
+ __FILE__, __LINE__, x, h); \
assert (frontier <= gcState.limitPlusSlop); \
} while (0)
-#define Assign(ty, o, v) \
- do { \
- *(ty*)(frontier + GC_NORMAL_HEADER_SIZE + (o)) = (v); \
- } while (0)
-
-#define AC(o, x) Assign(uchar, o, x)
-#define AD(o, x) Assign(double, o, x)
-#define AI(o, x) Assign(int, o, x)
-#define AP(o, x) Assign(pointer, o, x)
-#define AU(o, x) Assign(uint, o, x)
-
#define EndObject(bytes) \
do { \
frontier += (bytes); \
@@ -410,27 +400,41 @@
#endif
-static inline Int Int_addOverflow(Int lhs, Int rhs, Bool *overflow) {
+static inline Int Int_addOverflow (Int lhs, Int rhs, Bool *overflow) {
long long tmp;
tmp = (long long)lhs + rhs;
*overflow = (tmp != (int)tmp);
return tmp;
}
-static inline Int Int_mulOverflow(Int lhs, Int rhs, Bool *overflow) {
+static inline Int Int_mulOverflow (Int lhs, Int rhs, Bool *overflow) {
long long tmp;
tmp = (long long)lhs * rhs;
*overflow = (tmp != (int)tmp);
return tmp;
}
-static inline Int Int_subOverflow(Int lhs, Int rhs, Bool *overflow) {
+static inline Int Int_subOverflow (Int lhs, Int rhs, Bool *overflow) {
long long tmp;
tmp = (long long)lhs - rhs;
*overflow = (tmp != (int)tmp);
return tmp;
}
+static inline Word32 Word32_addOverflow (Word32 lhs, Word32 rhs, Bool *overflow) {
+ ullong tmp;
+
+ tmp = (ullong)lhs + rhs;
+ *overflow = (tmp != (Word32)tmp);
+ return tmp;
+}
+static inline Word32 Word32_mulOverflow (Word32 lhs, Word32 rhs, Bool *overflow) {
+ ullong tmp;
+
+ tmp = (ullong)lhs * rhs;
+ *overflow = (tmp != (Word32)tmp);
+ return tmp;
+}
#if (defined (INT_TEST) || defined (INT_LONG))
#define check(dst, n1, n2, l, f); \
@@ -438,10 +442,12 @@
int overflow; \
dst = f(n1, n2, &overflow); \
if (DEBUG_CCODEGEN) \
- fprintf(stderr, #f "(%d, %d) = %d\n", n1, n2, dst); \
+ fprintf (stderr, "%s: %d " #f "(%d, %d) = %d\n", \
+ __FILE__, __LINE__, n1, n2, dst); \
if (overflow) { \
if (DEBUG_CCODEGEN) \
- fprintf(stderr, "overflow\n"); \
+ fprintf (stderr, "%s: %d overflow\n", \
+ __FILE__, __LINE__); \
goto l; \
} \
} while (0)
@@ -600,6 +606,43 @@
#define Real_neg(x) (-(x))
#define Real_sub(x, y) ((x) - (y))
#define Real_toInt(x) ((int)(x))
+
+typedef volatile union {
+ word tab[2];
+ double d;
+} DoubleOr2Words;
+
+static inline double Real_fetch (double *dp) {
+ DoubleOr2Words u;
+ Word32 *p;
+
+ p = (Word32*)dp;
+ u.tab[0] = p[0];
+ u.tab[1] = p[1];
+ return u.d;
+}
+
+static inline void Real_move (double *dst, double *src) {
+ Word32 *pd;
+ Word32 *ps;
+ Word32 t;
+
+ pd = (Word32*)dst;
+ ps = (Word32*)src;
+ t = ps[1];
+ pd[0] = ps[0];
+ pd[1] = t;
+}
+
+static inline void Real_store (double *dp, double d) {
+ DoubleOr2Words u;
+ Word32 *p;
+
+ p = (Word32*)dp;
+ u.d = d;
+ p[0] = u.tab[0];
+ p[1] = u.tab[1];
+}
/* ------------------------------------------------- */
/* Vector */
1.3 +2 -2 mlton/lib/mlton/basic/random.sig
Index: random.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton/basic/random.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- random.sig 10 Apr 2002 07:50:31 -0000 1.2
+++ random.sig 10 Apr 2003 02:03:05 -0000 1.3
@@ -19,8 +19,8 @@
val nRandom: {list: 'a list, length: int, n: int} -> 'a list
(* 0.0 <= real() <= 1.0 *)
val real: unit -> real
- val seed: unit -> Word.t
+ val seed: unit -> Word.t option
val srand: Word.t -> unit
- val useed: unit -> Word.t
+ val useed: unit -> Word.t option
val word: unit -> Word.t
end
1.9 +1 -1 mlton/lib/mlton-stubs/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sig,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mlton.sig 25 Mar 2003 04:31:23 -0000 1.8
+++ mlton.sig 10 Apr 2003 02:03:06 -0000 1.9
@@ -17,7 +17,7 @@
*)
val eq: 'a * 'a -> bool
val errno: unit -> int (* the value of the C errno global *)
- datatype hostType = Cygwin | FreeBSD | Linux
+ datatype hostType = Cygwin | FreeBSD | Linux | Sun
val hostType: hostType
val isMLton: bool
val safe: bool
1.14 +1 -1 mlton/lib/mlton-stubs/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- mlton.sml 25 Mar 2003 04:31:23 -0000 1.13
+++ mlton.sml 10 Apr 2003 02:03:06 -0000 1.14
@@ -36,7 +36,7 @@
val deserialize = fn _ => raise Fail "deserialize"
val eq = fn _ => false
val errno = fn _ => raise Fail "errno"
- datatype hostType = Cygwin | FreeBSD | Linux
+ datatype hostType = Cygwin | FreeBSD | Linux | Sun
val hostType = Linux
val isMLton = false
val safe = true
1.3 +8 -4 mlton/lib/mlton-stubs/random.sig
Index: random.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/random.sig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- random.sig 10 Apr 2002 07:31:54 -0000 1.2
+++ random.sig 10 Apr 2003 02:03:06 -0000 1.3
@@ -11,12 +11,16 @@
(* Get the next pseudrandom. *)
val rand: unit -> word
- (* Use /dev/random to get a word. Useful as an arg to srand. *)
- val seed: unit -> word
+ (* Use /dev/random to get a word. Useful as an arg to srand.
+ * Return NONE if /dev/random can't be read.
+ *)
+ val seed: unit -> word option
(* Set the seed used by rand. *)
val srand: word -> unit
- (* Use /dev/urandom to get a word. Useful as an arg to srand. *)
- val useed: unit -> word
+ (* Use /dev/urandom to get a word. Useful as an arg to srand.
+ * Return NONE if /dev/urandom can't be read.
+ *)
+ val useed: unit -> word option
end
1.2 +2 -2 mlton/lib/mlton-stubs/random.sml
Index: random.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/random.sml,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- random.sml 6 Aug 2002 03:19:19 -0000 1.1
+++ random.sml 10 Apr 2003 02:03:06 -0000 1.2
@@ -1,7 +1,7 @@
structure Random: MLTON_RANDOM =
struct
- fun seed _ = 0w13: Word32.word
- fun useed _ = 0w13: Word32.word
+ fun seed _ = SOME (0w13: Word32.word)
+ fun useed _ = SOME (0w13: Word32.word)
local
val seed: word ref = ref 0w13
in
1.44 +0 -42 mlton/mlton/backend/machine.fun
Index: machine.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.fun,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- machine.fun 2 Apr 2003 02:55:56 -0000 1.43
+++ machine.fun 10 Apr 2003 02:03:06 -0000 1.44
@@ -324,9 +324,6 @@
dst: Operand.t option,
prim: Prim.t}
| ProfileLabel of ProfileLabel.t
- | SetExnStackLocal of {offset: int}
- | SetExnStackSlot of {offset: int}
- | SetSlotExnStack of {offset: int}
val layout =
let
@@ -361,12 +358,6 @@
end
| ProfileLabel l =>
seq [str "ProfileLabel ", ProfileLabel.layout l]
- | SetExnStackLocal {offset} =>
- seq [str "SetExnStackLocal ", Int.layout offset]
- | SetExnStackSlot {offset} =>
- seq [str "SetExnStackSlot ", Int.layout offset]
- | SetSlotExnStack {offset} =>
- seq [str "SetSlotExnStack ", Int.layout offset]
end
fun move (arg as {dst, src}) =
@@ -1188,39 +1179,6 @@
| _ => NONE
end
else SOME alloc
- | SetExnStackLocal {offset} =>
- (case Alloc.peekOffset (alloc, offset) of
- NONE => NONE
- | SOME {ty, ...} =>
- (case ty of
- Type.Label l =>
- let
- val Block.T {kind, ...} = labelBlock l
- in
- case kind of
- Kind.Handler {frameInfo, ...} =>
- let
- val {size, ...} =
- getFrameInfo frameInfo
- in
- if offset = size
- then SOME alloc
- else NONE
- end
- | _ => NONE
- end
- | _ => NONE))
- | SetExnStackSlot {offset} =>
- (checkOperand
- (Operand.StackOffset {offset = offset,
- ty = Type.word},
- alloc)
- ; SOME alloc)
- | SetSlotExnStack {offset} =>
- SOME
- (Alloc.define
- (alloc, Operand.StackOffset {offset = offset,
- ty = Type.word}))
end
fun liveIsOk (live: Operand.t vector,
a: Alloc.t): bool =
1.34 +0 -3 mlton/mlton/backend/machine.sig
Index: machine.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/backend/machine.sig,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- machine.sig 2 Apr 2003 02:55:56 -0000 1.33
+++ machine.sig 10 Apr 2003 02:03:06 -0000 1.34
@@ -111,9 +111,6 @@
dst: Operand.t option,
prim: Prim.t}
| ProfileLabel of ProfileLabel.t
- | SetExnStackLocal of {offset: int}
- | SetExnStackSlot of {offset: int}
- | SetSlotExnStack of {offset: int}
val foldOperands: t * 'a * (Operand.t * 'a -> 'a) -> 'a
val layout: t -> Layout.t
1.49 +117 -55 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.48
retrieving revision 1.49
diff -u -r1.48 -r1.49
--- c-codegen.fun 2 Apr 2003 02:55:56 -0000 1.48
+++ c-codegen.fun 10 Apr 2003 02:03:07 -0000 1.49
@@ -120,7 +120,14 @@
struct
open Operand
- val layout = Layout.str o toString
+ fun isMem (z: t): bool =
+ case z of
+ ArrayOffset _ => true
+ | Cast (z, _) => isMem z
+ | Contents _ => true
+ | Offset _ => true
+ | StackOffset _ => true
+ | _ => false
end
fun creturn (t: Runtime.Type.t): string =
@@ -226,7 +233,9 @@
end)
fun declareMain () =
let
- val magic = C.word (Random.useed ())
+ val magic = C.word (case Random.useed () of
+ NONE => String.hash (!Control.inputFile)
+ | SOME w => w)
in
C.callNoSemi ("Main",
[C.int (!Control.cardSizeLog2),
@@ -367,6 +376,27 @@
then s
else concat [s, " /* ", Label.toString l, " */"]
end
+ val handleMisalignedReals =
+ !Control.alignDoubles = Control.AlignNo
+ andalso !Control.hostType = Control.Sun
+ fun addr z = concat ["&(", z, ")"]
+ fun realFetch z = concat ["Real_fetch(", addr z, ")"]
+ fun realMove {dst, src} =
+ concat ["Real_move(", addr dst, ", ", addr src, ");\n"]
+ fun realStore {dst, src} =
+ concat ["Real_store(", addr dst, ", ", src, ");\n"]
+ fun move {dst: string, dstIsMem: bool,
+ src: string, srcIsMem: bool,
+ ty: Type.t}: string =
+ if handleMisalignedReals
+ andalso Type.equals (ty, Type.real)
+ then
+ case (dstIsMem, srcIsMem) of
+ (false, false) => concat [dst, " = ", src, ";\n"]
+ | (false, true) => concat [dst, " = ", realFetch src, ";\n"]
+ | (true, false) => realStore {dst = dst, src = src}
+ | (true, true) => realMove {dst = dst, src = src}
+ else concat [dst, " = ", src, ";\n"]
local
datatype z = datatype Operand.t
fun toString (z: Operand.t): string =
@@ -424,7 +454,12 @@
in
val operandToString = toString
end
-
+ fun fetchOperand (z: Operand.t): string =
+ if handleMisalignedReals
+ andalso Type.equals (Operand.ty z, Type.real)
+ andalso Operand.isMem z
+ then realFetch (operandToString z)
+ else operandToString z
fun outputStatement (s, print) =
let
datatype z = datatype Statement.t
@@ -435,55 +470,71 @@
(print "\t"
; (case s of
Move {dst, src} =>
- C.move ({dst = operandToString dst,
- src = operandToString src},
- print)
+ print
+ (move {dst = operandToString dst,
+ dstIsMem = Operand.isMem dst,
+ src = operandToString src,
+ srcIsMem = Operand.isMem src,
+ ty = Operand.ty dst})
| Noop => ()
| Object {dst, header, size, stores} =>
(C.call ("Object", [operandToString dst,
C.word header],
print)
- ; print "\t"
; (Vector.foreach
(stores, fn {offset, value} =>
- (C.call
- (concat ["A", Type.name (Operand.ty value)],
- [C.int offset, operandToString value],
- print)
- ; print "\t")))
+ let
+ val ty = Operand.ty value
+ val dst =
+ concat
+ ["C", Type.name (Operand.ty value),
+ "(frontier + ",
+ C.int (offset
+ + Runtime.normalHeaderSize),
+ ")"]
+ in
+ print "\t"
+ ; (print
+ (move {dst = dst,
+ dstIsMem = true,
+ src = operandToString value,
+ srcIsMem = Operand.isMem value,
+ ty = ty}))
+ end))
+ ; print "\t"
; C.call ("EndObject", [C.int size], print))
| PrimApp {args, dst, prim} =>
let
- val _ =
- case dst of
- NONE => ()
- | SOME dst =>
- print
- (concat [operandToString dst, " = "])
- fun doit () =
- C.call
- (Prim.toString prim,
- Vector.toListMap (args, operandToString),
- print)
- val _ =
+ fun call (): string =
+ concat
+ [Prim.toString prim,
+ "(",
+ concat
+ (List.separate
+ (Vector.toListMap (args, fetchOperand),
+ ", ")),
+ ")"]
+ fun app (): string =
case Prim.name prim of
Prim.Name.FFI s =>
(case Prim.numArgs prim of
- NONE => print (concat [s, ";\n"])
- | SOME _ => doit ())
- | _ => doit ()
- in
- ()
+ NONE => s
+ | SOME _ => call ())
+ | _ => call ()
+ in
+ case dst of
+ NONE => (print (app ())
+ ; print ";\n")
+ | SOME dst =>
+ print (move {dst = operandToString dst,
+ dstIsMem = Operand.isMem dst,
+ src = app (),
+ srcIsMem = false,
+ ty = Operand.ty dst})
end
| ProfileLabel l =>
C.call ("ProfileLabel", [ProfileLabel.toString l],
print)
- | SetExnStackLocal {offset} =>
- C.call ("SetExnStackLocal", [C.int offset], print)
- | SetExnStackSlot {offset} =>
- C.call ("SetExnStackSlot", [C.int offset], print)
- | SetSlotExnStack {offset} =>
- C.call ("SetSlotExnStack", [C.int offset], print)
))
end
val profiling = !Control.profile <> Control.ProfileNone
@@ -546,12 +597,14 @@
end)
fun push (return: Label.t, size: int) =
(print "\t"
- ; C.move ({dst = operandToString
- (Operand.StackOffset
- {offset = size - Runtime.labelSize,
- ty = Type.label return}),
- src = operandToString (Operand.Label return)},
- print)
+ ; print (move {dst = (operandToString
+ (Operand.StackOffset
+ {offset = size - Runtime.labelSize,
+ ty = Type.label return})),
+ dstIsMem = true,
+ src = operandToString (Operand.Label return),
+ srcIsMem = false,
+ ty = Type.Label return})
; C.push (size, print)
; if profiling
then print "\tFlushStackTop();\n"
@@ -574,21 +627,22 @@
concat ["tmp",
Int.toString (Counter.next c)]
val _ =
- print (concat
- ["\t",
- Runtime.Type.toString
- (Type.toRuntime ty),
- " ", tmp,
- " = ", operandToString z,
- ";\n"])
+ print
+ (concat
+ ["\t",
+ Runtime.Type.toString
+ (Type.toRuntime ty),
+ " ", tmp, " = ",
+ fetchOperand z,
+ ";\n"])
in
tmp
end
- | _ => operandToString z)
+ | _ => fetchOperand z)
in
(args, fn () => print "\t}\n")
end
- else (Vector.toListMap (args, operandToString),
+ else (Vector.toListMap (args, fetchOperand),
fn () => ())
val tracePrintLabelCode =
Trace.trace
@@ -642,10 +696,18 @@
| SOME fi => pop (valOf frameInfo)
; (Option.app
(dst, fn x =>
- print (concat
- ["\t", operandToString x, " = ",
- creturn (Type.toRuntime (Operand.ty x)),
- ";\n"]))))
+ let
+ val ty = Operand.ty x
+ in
+ print
+ (concat
+ ["\t",
+ move {dst = operandToString x,
+ dstIsMem = Operand.isMem x,
+ src = creturn (Type.toRuntime ty),
+ srcIsMem = false,
+ ty = ty}])
+ end)))
| Kind.Func => ()
| Kind.Handler {frameInfo, ...} => pop frameInfo
| Kind.Jump => ()
@@ -743,7 +805,7 @@
val (args, afterCall) =
case frameInfo of
NONE =>
- (Vector.toListMap (args, operandToString),
+ (Vector.toListMap (args, fetchOperand),
fn () => ())
| SOME frameInfo =>
let
1.37 +2 -0 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.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- x86-codegen.fun 20 Jan 2003 16:28:31 -0000 1.36
+++ x86-codegen.fun 10 Apr 2003 02:03:08 -0000 1.37
@@ -94,6 +94,7 @@
Control.Cygwin => true
| Control.FreeBSD => false
| Control.Linux => false
+ | _ => Error.bug "x86 can't handle hostType"
val makeC = outputC
val makeS = outputS
@@ -154,6 +155,7 @@
Control.Cygwin => String.dropPrefix (mainLabel, 1)
| Control.FreeBSD => mainLabel
| Control.Linux => mainLabel
+ | _ => Error.bug "x86 can't handle hostType"
in
[mainLabel, if reserveEsp then C.truee else C.falsee]
end
1.15 +3 -1 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.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- x86-mlton-basic.fun 23 Jan 2003 03:34:37 -0000 1.14
+++ x86-mlton-basic.fun 10 Apr 2003 02:03:08 -0000 1.15
@@ -315,7 +315,9 @@
Label.fromString (case !Control.hostType of
Control.Cygwin => "_LINE__"
| Control.FreeBSD => "__LINE__"
- | Control.Linux => "__LINE__"))
+ | Control.Linux => "__LINE__"
+ | _ => Error.bug "x86 can't handle hostType"))
+
val fileLine
= fn () => if !Control.debug
then Operand.immediate (Immediate.const_int 0)
1.40 +0 -107 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.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- x86-translate.fun 23 Jan 2003 03:34:37 -0000 1.39
+++ x86-translate.fun 10 Apr 2003 02:03:08 -0000 1.40
@@ -374,113 +374,6 @@
AppendList.single
(x86.Block.mkProfileBlock'
{profileLabel = l})
- | SetSlotExnStack {offset}
- => let
- val (comment_begin, comment_end) = comments statement
- val exnStack
- = x86MLton.gcState_currentThread_exnStackContentsOperand ()
- val stackTop = x86MLton.gcState_stackTopContentsOperand ()
- val stackBottom =
- x86MLton.gcState_stackBottomContentsOperand ()
- val tempP
- = let
- val index = x86.Immediate.const_int offset
- val memloc
- = x86.MemLoc.simple
- {base = x86MLton.gcState_stackTopContents (),
- index = index,
- scale = x86.Scale.One,
- size = x86MLton.pointerSize,
- class = x86MLton.Classes.Stack}
- in
- x86.Operand.memloc memloc
- end
- in
- AppendList.appends
- [comment_begin,
- AppendList.single
- (x86.Block.mkBlock'
- {entry = NONE,
- statements =
- [(* *(stackTop + offset) = exnStack *)
- x86.Assembly.instruction_mov
- {dst = tempP,
- src = exnStack,
- size = x86MLton.pointerSize}],
- transfer = NONE}),
- comment_end]
- end
- | SetExnStackLocal {offset}
- => let
- val (comment_begin,
- comment_end) = comments statement
- val exnStack
- = x86MLton.gcState_currentThread_exnStackContentsOperand ()
- val stackTop = x86MLton.gcState_stackTopContentsOperand ()
- val stackBottom =
- x86MLton.gcState_stackBottomContentsOperand ()
- in
- AppendList.appends
- [comment_begin,
- AppendList.single
- (x86.Block.mkBlock'
- {entry = NONE,
- statements
- = [(* exnStack = (stackTop + offset) - stackBottom *)
- x86.Assembly.instruction_mov
- {dst = exnStack,
- src = stackTop,
- size = x86MLton.pointerSize},
- x86.Assembly.instruction_binal
- {oper = x86.Instruction.ADD,
- dst = exnStack,
- src = x86.Operand.immediate_const_int offset,
- size = x86MLton.pointerSize},
- x86.Assembly.instruction_binal
- {oper = x86.Instruction.SUB,
- dst = exnStack,
- src = stackBottom,
- size = x86MLton.pointerSize}],
- transfer = NONE}),
- comment_end]
- end
- | SetExnStackSlot {offset}
- => let
- val (comment_begin,
- comment_end) = comments statement
-
- val exnStack =
- x86.Operand.memloc
- (x86MLton.gcState_currentThread_exnStackContents ())
-
- val tempP
- = let
- val index = x86.Immediate.const_int offset
- val memloc
- = x86.MemLoc.simple
- {base = x86MLton.gcState_stackTopContents (),
- index = index,
- scale = x86.Scale.One,
- size = x86MLton.pointerSize,
- class = x86MLton.Classes.Stack}
- in
- x86.Operand.memloc memloc
- end
- in
- AppendList.appends
- [comment_begin,
- AppendList.single
- (x86.Block.mkBlock'
- {entry = NONE,
- statements
- = [(* exnStack = *(stackTop + offset) *)
- x86.Assembly.instruction_mov
- {dst = exnStack,
- src = tempP,
- size = x86MLton.pointerSize}],
- transfer = NONE}),
- comment_end]
- end
| Object {dst, header, size, stores}
=> let
val (comment_begin,
1.37 +1 -0 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.36
retrieving revision 1.37
diff -u -r1.36 -r1.37
--- x86.fun 25 Mar 2003 04:31:25 -0000 1.36
+++ x86.fun 10 Apr 2003 02:03:08 -0000 1.37
@@ -58,6 +58,7 @@
Control.Cygwin => concat ["_", Label.toString l]
| Control.FreeBSD => Label.toString l
| Control.Linux => Label.toString l
+ | _ => Error.bug "x86 can't handle hostType"
val layout = Layout.str o toString
end
1.71 +4 -4 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -r1.70 -r1.71
--- control.sig 26 Feb 2003 00:10:50 -0000 1.70
+++ control.sig 10 Apr 2003 02:03:09 -0000 1.71
@@ -18,6 +18,9 @@
(* Begin Flags *)
(*------------------------------------*)
+ datatype alignDoubles = AlignNo | AlignPad | AlignSkip
+ val alignDoubles: alignDoubles ref
+
val basisLibs: string list
val basisLibrary: string ref
@@ -64,10 +67,7 @@
| Self
val host: host ref
- datatype hostType =
- Cygwin
- | FreeBSD
- | Linux
+ datatype hostType = datatype MLton.hostType
val hostType: hostType ref
(* Indentation used in laying out ILs. *)
1.87 +25 -4 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.86
retrieving revision 1.87
diff -u -r1.86 -r1.87
--- control.sml 26 Feb 2003 00:10:50 -0000 1.86
+++ control.sml 10 Apr 2003 02:03:09 -0000 1.87
@@ -11,6 +11,22 @@
structure C = Control ()
open C
+structure AlignDoubles =
+ struct
+ datatype t = AlignNo | AlignPad | AlignSkip
+
+ val toString =
+ fn AlignNo => "no"
+ | AlignPad => "pad"
+ | AlignSkip => "skip"
+ end
+
+datatype alignDoubles = datatype AlignDoubles.t
+
+val alignDoubles = control {name = "align doubles",
+ default = AlignNo,
+ toString = AlignDoubles.toString}
+
val basisLibs = ["basis-2002", "basis-2002-strict", "basis-1997", "basis-none"]
val basisLibrary = control {name = "basis library",
default = "basis-2002",
@@ -36,6 +52,7 @@
end
datatype chunk = datatype Chunk.t
+
val chunk = control {name = "chunk",
default = Coalesce {limit = 4096},
toString = Chunk.toString}
@@ -116,24 +133,24 @@
end
datatype host = datatype Host.t
+
val host = control {name = "host",
default = Self,
toString = Host.toString}
structure HostType =
struct
- datatype t =
- Cygwin
- | FreeBSD
- | Linux
+ datatype t = datatype MLton.hostType
val toString =
fn Cygwin => "Cygwin"
| FreeBSD => "FreeBSD"
| Linux => "Linux"
+ | Sun => "Sun"
end
datatype hostType = datatype HostType.t
+
val hostType = control {name = "host type",
default = Linux,
toString = HostType.toString}
@@ -249,7 +266,9 @@
val layout = Layout.str o toString
end
+
datatype limitCheck = datatype LimitCheck.t
+
val limitCheck = control {name = "limit check",
default = LoopHeaders {fullCFG = false,
loopExits = true},
@@ -428,6 +447,7 @@
| Header => "header"
| HeaderIndirect => "header indirect"
end
+
datatype variant = datatype Variant.t
val variant = control {name = "variant",
@@ -456,6 +476,7 @@
| (_, Detail) => true
| _ => false
end
+
datatype verbosity = datatype Verbosity.t
val verbosity = control {name = "verbosity",
1.128 +164 -114 mlton/mlton/main/main.sml
Index: main.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.sml,v
retrieving revision 1.127
retrieving revision 1.128
diff -u -r1.127 -r1.128
--- main.sml 2 Apr 2003 02:55:57 -0000 1.127
+++ main.sml 10 Apr 2003 02:03:10 -0000 1.128
@@ -36,10 +36,10 @@
end
val buildConstants: bool ref = ref false
+val ccOpts: string list ref = ref []
val coalesce: int option ref = ref NONE
val expert: bool ref = ref false
val gcc: string ref = ref "<unset>"
-val gccSwitches : string ref = ref ""
val includeDirs: string list ref = ref []
val keepGenerated = ref false
val keepO = ref false
@@ -65,8 +65,18 @@
"cygwin" => Control.Cygwin
| "freebsd" => Control.FreeBSD
| "linux" => Control.Linux
+ | "sun" => Control.Sun
| _ => Error.bug (concat ["strange hostType: ", hostType]))}
| _ => Error.bug (concat ["strange host mapping: ", line])))
+
+fun setHostType (hostString: string, usage): unit =
+ case List.peek (hostMap (), fn {host = h, ...} => h = hostString) of
+ NONE => usage (concat ["invalid host ", hostString])
+ | SOME {hostType = t, ...} =>
+ (Control.hostType := t
+ ; (case !Control.hostType of
+ Control.Sun => Control.Native.native := false
+ | _ => ()))
fun makeOptions {usage} =
let
@@ -77,6 +87,16 @@
List.map
(
[
+ (Expert, "align-doubles", " {no|pad|skip}",
+ " how to align doubles",
+ (SpaceString (fn s =>
+ alignDoubles
+ := (case s of
+ "no" => AlignNo
+ | "pad" => AlignPad
+ | "skip" => AlignSkip
+ | _ => usage (concat ["invalid -align-doubles flag: ",
+ s]))))),
(Normal, "basis", " {2002|1997|...}",
"select basis library to prefix to the program",
SpaceString (fn s =>
@@ -87,30 +107,23 @@
then basisLibrary := s'
else usage (concat ["invalid -basis flag: ", s])
end)),
- (Expert, "build-constants", "",
+ (Expert, "build-constants", " {false|true}",
"output C file that prints basis constants",
- trueRef buildConstants),
- (Expert, "card-size-log2", " n",
+ boolRef buildConstants),
+ (Expert, "card-size-log2", " <n>",
"log (base 2) of card size used by GC",
intRef cardSizeLog2),
- (Expert, "cc", " gcc", "path to gcc executable",
- SpaceString (fn s => (gcc := s; gccSwitches := ""))),
- (Expert, "coalesce", " n", "coalesce chunk size for C codegen",
+ (Expert, "cc", " <gcc>", "path to gcc executable",
+ SpaceString (fn s => gcc := s)),
+ (Expert, "cc-opt", " <opt>", "pass option to C compiler", push ccOpts),
+ (Expert, "coalesce", " <n>", "coalesce chunk size for C codegen",
Int (fn n => coalesce := SOME n)),
- (Expert, "ccopt", " opt", "pass option to C compiler",
- SpaceString (fn s =>
- if 3 = String.size s
- andalso String.isPrefix {string = s, prefix = "-O"}
- then (optimization
- := Char.toInt (String.sub (s, 2))
- - Char.toInt #"0")
- else gccSwitches := concat [!gccSwitches, " ", s])),
(Expert, "debug", " {false|true}", "produce executable with debug info",
boolRef debug),
(Normal, "detect-overflow", " {true|false}",
"overflow checking on integer arithmetic",
boolRef detectOverflow),
- (Expert, "diag", " pass", "keep diagnostic info for pass",
+ (Expert, "diag", " <pass>", "keep diagnostic info for pass",
SpaceString (fn s =>
(case Regexp.fromString s of
SOME (re,_) => let val re = Regexp.compileDFA re
@@ -119,10 +132,8 @@
; List.push (keepPasses, re)
end
| NONE => usage (concat ["invalid -diag flag: ", s])))),
- (Expert, "drop-pass", " pass", "omit optimization pass",
+ (Expert, "drop-pass", " <pass>", "omit optimization pass",
SpaceString (fn s => List.push (dropPasses, s))),
- (Expert, "D", "define", "define a constant for gcc",
- String (fn s => (List.push (defines, s)))),
(Expert, "eliminate-overflow", " {true|false}",
"eliminate useless overflow tests",
boolRef eliminateOverflow),
@@ -152,26 +163,14 @@
concat (List.separate (List.map (hostMap (), #host), "|")),
"}"],
"host type that executable will run on",
- SpaceString (fn s => host := (if s = "self" then Self else Cross s))),
+ SpaceString (fn s =>
+ (setHostType (s, usage)
+ ; host := (if s = "self" then Self else Cross s)))),
(Normal, "ieee-fp", " {false|true}", "use strict IEEE floating-point",
boolRef Native.IEEEFP),
- (Expert, "indentation", " n", "indentation level in ILs",
+ (Expert, "indentation", " <n>", "indentation level in ILs",
intRef indentation),
-(* (Normal, "include", " file.h", "include a .h file",
- * SpaceString (fn s => List.push (includes, s))),
- *)
- (Normal, "inline", " <n>", "inlining threshold",
- Int setInlineSize),
- (* -inline-array true is no longer allowed, because GC_arrayAllocate
- * knows intimate details of the generational GC.
- *)
-(* (Expert, "inline-array", " {false|true}",
- * "inline array allocation",
- * boolRef inlineArrayAllocation),
- *)
-(* (Normal, "I", "dir", "search dir for include files",
- * push includeDirs),
- *)
+ (Normal, "inline", " <n>", "inlining threshold", Int setInlineSize),
(Normal, "keep", " {g|o|sml}", "save intermediate files",
SpaceString (fn s =>
case s of
@@ -183,14 +182,14 @@
| "rssa" => keepRSSA := true
| "ssa" => keepSSA := true
| _ => usage (concat ["invalid -keep flag: ", s]))),
- (Expert, "keep-pass", " pass", "keep the results of pass",
+ (Expert, "keep-pass", " <pass>", "keep the results of pass",
SpaceString
(fn s => (case Regexp.fromString s of
SOME (re,_) => let val re = Regexp.compileDFA re
in List.push (keepPasses, re)
end
| NONE => usage (concat ["invalid -keep-pass flag: ", s])))),
- (Expert, "lib", " lib", "set MLton lib directory",
+ (Expert, "lib", " <lib>", "set MLton lib directory",
SpaceString (fn s => libDir := s)),
(Normal, "lib-search", " <dir>", "search dir for libraries (like gcc -L)",
push libDirs),
@@ -214,7 +213,7 @@
boolRef limitCheckCounts),
(Normal, "link", " <library>", "link with library (like gcc -l)",
push libs),
- (Expert, "loop-passes", " n", "loop optimization passes (1)",
+ (Expert, "loop-passes", " <n>", "loop optimization passes (1)",
Int
(fn i =>
if i >= 1
@@ -225,14 +224,16 @@
(Normal, "may-load-world", " {true|false}",
"may @MLton load-world be used",
boolRef mayLoadWorld),
- (Normal, "native", " {true|false}", "use native code generator",
+ (Normal, "native",
+ if !hostType = Sun then " {false}" else " {true|false}",
+ "use native code generator",
boolRef Native.native),
- (Expert, "native-commented", " n", "level of comments (0)",
+ (Expert, "native-commented", " <n>", "level of comments (0)",
intRef Native.commented),
(Expert, "native-copy-prop", " {true|false}",
"use copy propagation",
boolRef Native.copyProp),
- (Expert, "native-cutoff", " n",
+ (Expert, "native-cutoff", " <n>",
"live transfer cutoff distance",
intRef Native.cutoff),
(Expert, "native-live-transfer", " {0,...,8}",
@@ -244,9 +245,9 @@
(Expert, "native-move-hoist", " {true|false}",
"use move hoisting",
boolRef Native.moveHoist),
- (Expert, "native-optimize", " n", "level of optimizations",
+ (Expert, "native-optimize", " <n>", "level of optimizations",
intRef Native.optimize),
- (Expert, "native-split", " n", "split assembly files at ~n lines",
+ (Expert, "native-split", " <n>", "split assembly files at ~n lines",
Int (fn i => Native.split := SOME i)),
(Expert, "native-shuffle", " {true|false}",
"shuffle registers at C-calls",
@@ -280,15 +281,13 @@
case s of
"source" => profileIL := ProfileSource
| _ => usage (concat ["invalid -profile-il arg: ", s]))),
- (Normal, "profile-split", " <regexp>",
- "split duplicates of functions",
+ (Normal, "profile-split", " <regexp>", "split duplicates of functions",
SpaceString
(fn s =>
case Regexp.fromString s of
NONE => usage (concat ["invalid -profile-split regexp: ", s])
| SOME (r, _) => profileSplit := Regexp.or [r, !profileSplit])),
- (Normal, "profile-stack", " {false|true}",
- "profile the stack",
+ (Normal, "profile-stack", " {false|true}", "profile the stack",
boolRef profileStack),
(Normal, "safe", " {true|false}", "bounds checking and other checks",
boolRef safe),
@@ -315,7 +314,7 @@
| "sml" => Place.SML
| _ => usage (concat ["invalid -stop arg: ", s])))),
(Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
- (Expert, "text-io-buf-size", " n", "TextIO buffer size",
+ (Expert, "text-io-buf-size", " <n>", "TextIO buffer size",
intRef textIOBufSize),
(Expert, "type-check", " {false|true}", "type check ILs",
boolRef typeCheck),
@@ -327,7 +326,7 @@
| "1" => Top
| "2" => Pass
| "3" => Detail
- | _ => usage (concat ["invalid -v arg: ", s])))),
+ | _ => usage (concat ["invalid -verbose arg: ", s])))),
(Expert, "variant", " {header|first-word}",
"how to represent variant tags",
SpaceString
@@ -358,6 +357,7 @@
case args of
lib :: args => (libDir := lib; args)
| _ => Error.bug "incorrect args from shell script"
+ val _ = setHostType ("self", usage)
val result = parse args
val gcc = !gcc
val host = !host
@@ -369,10 +369,51 @@
val _ = Control.libDir := lib
val libDirs = lib :: !libDirs
val includeDirs = concat [lib, "/include"] :: !includeDirs
+ val x86CFlags =
+ ["-fno-strength-reduce",
+ "-fno-strict-aliasing",
+ "-fomit-frame-pointer",
+ "-fschedule-insns",
+ "-fschedule-insns2",
+ "-malign-functions=5",
+ "-malign-jumps=2",
+ "-malign-loops=2",
+ (* -mcpu=pentiumpro is the same as -mcpu=i686 *)
+ "-mcpu=pentiumpro",
+ "-w"]
+ val x86LinkLibs = ["m"]
+ val sparcCFlags =
+ ["-Wa,-xarch=v8plusa",
+ "-m32",
+ "-malign-functions=4",
+ "-mcpu=v9",
+ "-mno-epilogue",
+ "-mtune=ultrasparc",
+ "-w"]
+ val sparcLinkLibs = ["dl", "m", "nsl", "socket"]
+ val (cFlags, defaultLibs) =
+ case !hostType of
+ Cygwin => (x86CFlags, x86LinkLibs)
+ | FreeBSD => (x86CFlags, x86LinkLibs)
+ | Linux => (x86CFlags, x86LinkLibs)
+ | Sun => (sparcCFlags, sparcLinkLibs)
+ val ccOpts =
+ List.fold
+ (!ccOpts, cFlags, fn (ccOpt, ac) =>
+ if ccOpt = ""
+ then ac (* reset the options *)
+ else if (3 = String.size ccOpt
+ andalso String.isPrefix {string = ccOpt, prefix = "-O"})
+ then (optimization := (Char.toInt (String.sub (ccOpt, 2))
+ - Char.toInt #"0")
+ ; ac)
+ else ccOpt :: ac)
+ val ccOpts = String.tokens (concat (List.separate (ccOpts, " ")),
+ Char.isSpace)
val _ =
- case List.peek (hostMap (), fn {host = h, ...} => h = hostString) of
- NONE => usage (concat ["invalid host ", hostString])
- | SOME {hostType = t, ...} => hostType := t
+ if !Native.native andalso !hostType = Sun
+ then usage "can't use -native true on Sparc"
+ else ()
val _ =
chunk := (if !Native.native
then
@@ -416,18 +457,23 @@
let
val rec loop =
fn [] => usage (concat ["invalid file suffix on ", input])
- | (suf, start) :: sufs =>
+ | (suf, start, hasNum) :: sufs =>
if String.isSuffix {string = input, suffix = suf}
then (start,
- String.dropSuffix (File.fileOf input,
- String.size suf))
+ let
+ val f = File.base input
+ in
+ if hasNum
+ then File.base f
+ else f
+ end)
else loop sufs
datatype z = datatype Place.t
in
- loop [(".cm", CM),
- (".sml", SML),
- (".c", Generated),
- (".o", O)]
+ loop [(".cm", CM, false),
+ (".sml", SML, false),
+ (".c", Generated, true),
+ (".o", O, true)]
end
val (csoFiles, rest) =
List.splitPrefix (rest, fn s =>
@@ -480,8 +526,7 @@
inputs,
linkLibs])
val definesAndIncludes =
- List.concat [list ("-D", !defines),
- list ("-I", rev (includeDirs))]
+ list ("-I", rev (includeDirs))
(* This mess is necessary because the linker on linux
* adds a dependency to a shared library even if there are
* no references to it. So, on linux, we explicitly link
@@ -514,13 +559,13 @@
NONE => ["-lgmp"]
| SOME lib => [lib]
end
+ | Sun => ["-lgmp"]
val linkLibs: string list =
List.concat [list ("-L", rev (libDirs)),
list ("-l",
- (if !debug
- then "mlton-gdb"
+ (if !debug then "mlton-gdb"
else "mlton")
- :: !libs),
+ :: (defaultLibs @ (!libs))),
linkWithGmp]
datatype debugFormat =
Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus
@@ -555,19 +600,22 @@
* move the output file to it's rightful place.
*)
val _ =
- case MLton.hostType of
- MLton.Cygwin =>
+ if MLton.hostType = MLton.Cygwin
+ then
if String.contains (output, #".")
then ()
else
File.move {from = concat [output, ".exe"],
to = output}
- | MLton.FreeBSD => ()
- | MLton.Linux => ()
+ else ()
in
()
end
fun compileCSO (inputs: File.t list): unit =
+ if List.forall (inputs, fn f =>
+ SOME "o" = File.extension f)
+ then compileO inputs
+ else
let
val r = ref 0
val oFiles =
@@ -575,58 +623,60 @@
(fn () =>
List.fold
(inputs, [], fn (input, ac) =>
- if String.isSuffix {string = input,
- suffix = ".o"}
- then input :: ac
- else
let
- val (debugSwitches, switches) =
- if String.isSuffix {string = input,
- suffix = ".c"}
- then
- (gccDebug,
- List.concat
- [definesAndIncludes,
- [concat
- ["-O",
- Int.toString (!optimization)]],
- if !Native.native
- then []
- else String.tokens (!gccSwitches,
- Char.isSpace)])
- else ([asDebug], [])
- val switches =
- if !debug
- then debugSwitches @ switches
- else switches
- val switches =
- case host of
- Cross s => "-b" :: s :: switches
- | Self => switches
- val switches = "-c" :: switches
- val output =
- if stop = Place.O orelse !keepO
- then
- if !keepGenerated
- then
- concat
- [String.dropSuffix (input, 1),
- "o"]
- else
- (Int.inc r
- ; (suffix
- (concat [".", Int.toString (!r),
- ".o"])))
- else temp ".o"
- val _ = docc ([input], output, switches, [])
+ val extension = File.extension input
in
- output :: ac
+ if SOME "o" = extension
+ then input :: ac
+ else
+ let
+ val (debugSwitches, switches) =
+ if SOME "c" = extension
+ then
+ (gccDebug,
+ List.concat
+ [definesAndIncludes,
+ [concat
+ ["-O", (Int.toString
+ (!optimization))]],
+ ccOpts])
+ else ([asDebug], [])
+ val switches =
+ if !debug
+ then debugSwitches @ switches
+ else switches
+ val switches =
+ case host of
+ Cross s => "-b" :: s :: switches
+ | Self => switches
+ val switches = "-c" :: switches
+ val output =
+ if stop = Place.O orelse !keepO
+ then
+ if !keepGenerated
+ then
+ concat
+ [String.dropSuffix
+ (input, 1),
+ "o"]
+ else
+ (Int.inc r
+ ; (suffix
+ (concat
+ [".", Int.toString (!r),
+ ".o"])))
+ else temp ".o"
+ val _ =
+ docc ([input], output, switches, [])
+ in
+ output :: ac
+ end
end))
()
in
case stop of
Place.O => ()
- | _ => compileO oFiles
+ | _ => compileO (rev oFiles)
end
fun compileSml (files: File.t list) =
let
1.10 +1 -1 mlton/runtime/IntInf.h
Index: IntInf.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/IntInf.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- IntInf.h 24 Nov 2002 01:19:45 -0000 1.9
+++ IntInf.h 10 Apr 2003 02:03:10 -0000 1.10
@@ -24,7 +24,7 @@
* MLton package.
*/
#include "/usr/local/include/gmp.h"
-#elif (defined (__linux__))
+#elif (defined (__linux__) || defined (__sun__))
#include <gmp.h>
#else
#error gmp.h not defined for platform
1.52 +18 -1 mlton/runtime/Makefile
Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Makefile,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -r1.51 -r1.52
--- Makefile 23 Jan 2003 22:01:59 -0000 1.51
+++ Makefile 10 Apr 2003 02:03:10 -0000 1.52
@@ -1,4 +1,6 @@
HOST = self
+HOSTTYPE = $(shell ../bin/hosttype)
+
ifeq ($(HOST), self)
AR = ar rc
HOSTFLAGS =
@@ -6,7 +8,22 @@
AR = $(HOST)-ar rc
HOSTFLAGS = -b $(HOST)
endif
-CC = gcc -Wall -I. -mcpu=pentiumpro -malign-loops=2 -malign-jumps=2 -malign-functions=5 -fomit-frame-pointer $(HOSTFLAGS)
+
+X86FLAGS = -mcpu=pentiumpro -malign-loops=2 -malign-jumps=2 -malign-functions=5 -fomit-frame-pointer
+ifeq ($(HOSTTYPE), cygwin)
+ARCHFLAGS = $(X86FLAGS)
+endif
+ifeq ($(HOSTTYPE), freebsd)
+ARCHFLAGS = $(X86FLAGS)
+endif
+ifeq ($(HOSTTYPE), linux)
+ARCHFLAGS = $(X86FLAGS)
+endif
+ifeq ($(HOSTTYPE), sun)
+ARCHFLAGS =
+endif
+
+CC = gcc -Wall -I. $(ARCHFLAGS) $(HOSTFLAGS)
# Can't use more optimization than -O1 because gcc doesn't correctly compile
# Real_class in basis/Real.c
CFLAGS = -O1
1.11 +8 -2 mlton/runtime/basis-constants.h
Index: basis-constants.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis-constants.h,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- basis-constants.h 29 Dec 2002 01:23:00 -0000 1.10
+++ basis-constants.h 10 Apr 2003 02:03:10 -0000 1.11
@@ -33,10 +33,16 @@
#define MLton_hostType 1
#elif (defined (__linux__))
#define MLton_hostType 2
+#elif (defined (__sun__))
+#define MLton_hostType 3
#else
#error MLton_hostType not defined
#endif
-#define MLton_isLittleEndian TRUE
+
+#if (defined (__sun__))
+#define LOG_AUTHPRIV LOG_AUTH
+#define LOG_PERROR 0
+#endif /* __sun__ */
/* ------------------------------------------------- */
/* Ptrace */
@@ -46,7 +52,7 @@
/* Nothing to do -- everything comes from sys/ptrace.h. */
-#elif (defined (__CYGWIN__) || defined (__FreeBSD__))
+#elif (defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__sun__))
#define PTRACE_BOGUS 0xFFFFFFFF
#define PTRACE_SYSCALL PTRACE_BOGUS
1.127 +75 -38 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.126
retrieving revision 1.127
diff -u -r1.126 -r1.127
--- gc.c 25 Mar 2003 04:31:25 -0000 1.126
+++ gc.c 10 Apr 2003 02:03:10 -0000 1.127
@@ -36,7 +36,7 @@
#include <limits.h>
#endif
-#if (defined (__linux__) || defined (__FreeBSD__))
+#if (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
#include <signal.h>
#include <sys/stat.h>
#include <sys/time.h>
@@ -44,6 +44,10 @@
#include <ucontext.h>
#endif
+#if (defined (__sun__))
+#include <sys/swap.h> /* For swapctl. */
+#endif
+
#include "IntInf.h"
#define METER FALSE /* Displays distribution of object sizes at program exit. */
@@ -129,7 +133,7 @@
return n << 2;
}
-#if (defined (__linux__) || defined (__FreeBSD__))
+#if (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
static inline uint min (uint x, uint y) {
return ((x < y) ? x : y);
}
@@ -163,7 +167,7 @@
return 0 == a % b;
}
-#if (defined (__linux__) || defined (__FreeBSD__))
+#if (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
/* A super-safe mmap.
* Allocates a region of memory with dead zones at the high and low ends.
* Any attempt to touch the dead zone (read or write) will cause a
@@ -182,6 +186,15 @@
diee ("mprotect failed");
return result;
}
+
+#elif (defined (__CYGWIN__))
+
+/* Nothing needed. */
+
+#else
+
+#error ssmmap not defined on platform
+
#endif
static void release (void *base, size_t length) {
@@ -191,7 +204,7 @@
(uint)base);
if (0 == VirtualFree (base, 0, MEM_RELEASE))
die ("VirtualFree release failed");
-#elif (defined (__linux__) || defined (__FreeBSD__))
+#elif (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
smunmap (base, length);
#else
#error release not defined
@@ -205,7 +218,7 @@
(uint)base, (uint)length);
if (0 == VirtualFree (base, length, MEM_DECOMMIT))
die ("VirtualFree decommit failed");
-#elif (defined (__linux__) || defined (__FreeBSD__))
+#elif (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
smunmap (base, length);
#else
#error decommit not defined
@@ -289,24 +302,36 @@
showMaps();
}
-#elif (defined (__linux__))
+#elif (defined (__FreeBSD__))
-static void showMem() {
+static void showMem () {
static char buffer[256];
- sprintf(buffer, "/bin/cat /proc/%d/maps\n", getpid());
- (void)system(buffer);
+ sprintf (buffer, "/bin/cat /proc/%d/map\n", (int)getpid ());
+ (void)system (buffer);
}
-#elif (defined (__FreeBSD__))
+#elif (defined (__linux__))
static void showMem () {
static char buffer[256];
- sprintf (buffer, "/bin/cat /proc/%d/map\n", getpid ());
+ sprintf (buffer, "/bin/cat /proc/%d/maps\n", (int)getpid ());
(void)system (buffer);
}
+#elif (defined (__sun__))
+
+static void showMem () {
+ static char buffer[256];
+ sprintf (buffer, "pmap %d\n", (int)getpid ());
+ system (buffer);
+}
+
+#else
+
+#error showMem not defined on platform
+
#endif
static inline void copy (pointer src, pointer dst, uint size) {
@@ -1387,7 +1412,7 @@
(uint)h->start,
(uint)address,
(uint)h->size);
-#elif (defined (__linux__) || defined (__FreeBSD__))
+#elif (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
h->start = mmap (address+(void*)0, h->size,
PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANON, -1, 0);
@@ -2249,7 +2274,7 @@
/* heapRemap */
/* ---------------------------------------------------------------- */
-#if (defined (__CYGWIN__) || defined (__FreeBSD__))
+#if (defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__sun__))
static bool heapRemap (GC_state s, GC_heap h, W32 desired, W32 minSize) {
return FALSE;
@@ -3112,7 +3137,7 @@
}
}
-#if (defined (__linux__) || defined (__FreeBSD__))
+#if (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
#ifndef EIP
#define EIP 14
@@ -3134,6 +3159,8 @@
pc = (pointer) ucp->uc_mcontext.gregs[EIP];
#elif (defined (__FreeBSD__))
pc = (pointer) ucp->uc_mcontext.mc_eip;
+#elif (defined (__sun__))
+ pc = (pointer) ucp->uc_mcontext.gregs[REG_PC];
#else
#error pc not defined
#endif
@@ -3257,8 +3284,11 @@
static void initSignalStack (GC_state s) {
#if (defined (__CYGWIN__))
+
/* Nothing */
-#elif (defined (__linux__) || defined (__FreeBSD__))
+
+#elif (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
+
static stack_t altstack;
size_t ss_size = align (SIGSTKSZ, s->pageSize);
size_t psize = s->pageSize;
@@ -3267,8 +3297,11 @@
altstack.ss_size = ss_size;
altstack.ss_flags = 0;
sigaltstack (&altstack, NULL);
+
#else
+
#error initSignalStack not defined
+
#endif
}
@@ -3343,7 +3376,7 @@
static void setMemInfo (GC_state s) {
MEMORYSTATUS ms;
- GlobalMemoryStatus(&ms);
+ GlobalMemoryStatus (&ms);
s->totalRam = ms.dwTotalPhys;
s->totalSwap = ms.dwTotalPageFile;
}
@@ -3351,47 +3384,51 @@
#elif (defined (__FreeBSD__))
/* returns total amount of swap available */
-static int
-get_total_swap()
-{
+static int totalSwap () {
static char buffer[256];
FILE *file;
int total_size = 0;
- file = popen("/usr/sbin/swapinfo -k | awk '{ print $4; }'\n", "r");
+ file = popen ("/usr/sbin/swapinfo -k | awk '{ print $4; }'\n", "r");
if (file == NULL)
diee ("swapinfo failed");
-
/* skip header */
- fgets(buffer, 255, file);
-
+ fgets (buffer, 255, file);
while (fgets(buffer, 255, file) != NULL) {
total_size += atoi(buffer);
}
-
- pclose(file);
-
+ pclose (file);
return total_size * 1024;
}
/* returns total amount of memory available */
-static int
-get_total_mem()
-{
- int i, mem, len;
-
- len = sizeof(int);
- i = sysctlbyname("hw.physmem", &mem, &len, NULL, 0);
-
- if (i == -1)
- diee("sysctl failed");
+static int totalRam() {
+ int mem, len;
+ len = sizeof (int);
+ if (-1 == sysctlbyname ("hw.physmem", &mem, &len, NULL, 0))
+ diee ("sysctl failed");
return mem;
}
static void setMemInfo (GC_state s) {
- s->totalRam = get_total_mem();
- s->totalSwap = get_total_swap();
+ s->totalRam = totalRam();
+ s->totalSwap = totalSwap();
+}
+
+#elif (defined (__sun__))
+
+static void setMemInfo (GC_state s) {
+ struct anoninfo anon;
+
+ s->totalRam = sysconf (_SC_PHYS_PAGES) * s->pageSize;
+ if (-1 == swapctl (SC_AINFO, &anon))
+ /* Couldn't get swap, so assume that there's as much swap as
+ * there is RAM.
+ */
+ s->totalSwap = s->totalRam;
+ else
+ s->totalSwap = anon.ani_max * s->pageSize;
}
#else
1.21 +15 -25 mlton/runtime/mlton-basis.h
Index: mlton-basis.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/mlton-basis.h,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- mlton-basis.h 8 Jan 2003 15:19:17 -0000 1.20
+++ mlton-basis.h 10 Apr 2003 02:03:10 -0000 1.21
@@ -13,7 +13,8 @@
typedef double Double;
typedef int Int;
typedef char *Pointer;
-typedef unsigned long Word;
+typedef unsigned long Word32;
+typedef Word32 Word;
/* Here are some type abbreviations for abstract machine types. */
typedef Int Bool;
@@ -98,23 +99,12 @@
Int IEEEReal_getRoundingMode();
/* ------------------------------------------------- */
-/* Int */
-/* ------------------------------------------------- */
-
-Bool Int_addOverflow(int n1, int n2, int *res);
-Bool Int_mulOverflow(int n1, int n2, int *res);
-Bool Int_negOverflow(int n, int *res);
-Bool Int_subOverflow(int n1, int n2, int *res);
-Int Int_quot(Int numerator, Int denominator);
-Int Int_rem(Int numerator, Int denominator);
-
-/* ------------------------------------------------- */
/* Itimer */
/* ------------------------------------------------- */
-void Itimer_set(Int which,
- Int interval_tv_sec, Int interval_tv_usec,
- Int value_tv_sec, Int value_tv_usec);
+void Itimer_set (Int which,
+ Int interval_tv_sec, Int interval_tv_usec,
+ Int value_tv_sec, Int value_tv_usec);
/* ------------------------------------------------- */
/* MLton */
@@ -174,20 +164,20 @@
extern Double Real_minNormalPos;
extern Double Real_minPos;
-Int Real_class(Double d);
-Int Real_isFinite(Double d);
-Int Real_isNan(Double d);
-Int Real_isNormal(Double d);
-Int Real_isPositive(Double d);
-Int Real_qequal(Double x1, Double x2);
-double Real_round(Double d);
-Int Real_signBit(Double d);
+Int Real_class (Double d);
+Int Real_isFinite (Double d);
+Int Real_isNan (Double d);
+Int Real_isNormal (Double d);
+Int Real_isPositive (Double d);
+Int Real_qequal (Double x1, Double x2);
+double Real_round (Double d);
+Int Real_signBit (Double d);
/* ------------------------------------------------- */
/* Rlimit */
/* ------------------------------------------------- */
-#if (defined (__CYGWIN__))
+#if (defined (__CYGWIN__) || defined (__sun__))
#define RLIMIT_BOGUS 0xFFFFFFFF
#define RLIMIT_RSS RLIMIT_BOGUS
#define RLIMIT_NPROC RLIMIT_BOGUS
@@ -205,7 +195,7 @@
#define MLton_Rlimit_stackSize RLIMIT_STACK
#if (defined (__FreeBSD__))
#define MLton_Rlimit_virtualMemorySize RLIMIT_DATA
-#elif (defined (__CYGWIN__) || defined (__linux__))
+#elif (defined (__CYGWIN__) || defined (__linux__) || defined (__sun__))
#define MLton_Rlimit_virtualMemorySize RLIMIT_AS
#else
#error MLton_Rlimit_virtualMemorySize not defined
1.19 +2 -2 mlton/runtime/my-lib.c
Index: my-lib.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/my-lib.c,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- my-lib.c 2 Jan 2003 17:45:22 -0000 1.18
+++ my-lib.c 10 Apr 2003 02:03:10 -0000 1.19
@@ -151,7 +151,7 @@
if (0 == n)
buf[i--] = '0';
-#if (defined (__CYGWIN__) || defined (__FreeBSD__))
+#if (defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__sun__))
#define MININT 0x80000000
#endif
else if (MININT == n) {
@@ -240,7 +240,7 @@
result = VirtualAlloc (0, length, MEM_COMMIT, PAGE_READWRITE);
if (NULL == result)
die("VirtualAlloc failed");
-#elif (defined (__linux__) || defined (__FreeBSD__))
+#elif (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
result = mmap (NULL, length, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANON, -1, 0);
if (result == (void*)-1)
1.3 +4 -0 mlton/runtime/net-constants.h
Index: net-constants.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/net-constants.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- net-constants.h 15 Jan 2003 20:10:14 -0000 1.2
+++ net-constants.h 10 Apr 2003 02:03:10 -0000 1.3
@@ -3,6 +3,10 @@
#include <stdlib.h>
#include <errno.h>
+#if (defined __sun__)
+#include <sys/filio.h> /* For FIONBIO, FIONREAD. */
+#include <sys/sockio.h> /* For SIOCATMARK. */
+#endif
#include <sys/ioctl.h>
#include <sys/types.h>
#include <sys/socket.h>
1.9 +15 -5 mlton/runtime/posix-constants.h
Index: posix-constants.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/posix-constants.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- posix-constants.h 24 Nov 2002 01:19:45 -0000 1.8
+++ posix-constants.h 10 Apr 2003 02:03:10 -0000 1.9
@@ -71,12 +71,22 @@
#define Posix_FileSys_S_ifchr S_IFCHR
#define Posix_FileSys_S_ififo S_IFIFO
-/* Cygwin/Windows distinguish between text and binary files, but Linux and
- * FreeBSD do not.
+/* Cygwin/Windows distinguish between text and binary files, but Linux,
+ * FreeBSD, and Solaris do not.
*/
-#if (defined (__linux__) || defined (__FreeBSD__))
+#if (defined (__CYGWIN__))
+
+/* Nothing. */
+
+#elif (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
+
#define O_BINARY 0
#define O_TEXT 0
+
+#else
+
+#error May need to define O_BINARY and O_TEXT on platform.
+
#endif
#define Posix_FileSys_O_append O_APPEND
@@ -85,7 +95,7 @@
#define Posix_FileSys_O_excl O_EXCL
#define Posix_FileSys_O_noctty O_NOCTTY
#define Posix_FileSys_O_nonblock O_NONBLOCK
-#if (defined (__CYGWIN__) || defined (__linux__))
+#if (defined (__CYGWIN__) || defined (__linux__) || defined (__sun__))
#define Posix_FileSys_O_sync O_SYNC
#elif (defined (__FreeBSD__))
#define Posix_FileSys_O_sync 0
@@ -222,7 +232,7 @@
#define Posix_Signal_vtalrm SIGVTALRM
#define Posix_Signal_block SIG_BLOCK
-#if (defined (__CYGWIN__) || defined (__FreeBSD__))
+#if (defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__sun__))
#define Posix_Signal_numSignals NSIG
#elif (defined (__linux__))
#define Posix_Signal_numSignals _NSIG
1.5 +1 -1 mlton/runtime/Posix/FileSys/open.c
Index: open.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/FileSys/open.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- open.c 16 Sep 2002 18:46:26 -0000 1.4
+++ open.c 10 Apr 2003 02:03:11 -0000 1.5
@@ -5,7 +5,7 @@
Int Posix_FileSys_open (NullString p, Word w, Mode m) {
-#if (defined (__linux__) || defined (__FreeBSD__))
+#if (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
return open ((char *) p, w, m);
1.2 +2 -2 mlton/runtime/Posix/ProcEnv/getgroups.c
Index: getgroups.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/ProcEnv/getgroups.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- getgroups.c 18 Jul 2001 05:51:06 -0000 1.1
+++ getgroups.c 10 Apr 2003 02:03:11 -0000 1.2
@@ -7,12 +7,12 @@
* shorts (i.e. gid_t).
*/
-Int Posix_ProcEnv_getgroups(Pointer groups) {
+Int Posix_ProcEnv_getgroups (Pointer groups) {
int i;
int result;
gid_t groupList[Posix_ProcEnv_numgroups];
- result = getgroups(Posix_ProcEnv_numgroups, groupList);
+ result = getgroups (Posix_ProcEnv_numgroups, groupList);
for (i = 0; i < result; i++)
((Word *) groups)[i] = groupList[i];
1.2 +31 -0 mlton/runtime/Posix/ProcEnv/setenv.c
Index: setenv.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/ProcEnv/setenv.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- setenv.c 18 Jul 2001 05:51:06 -0000 1.1
+++ setenv.c 10 Apr 2003 02:03:11 -0000 1.2
@@ -1,6 +1,37 @@
#include <stdlib.h>
#include "mlton-posix.h"
+
+
+#if (defined (__CYGWIN__) || defined (__FreeBSD__) || defined (__linux__))
+
Int Posix_ProcEnv_setenv (NullString s, NullString v) {
return setenv ((char *)s, (char *)v, 1);
}
+
+#elif (defined (__sun__))
+
+#include <stdio.h> // for sprintf
+#include <strings.h>
+
+/* This has a space leak, but I don't see how to avoid it, since the
+ * specification of putenv is that it uses the memory for its arg.
+ */
+
+Int Posix_ProcEnv_setenv (NullString s, NullString v) {
+ char *b;
+ char *name;
+ char *value;
+
+ name = (char *)s;
+ value = (char *)v;
+ b = malloc (strlen (name) + strlen (value) + 2 /* = and \000 */);
+ sprintf (b, "%s=%s", name, value);
+ return putenv (b);
+}
+
+#else
+
+#error Need to define Posix_ProcEnv_setenv for platform
+
+#endif
1.9 +1 -1 mlton/runtime/Posix/Signal/Signal.c
Index: Signal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/Posix/Signal/Signal.c,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- Signal.c 16 Sep 2002 18:46:26 -0000 1.8
+++ Signal.c 10 Apr 2003 02:03:11 -0000 1.9
@@ -10,7 +10,7 @@
}
enum {
-#if (defined (__linux__) || defined (__FreeBSD__))
+#if (defined (__linux__) || defined (__FreeBSD__) || defined (__sun__))
SA_FLAGS = SA_ONSTACK,
#elif (defined (__CYGWIN__))
SA_FLAGS = 0,
1.2 +48 -16 mlton/runtime/basis/IEEEReal.c
Index: IEEEReal.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/IEEEReal.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- IEEEReal.c 18 Jul 2001 05:51:05 -0000 1.1
+++ IEEEReal.c 10 Apr 2003 02:03:12 -0000 1.2
@@ -1,33 +1,65 @@
#include "mlton-basis.h"
+#include "my-lib.h"
/* ------------------------------------------------- */
/* IEEEReal */
/* ------------------------------------------------- */
+#if (defined (__i386__))
+
+/* Macros for accessing the hardware control word. */
+#define _FPU_GETCW(cw) __asm__ ("fnstcw %0" : "=m" (*&cw))
+#define _FPU_SETCW(cw) __asm__ ("fldcw %0" : : "m" (*&cw))
+
#define ROUNDING_CONTROL_MASK 0x0C00
#define ROUNDING_CONTROL_SHIFT 10
-void IEEEReal_setRoundingMode(int mode) {
+void IEEEReal_setRoundingMode (int mode) {
unsigned short controlWord;
- __asm__ __volatile__ ("fstcw %0"
- : "=m" (controlWord)
- : );
- controlWord =
- (mode << ROUNDING_CONTROL_SHIFT)
- | (controlWord & ~ROUNDING_CONTROL_MASK);
-
- __asm__ __volatile__ ("fldcw %0"
- :
- : "m" (controlWord));
+ _FPU_GETCW(controlWord);
+ controlWord &= ~ROUNDING_CONTROL_MASK;
+ controlWord |= mode << ROUNDING_CONTROL_SHIFT;
+ _FPU_SETCW(controlWord);
}
-Int IEEEReal_getRoundingMode() {
+Int IEEEReal_getRoundingMode () {
unsigned short controlWord;
- __asm__ __volatile__ ("fstcw %0"
- : "=m" (controlWord)
- : );
-
+ _FPU_GETCW(controlWord);
return (controlWord & ROUNDING_CONTROL_MASK) >> ROUNDING_CONTROL_SHIFT;
}
+
+#elif (defined (__sparc__))
+
+#include <ieeefp.h>
+
+void IEEEReal_setRoundingMode (int mode) {
+ switch (mode) {
+ case 0: mode = FP_RN; break;
+ case 1: mode = FP_RM; break;
+ case 2: mode = FP_RP; break;
+ case 3: mode = FP_RZ; break;
+ default:
+ die ("IEEEReal_setRoundingMode error: invalid mode %d\n", mode);
+ }
+ fpsetround (mode);
+}
+
+int IEEEReal_getRoundingMode () {
+ int mode;
+
+ mode = fpgetround ();
+ switch (mode) {
+ case FP_RN: mode = 0; break;
+ case FP_RM: mode = 1; break;
+ case FP_RP: mode = 2; break;
+ case FP_RZ: mode = 3; break;
+ default:
+ die ("IEEEReal_setRoundingMode error: invalid mode %d\n", mode);
+ }
+ return mode;
+}
+
+
+#endif
1.6 +64 -13 mlton/runtime/basis/Real.c
Index: Real.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real.c,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- Real.c 25 Feb 2002 17:09:42 -0000 1.5
+++ Real.c 10 Apr 2003 02:03:12 -0000 1.6
@@ -44,7 +44,9 @@
#define Real_Class_normal 4
#define Real_Class_subnormal 5
-Int Real_class(Double d) {
+#if (defined (__i386__))
+
+Int Real_class (Double d) {
Word word0, word1;
word0 = ((Word *)&d)[0];
@@ -71,19 +73,11 @@
}
}
-Int Real_isFinite(Double d) {
- return finite(d); /* finite is from math.h */
-}
-
-inline Int Real_isNan(Double d) {
- return isnan(d); /* isnan is from math.h */
+inline Int Real_isNan (Double d) {
+ return isnan (d); /* isnan is from math.h */
}
-Int Real_qequal(Double x1, Double x2) {
- return Real_isNan(x1) || Real_isNan(x2) || x1 == x2;
-}
-
-Int Real_isNormal(Double d) {
+Int Real_isNormal (Double d) {
Word word1, exponent;
word1 = ((Word *)&d)[1];
@@ -93,7 +87,7 @@
return not(exponent == 0 or exponent == EXPONENT_MASK);
}
-Double Real_round(Double d) {
+Double Real_round (Double d) {
register double f0;
f0 = d;
@@ -103,3 +97,60 @@
return f0;
}
+
+#elif (defined __sparc__)
+
+#include <ieeefp.h>
+
+double Real_maxFinite = 1.7976931348623157e308;
+double Real_minPos = 4.94065645841246544e-324;
+double Real_minNormalPos = 2.22507385850720140e-308;
+
+Int Real_class (Double d) {
+ fpclass_t c;
+
+ c = fpclass (d);
+ switch (c) {
+ case FP_SNAN: return Real_Class_nanSignalling;
+ case FP_QNAN: return Real_Class_nanQuiet;
+ case FP_NINF: return Real_Class_inf;
+ case FP_PINF: return Real_Class_inf;
+ case FP_NDENORM: return Real_Class_subnormal;
+ case FP_PDENORM: return Real_Class_subnormal;
+ case FP_NZERO: return Real_Class_zero;
+ case FP_PZERO: return Real_Class_zero;
+ case FP_NNORM: return Real_Class_normal;
+ case FP_PNORM: return Real_Class_normal;
+ default:
+ die ("Real_class error: invalid class %d\n", c);
+ }
+}
+
+inline Int Real_isNan (Double d) {
+ fpclass_t c;
+
+ c = fpclass (d);
+ return c == FP_SNAN || c == FP_QNAN;
+}
+
+Int Real_isNormal (Double d) {
+ fpclass_t c;
+
+ c = fpclass (d);
+ return c == FP_NNORM || c == FP_PNORM || c == FP_NZERO || c == FP_PZERO;
+}
+
+Double Real_round (Double d) {
+ return rint (d);
+}
+
+#endif /* __sparc__ */
+
+Int Real_isFinite (Double d) {
+ return finite (d); /* finite is from math.h */
+}
+
+Int Real_qequal (Double x1, Double x2) {
+ return Real_isNan (x1) || Real_isNan (x2) || x1 == x2;
+}
+
1.5 +5 -1 mlton/runtime/basis/Real_const.S
Index: Real_const.S
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Real_const.S,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- Real_const.S 16 Sep 2002 18:46:26 -0000 1.4
+++ Real_const.S 10 Apr 2003 02:03:12 -0000 1.5
@@ -32,7 +32,7 @@
.long 0x00000001
.long 0x00000000
-#elif (defined (__linux__) || defined(__FreeBSD__))
+#elif (defined (__linux__) || defined (__FreeBSD__))
.data
.globl Real_maxFinite
@@ -57,6 +57,10 @@
Real_minPos:
.long 0x00000001
.long 0x00000000
+
+#elif (defined (__sun__))
+
+// Don't need to do anything, since Real.c defines these constants.
#else
1.4 +1 -1 mlton/runtime/basis/Int/quot.c
Index: quot.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/quot.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- quot.c 7 Nov 2002 19:15:06 -0000 1.3
+++ quot.c 10 Apr 2003 02:03:12 -0000 1.4
@@ -27,7 +27,7 @@
*/
Int Int_quot (Int n, Int d) {
-#if (defined (__i386__))
+#if (defined (__i386__) || defined (__sparc__))
return n / d;
#else
#error check that C / correctly implements Int.quot from the basis library
1.3 +1 -1 mlton/runtime/basis/Int/rem.c
Index: rem.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/basis/Int/rem.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- rem.c 7 Nov 2002 19:15:06 -0000 1.2
+++ rem.c 10 Apr 2003 02:03:12 -0000 1.3
@@ -3,7 +3,7 @@
/* See the comment in quot.c. */
Int Int_rem (Int n, Int d) {
-#if (defined (__i386__))
+#if (defined (__i386__) || defined (__sparc__))
return n % d;
#else
#error check that C % correctly implements Int.rem from the basis library
-------------------------------------------------------
This SF.net email is sponsored by: Etnus, makers of TotalView, The debugger
for complex code. Debugging C/C++ programs can leave you feeling lost and
disoriented. TotalView can help you find your way. Available on major UNIX
and Linux platforms. Try it free. www.etnus.com
_______________________________________________
MLton-devel mailing list
MLton-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/mlton-devel