From e9ceb566480b88dc5631ebc1b1418fde4c923ab7 Mon Sep 17 00:00:00 2001 From: Martin Elsman Date: Wed, 30 Jan 2019 11:04:15 +0100 Subject: [PATCH] MLKit 64bit (#25) MLKit now generates 64bit assembler under both Linux and macOS for all combinations of GC, Region-based memory management, and profiling. All tests are working, including the following targets: * `make mlkit` * `make mlkit_libs` * `(cd test_dev; make test)` * `(cd test; make test_mlkit)`` * `make bootstrap` There are a number of possibilities for improvements and features that are not currently included. In particular, the KAM backend, which is the basis for SMLserver, has not yet been ported. Possibilities for improvements include: * Elimination of the `gen->b` pointer (use alignment properties instead). * Inlining of allocation in regions (for the common case). * Figure out how to assign certain C callee-save registers to variables that are live across C calls. * Many peep-hole optimisations seem possible. * Eliminate the need for dynamic stack alignment on 16-byte boundaries. * Test the preliminary support for generational garbage collection. * Use conditional move instructions instead of conditional jumps when possible. * Add Word64 and Word63 modules and friends. Whenever we have WordX, we should also have IntX. We should then also modify the default word type to be Word64.word if GC is disabled and Word63.word if GC is enabled. Immediate constants of size 64 and 63 should also be supported. --- .travis.yml | 5 +- Makefile.in | 20 +- NEWS.md | 2 + README.md | 27 +- basis/Date.sml | 134 +- basis/TIME.sig | 5 +- basis/Time.sml | 81 +- src/CUtils/.gitignore | 4 +- src/CUtils/Makefile | 41 +- src/CUtils/binaryheap_test.c | 8 +- src/CUtils/binaryheap_test.out.ok | 1 + src/CUtils/hashmap.c | 16 +- src/CUtils/hashmap.h | 2 +- src/CUtils/hashmap_typed.h | 4 +- src/CUtils/hashmap_typed_test.c | 27 +- src/CUtils/hashmap_typed_test.out.ok | 3 + src/Common/KitX64.sml | 6 + src/Compiler/Backend/BACKEND_INFO.sml | 22 +- src/Compiler/Backend/LineStmt.sml | 270 +- src/Compiler/Backend/REGISTER_INFO.sml | 24 +- src/Compiler/Backend/RegAlloc.sml | 422 +-- src/Compiler/Backend/X64/.gitignore | 1 + src/Compiler/Backend/X64/CodeGenX64.sml | 3523 +++++++++++++++++++++ src/Compiler/Backend/X64/ExecutionX64.sml | 324 ++ src/Compiler/Backend/X64/INSTS_X64.sml | 166 + src/Compiler/Backend/X64/InstsX64.sml | 468 +++ src/Compiler/native64.mlb | 44 + src/Makefile.in | 47 +- src/Manager/Manager.sml | 395 +-- src/Runtime/Export.c | 34 +- src/Runtime/Export.h | 2 +- src/Runtime/Flags.h | 1 - src/Runtime/GC.c | 501 +-- src/Runtime/GC.h | 6 + src/Runtime/IO.c | 237 +- src/Runtime/Makefile.in | 21 +- src/Runtime/Math.c | 319 +- src/Runtime/Math.h | 8 +- src/Runtime/Posix.c | 82 +- src/Runtime/Posix.h | 2 +- src/Runtime/Profiling.c | 592 ++-- src/Runtime/Profiling.h | 25 +- src/Runtime/Region.c | 323 +- src/Runtime/Region.h | 116 +- src/Runtime/Runtime.c | 169 +- src/Runtime/String.c | 117 +- src/Runtime/Table.c | 31 +- src/Runtime/Table.h | 28 +- src/Runtime/Time.c | 38 +- src/Tools/Rp2ps/Makefile.in | 4 +- src/Tools/Tester/Tester.sml | 84 +- test/Makefile | 2 +- test/filesys.sml | 79 +- test/opaque2.sml.out.ok | 1 + test/textio.sml.out.ok | 7 +- test_dev/.gitignore | 8 + test_dev/Initial.out.ok | 16 + test_dev/Initial.sml | 342 ++ test_dev/Makefile | 244 ++ test_dev/README_KAM.md | 43 + test_dev/README_X64.md | 50 + test_dev/a.mlb | 2 + test_dev/a.mlbout.ok | 2 + test_dev/a1.out.ok | 1 + test_dev/a1.sml | 2 +- test_dev/a2.sml | 2 +- test_dev/auto.out.ok | 1 + test_dev/auto.sml | 10 + test_dev/b.mlb | 2 + test_dev/b.mlbout.ok | 2 + test_dev/b2.sml | 8 +- test_dev/b3.out.ok | 1 + test_dev/b3.sml | 8 + test_dev/build.out.ok | 12 + test_dev/build.sml | 38 + test_dev/c.mlb | 2 + test_dev/c.mlbout.ok | 1 + test_dev/c1.sml | 1 + test_dev/c2.sml | 14 + test_dev/ccall.out.ok | 1 + test_dev/ccall.sml | 11 + test_dev/empty.sml | 1 + test_dev/exception1.out.ok | 1 + test_dev/exception1.sml | 14 +- test_dev/exception2.sml | 34 +- test_dev/exception3.out.ok | 1 + test_dev/exception3.sml | 18 +- test_dev/exception4.out.ok | 6 + test_dev/exception4.sml | 20 +- test_dev/exception5.out.ok | 9 + test_dev/exception5.sml | 16 +- test_dev/exn1.out.ok | 1 + test_dev/exn2.out.ok | 1 + test_dev/exn2.sml | 4 +- test_dev/exn3.out.ok | 1 + test_dev/exn3.sml | 4 +- test_dev/exn4.out.ok | 6 + test_dev/exn4.sml | 10 +- test_dev/f1.out.ok | 11 + test_dev/f1.sml | 6 +- test_dev/f2.out.ok | 3 + test_dev/f2.sml | 6 +- test_dev/fft_no_basislib.out.ok | 4 + test_dev/fft_no_basislib.sml | 94 +- test_dev/fib.out.ok | 357 +++ test_dev/fib.sml | 20 +- test_dev/fib0.out.ok | 1 + test_dev/fib0.sml | 4 +- test_dev/foldl.out.ok | 5 + test_dev/global_region.out.ok | 0 test_dev/hanoi.out.ok | 3071 ++++++++++++++++++ test_dev/hanoi.sml | 6 +- test_dev/hello.out.ok | 1 + test_dev/hello.sml | 10 +- test_dev/if.out.ok | 1 + test_dev/if.sml | 2 +- test_dev/immedString.out.ok | 1 + test_dev/immedString.sml | 2 +- test_dev/int_first.out.ok | 3 + test_dev/int_first.sml | 24 + test_dev/int_overflow.out.ok | 5 + test_dev/int_overflow.sml | 19 + test_dev/kitkbjul9_no_basislib.out.ok | 819 +++++ test_dev/kitkbjul9_no_basislib.sml | 779 +++-- test_dev/kitlife35u_no_basislib.out.ok | 534 ++++ test_dev/kitlife35u_no_basislib.sml | 399 ++- test_dev/kitqsort_no_basislib.out.ok | 1 + test_dev/kitqsort_no_basislib.sml | 31 +- test_dev/kitreynolds2_no_basislib.out.ok | 1 + test_dev/kitreynolds2_no_basislib.sml | 73 +- test_dev/kitreynolds3_no_basislib.out.ok | 1 + test_dev/kitreynolds3_no_basislib.sml | 76 +- test_dev/kitsimple_no_basislib.out.ok | 22 + test_dev/kitsimple_no_basislib.sml | 290 +- test_dev/kittmergesort_no_basislib.out.ok | 6 + test_dev/kittmergesort_no_basislib.sml | 36 +- test_dev/l1.out.ok | 1 + test_dev/l1.sml | 4 +- test_dev/list_nh.out.ok | 20 + test_dev/list_nh.sml | 10 +- test_dev/p1.sml | 13 + test_dev/professor_game.out.ok | 230 ++ test_dev/professor_game.sml | 157 +- test_dev/r.c | 9 + test_dev/raise_div.out.ok | 1 + test_dev/raise_div.sml | 1 + test_dev/raise_maybe.sml | 5 + test_dev/real0.out.ok | 2 + test_dev/real0.sml | 19 + test_dev/real1.out.ok | 7 + test_dev/real1.sml | 6 +- test_dev/real2.out.ok | 11 + test_dev/real2.sml | 29 +- test_dev/real_cmp.out.ok | 10 + test_dev/real_cmp.sml | 27 + test_dev/real_negabs.out.ok | 12 + test_dev/real_negabs.sml | 31 + test_dev/ref-int.out.ok | 3025 ++++++++++++++++++ test_dev/ref-int.sml | 13 +- test_dev/ref-real.out.ok | 3 + test_dev/ref-real.sml | 57 +- test_dev/ref.out.ok | 1 + test_dev/ref.sml | 6 +- test_dev/reg.out.ok | 1 + test_dev/reg.sml | 135 + test_dev/shra.out.ok | 5 + test_dev/shra.sml | 50 + test_dev/sign.out.ok | 5 + test_dev/sign.sml | 24 + test_dev/string1.out.ok | 1 + test_dev/string1.sml | 6 +- test_dev/string_sub.out.ok | 4 + test_dev/string_sub.sml | 43 + test_dev/string_upd.out.ok | 2 + test_dev/string_upd.sml | 30 + test_dev/string_update.out.ok | 17 + test_dev/string_update.sml | 79 + test_dev/strs.sml | 8 +- test_dev/test_dattyp.out.ok | 1501 +++++++++ test_dev/test_dattyp.sml | 4 +- test_dev/testdyn1-nobasis.out.ok | 92 + test_dev/testdyn1-nobasis.sml | 323 ++ test_dev/word_list.out.ok | 4 + test_dev/word_list.sml | 34 + to_do | 69 +- 185 files changed, 19462 insertions(+), 3301 deletions(-) create mode 100644 src/CUtils/binaryheap_test.out.ok create mode 100644 src/CUtils/hashmap_typed_test.out.ok create mode 100644 src/Common/KitX64.sml create mode 100644 src/Compiler/Backend/X64/.gitignore create mode 100644 src/Compiler/Backend/X64/CodeGenX64.sml create mode 100644 src/Compiler/Backend/X64/ExecutionX64.sml create mode 100644 src/Compiler/Backend/X64/INSTS_X64.sml create mode 100644 src/Compiler/Backend/X64/InstsX64.sml create mode 100644 src/Compiler/native64.mlb create mode 100644 test_dev/.gitignore create mode 100644 test_dev/Initial.out.ok create mode 100644 test_dev/Initial.sml create mode 100644 test_dev/Makefile create mode 100644 test_dev/README_KAM.md create mode 100644 test_dev/README_X64.md create mode 100644 test_dev/a.mlb create mode 100644 test_dev/a.mlbout.ok create mode 100644 test_dev/a1.out.ok create mode 100644 test_dev/auto.out.ok create mode 100644 test_dev/auto.sml create mode 100644 test_dev/b.mlb create mode 100644 test_dev/b.mlbout.ok create mode 100644 test_dev/b3.out.ok create mode 100644 test_dev/b3.sml create mode 100644 test_dev/build.out.ok create mode 100644 test_dev/build.sml create mode 100644 test_dev/c.mlb create mode 100644 test_dev/c.mlbout.ok create mode 100644 test_dev/c1.sml create mode 100644 test_dev/c2.sml create mode 100644 test_dev/ccall.out.ok create mode 100644 test_dev/ccall.sml create mode 100644 test_dev/empty.sml create mode 100644 test_dev/exception1.out.ok create mode 100644 test_dev/exception3.out.ok create mode 100644 test_dev/exception4.out.ok create mode 100644 test_dev/exception5.out.ok create mode 100644 test_dev/exn1.out.ok create mode 100644 test_dev/exn2.out.ok create mode 100644 test_dev/exn3.out.ok create mode 100644 test_dev/exn4.out.ok create mode 100644 test_dev/f1.out.ok create mode 100644 test_dev/f2.out.ok create mode 100644 test_dev/fft_no_basislib.out.ok create mode 100644 test_dev/fib.out.ok create mode 100644 test_dev/fib0.out.ok create mode 100644 test_dev/foldl.out.ok create mode 100644 test_dev/global_region.out.ok create mode 100644 test_dev/hanoi.out.ok create mode 100644 test_dev/hello.out.ok create mode 100644 test_dev/if.out.ok create mode 100644 test_dev/immedString.out.ok create mode 100644 test_dev/int_first.out.ok create mode 100644 test_dev/int_first.sml create mode 100644 test_dev/int_overflow.out.ok create mode 100644 test_dev/int_overflow.sml create mode 100644 test_dev/kitkbjul9_no_basislib.out.ok create mode 100644 test_dev/kitlife35u_no_basislib.out.ok create mode 100644 test_dev/kitqsort_no_basislib.out.ok create mode 100644 test_dev/kitreynolds2_no_basislib.out.ok create mode 100644 test_dev/kitreynolds3_no_basislib.out.ok create mode 100644 test_dev/kitsimple_no_basislib.out.ok create mode 100644 test_dev/kittmergesort_no_basislib.out.ok create mode 100644 test_dev/l1.out.ok create mode 100644 test_dev/list_nh.out.ok create mode 100644 test_dev/p1.sml create mode 100644 test_dev/professor_game.out.ok create mode 100644 test_dev/r.c create mode 100644 test_dev/raise_div.out.ok create mode 100644 test_dev/raise_div.sml create mode 100644 test_dev/raise_maybe.sml create mode 100644 test_dev/real0.out.ok create mode 100644 test_dev/real0.sml create mode 100644 test_dev/real1.out.ok create mode 100644 test_dev/real2.out.ok create mode 100644 test_dev/real_cmp.out.ok create mode 100644 test_dev/real_cmp.sml create mode 100644 test_dev/real_negabs.out.ok create mode 100644 test_dev/real_negabs.sml create mode 100644 test_dev/ref-int.out.ok create mode 100644 test_dev/ref-real.out.ok create mode 100644 test_dev/ref.out.ok create mode 100644 test_dev/reg.out.ok create mode 100644 test_dev/reg.sml create mode 100644 test_dev/shra.out.ok create mode 100644 test_dev/shra.sml create mode 100644 test_dev/sign.out.ok create mode 100644 test_dev/sign.sml create mode 100644 test_dev/string1.out.ok create mode 100644 test_dev/string_sub.out.ok create mode 100644 test_dev/string_sub.sml create mode 100644 test_dev/string_upd.out.ok create mode 100644 test_dev/string_upd.sml create mode 100644 test_dev/string_update.out.ok create mode 100644 test_dev/string_update.sml create mode 100644 test_dev/test_dattyp.out.ok create mode 100644 test_dev/testdyn1-nobasis.out.ok create mode 100644 test_dev/testdyn1-nobasis.sml create mode 100644 test_dev/word_list.out.ok create mode 100644 test_dev/word_list.sml diff --git a/.travis.yml b/.travis.yml index e9edf998a..7da457566 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,8 +29,9 @@ install: - make mlkit_bin_dist script: - - cd test && make test_mlkit - - cd ../js/test && make test + - make -C test_dev test + - make -C test test_mlkit + - make -C js/test test deploy: provider: releases diff --git a/Makefile.in b/Makefile.in index 57f8c07fe..d388a79a6 100644 --- a/Makefile.in +++ b/Makefile.in @@ -3,6 +3,8 @@ SHELL=@SHELL@ KITVERSION=@PACKAGE_VERSION@ prefix=@prefix@ +datarootdir=@datarootdir@ +datadir=@datadir@ srcdir=@srcdir@ top_srcdir=@top_srcdir@ exec_prefix=@exec_prefix@ @@ -162,7 +164,7 @@ clean: cd ml-yacc-lib && $(CLEAN) cd kitdemo && $(CLEAN) run */*~ cd test && $(MAKE) clean - cd test_dev && $(CLEAN) run *.out *.log + cd test_dev && $(MAKE) clean cd src && $(MAKE) clean $(MAKE) -C smlserver_demo clean cd smlserver && $(CLEAN) @@ -291,6 +293,7 @@ install_src: $(MKDIR) $(INSTDIR)/src/Compiler/Backend $(INSTDIR)/src/Compiler/Lambda $(INSTDIR)/src/Compiler/Regions $(MKDIR) $(INSTDIR)/src/Compiler/Backend/Barry $(INSTDIR)/src/Compiler/Backend/Dummy $(INSTDIR)/src/Compiler/Backend/KAM $(MKDIR) $(INSTDIR)/src/Compiler/Backend/X86 + $(MKDIR) $(INSTDIR)/src/Compiler/Backend/X64 $(MKDIR) $(INSTDIR)/src/Tools/Benchmark $(INSTDIR)/src/Tools/GenOpcodes $(INSTDIR)/src/Tools/MlbMake $(INSTDIR)/src/Tools/Rp2ps $(MKDIR) $(INSTDIR)/src/Tools/Tester $(INSTDIR)/src/Tools/MspComp $(INSTALLDATA) src/Makefile src/*.{sml,in} $(INSTDIR)/src @@ -304,6 +307,7 @@ install_src: $(INSTALLDATA) src/Compiler/Backend/Dummy/*.sml $(INSTDIR)/src/Compiler/Backend/Dummy $(INSTALLDATA) src/Compiler/Backend/KAM/*.{sml,spec} $(INSTDIR)/src/Compiler/Backend/KAM $(INSTALLDATA) src/Compiler/Backend/X86/*.sml $(INSTDIR)/src/Compiler/Backend/X86 + $(INSTALLDATA) src/Compiler/Backend/X64/*.sml $(INSTDIR)/src/Compiler/Backend/X64 $(INSTALLDATA) src/Manager/*.{sml,sig,mlb} $(INSTDIR)/src/Manager $(INSTALLDATA) src/Kitlib/*.{sml,sig,mlb} $(INSTDIR)/src/Kitlib $(INSTALLDATA) src/Pickle/*.{sml,sig,mlb} $(INSTDIR)/src/Pickle @@ -333,7 +337,7 @@ bootstrap_first: bootstrap_next_build: cd src && $(MAKE) genopcodes BINDIR=../$(BINDIR) - cd src/Compiler && SML_LIB=$(CWD) ../../bin/mlkit -gc native.mlb + cd src/Compiler && SML_LIB=$(CWD) ../../bin/mlkit -gc native64.mlb bootstrap_next_install: $(MAKE) install_top @@ -386,9 +390,9 @@ man_smltojs: # $ ./configure # $ make all # ----------------------------------------------------- -MLKIT_DIST_BIN=mlkit-$(KITVERSION)-x86 -.PHONY: mlkit_x86_tgz -mlkit_x86_tgz: +MLKIT_DIST_BIN=mlkit-$(KITVERSION)-x64 +.PHONY: mlkit_x64_tgz +mlkit_x64_tgz: $(MKDIR) dist rm -rf dist/$(MLKIT_DIST_BIN) $(MAKE) install0 DESTDIR=$(CWD)/dist/$(MLKIT_DIST_BIN) prefix= @@ -403,9 +407,9 @@ mlkit_x86_tgz: # $ make smltojs # $ make smltojs_basislibs # ----------------------------------------------------- -SMLTOJS_DIST_BIN=smltojs-$(KITVERSION)-x86 -.PHONY: smltojs_x86_tgz -smltojs_x86_tgz: +SMLTOJS_DIST_BIN=smltojs-$(KITVERSION)-x64 +.PHONY: smltojs_x64_tgz +smltojs_x64_tgz: $(MKDIR) dist rm -rf dist/$(SMLTOJS_DIST_BIN) $(MAKE) install_smltojs0 DESTDIR=$(CWD)/dist/$(SMLTOJS_DIST_BIN) prefix= diff --git a/NEWS.md b/NEWS.md index 2558d2264..566728838 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ ## MLKit NEWS +* mael 2019-01-22: MLKit now uses a native 64bit backend. + * mael 2018-08-25: Support for automatic deployment of binary builds. ### MLKit version 4.3.12 is released diff --git a/README.md b/README.md index c9e8314c2..76c2a5810 100644 --- a/README.md +++ b/README.md @@ -11,6 +11,13 @@ Library. [![Issue Stats](http://issuestats.com/github/melsman/mlkit/badge/issue)](http://issuestats.com/github/melsman/mlkit) [![Build Status](https://travis-ci.org/melsman/mlkit.svg?branch=master)](https://travis-ci.org/melsman/mlkit) +## Installation + +Under macOS, MLKit is available through Homebrew: Just execute `brew +install mlkit`. Under Linux, you may install a binary version of MLKit +using an [mlkit PPA from Launchpad](https://launchpad.net/~pmunksgaard/+archive/ubuntu/mlkit). + + ## MLKit Features * Covers all of Standard ML. The MLKit compiles all of Standard ML, @@ -33,10 +40,10 @@ Library. this respect. * Reference-tracing Garbage Collection: The MLKit supports - reference-tracing garbage collection in combination with region + reference-tracing garbage collection in combination with region-based memory management. -* Native backend for the x86 architecture. +* Native backend for the x64 architecture (under Linux and macOS). * [Documentation](http://www.elsman.com/mlkit/doc.html). A comprehensive guide on programming with the MLKit is @@ -69,7 +76,7 @@ for details. The runtime system (`/src/Runtime/`) and libraries To compile, install, and use the MLKit, a Linux box running Ubuntu Linux, Debian, gentoo, or similar is needed. The MLKit also works on -Mac OS and has also earlier been reported to run on the FreeBSD/x86 +macOS and has also earlier been reported to run on the FreeBSD/x86 platform, with a little tweaking. To compile the MLKit, a Standard ML compiler is needed, which needs to @@ -137,7 +144,7 @@ Execute the following command: $ make mlkit_libs ```` -## Installation +## Installation after Compilation For a system wide installation of the MLKit, installation including man-pages and tools, execute the command: @@ -155,13 +162,15 @@ $ make install To build a binary package, execute the command ````bash -$ make mlkit_i386_tgz +$ make mlkit_x64_tgz ```` -This command leaves a package `mlkit-X.Y.Z-i386.tgz` in the `dist/` +This command leaves a package `mlkit-X.Y.Z-x64.tgz` in the `dist/` directory. For building a binary package, the installation step above is not needed and the bootstrapping step is optional. +For building packages containing both MLKit and SMLtoJs, consult the Makefile. + ## Try It To test the installation, copy the directory `/usr/share/mlkit/kitdemo` to @@ -188,7 +197,7 @@ and `man/man1`. License information is located in the file ## Comments and Bug Reports -The MLKit has a number of [known bugs and limitations](http://www.elsman.com/mlkit/bugs.html). To file a bug-report, create an issue at the Github page. +The MLKit has a number of [known bugs and limitations](http://elsman.com/mlkit/bugs.html). To file a bug-report, create an issue at the Github page. ## Appendix A: Directory Structure of the Sources @@ -214,7 +223,7 @@ After having checked out the sources from Github, execute the command: $ ./autobuild ```` -To compile and install the MLKit, execute the following commands: +To compile the MLKit, execute the following commands: ````bash $ ./configure $ make mlkit @@ -222,6 +231,8 @@ $ make bootstrap $ make mlkit_libs ```` +The `make bootstrap` command is optional. + To install the MLKit and related tools, execute: ````bash $ sudo make install diff --git a/basis/Date.sml b/basis/Date.sml index 567cedc3d..c610eff8a 100644 --- a/basis/Date.sml +++ b/basis/Date.sml @@ -18,7 +18,7 @@ structure Date :> DATE = wday : weekday, yday : int, (* 0-365 *) isDst : bool option, (* daylight savings time in force *) - offset : int option (* signed seconds East of UTC: this + offset : int option (* signed seconds East of UTC: this zone = UTC+t; ~43200 < t <= 43200 *) } @@ -31,7 +31,7 @@ structure Date :> DATE = tm_mday : int, tm_min : int, tm_mon : int, - tm_sec : int, + tm_sec : int, tm_wday : int, tm_yday : int, tm_year : int @@ -47,13 +47,13 @@ structure Date :> DATE = local val asctime_exn = Initial.fail_asctime val strftime_exn = Initial.fail_strftime in fun asctime_ (t : tmoz) : string = prim("sml_asctime", (t,asctime_exn)) - fun strftime_ (s : string, t : tmoz) : string = prim("sml_strftime", (s,t,strftime_exn)) + fun strftime_ (s : string, t : tmoz) : string = prim("sml_strftime", (s,t,Overflow(*strftime_exn*))) end val toweekday = fn 0 => Sun | 1 => Mon | 2 => Tue | 3 => Wed - | 4 => Thu | 5 => Fri | 6 => Sat + | 4 => Thu | 5 => Fri | 6 => Sat | _ => raise Fail "Internal error: Date.toweekday"; - val fromwday = fn Sun => 0 | Mon => 1 | Tue => 2 | Wed => 3 + val fromwday = fn Sun => 0 | Mon => 1 | Tue => 2 | Wed => 3 | Thu => 4 | Fri => 5 | Sat => 6; val tomonth = fn 0 => Jan | 1 => Feb | 2 => Mar | 3 => Apr | 4 => May | 5 => Jun | 6 => Jul | 7 => Aug @@ -62,32 +62,32 @@ structure Date :> DATE = val frommonth = fn Jan => 0 | Feb => 1 | Mar => 2 | Apr => 3 | May => 4 | Jun => 5 | Jul => 6 | Aug => 7 | Sep => 8 | Oct => 9 | Nov => 10 | Dec => 11; - + fun tmozToDate {tm_hour, tm_isdst, tm_mday, tm_min, tm_mon, tm_sec, - tm_wday, tm_yday, tm_year} offset = - DATE {year = tm_year + 1900, month = tomonth tm_mon, - day = tm_mday, hour = tm_hour, minute = tm_min, + tm_wday, tm_yday, tm_year} offset = + DATE {year = tm_year + 1900, month = tomonth tm_mon, + day = tm_mday, hour = tm_hour, minute = tm_min, second = tm_sec, wday = toweekday tm_wday, - yday = tm_yday, - isDst = (case tm_isdst of 0 => SOME false + yday = tm_yday, + isDst = (case tm_isdst of 0 => SOME false | 1 => SOME true | _ => NONE), offset = offset } - fun leapyear y = y mod 4 = 0 andalso y mod 100 <> 0 orelse y mod 400 = 0 + fun leapyear y = y mod 4 = 0 andalso y mod 100 <> 0 orelse y mod 400 = 0 - fun monthdays year month = + fun monthdays year month = case month of Jan => 31 | Mar => 31 | May => 31 | Jul => 31 | Aug => 31 | Oct => 31 | Dec => 31 | Feb => if leapyear year then 29 else 28 - | Apr => 30 | Jun => 30 | Sep => 30 | Nov => 30 + | Apr => 30 | Jun => 30 | Sep => 30 | Nov => 30 fun yeardays year = if leapyear year then 366 else 365 (* Check whether date may be passed to ISO/ANSI C functions: *) fun okDate (DATE {year, month, day, hour, minute, second, ...}) = - 1900 <= year + 1900 <= year andalso 1 <= day andalso day <= monthdays year month andalso 0 <= hour andalso hour <= 23 andalso 0 <= minute andalso minute <= 59 @@ -95,12 +95,12 @@ structure Date :> DATE = fun dateToTmoz (dt as DATE {year, month, day, hour, minute, second, wday, yday, isDst, offset}) = - if okDate dt then - {tm_hour = hour, tm_mday = day, tm_min = minute, - tm_mon = frommonth month, tm_sec = second, - tm_year = year - 1900, + if okDate dt then + {tm_hour = hour, tm_mday = day, tm_min = minute, + tm_mon = frommonth month, tm_sec = second, + tm_year = year - 1900, tm_isdst = case isDst of SOME false=>0 | SOME true=>1 | NONE=> ~1, - tm_wday = fromwday wday, tm_yday = yday} + tm_wday = fromwday wday, tm_yday = yday} else raise Date; @@ -109,22 +109,22 @@ structure Date :> DATE = (* Reingold: Number of the day within the year: *) - fun dayinyear year month day = + fun dayinyear year month day = let val monthno = frommonth month in day - 1 + 31 * monthno - - (if monthno > 1 then + - (if monthno > 1 then (27 + 4 * monthno) div 10 - (if leapyear year then 1 else 0) else 0) end (* Reingold: Find the number of days elapsed from the (imagined) Gregorian date Sunday, December 31, 1 BC to the given date. *) - - fun todaynumber year month day = + + fun todaynumber year month day = let val prioryears = year - 1 in - dayinyear year month day + dayinyear year month day + 1 + 365 * prioryears + prioryears div 4 @@ -134,7 +134,7 @@ structure Date :> DATE = (* Reingold et al: from absolute day number to year, month, date: *) - fun fromdaynumber n = + fun fromdaynumber n = let val d0 = n - 1 val n400 = d0 div 146097 val d1 = d0 mod 146097 @@ -147,23 +147,23 @@ structure Date :> DATE = val year = 400 * n400 + 100 * n100 + n4 * 4 + n1 + 1 fun loop month day = let val mdays = monthdays year (tomonth month) - in + in if mdays < day then loop (month+1) (day-mdays) else (year, tomonth month, day) end - in - if n100 = 4 orelse n1 = 4 then + in + if n100 = 4 orelse n1 = 4 then (year-1, Dec, 31) else - loop 0 day - end + loop 0 day + end (* -------------------------------------------------- *) fun weekday daynumber = toweekday (daynumber mod 7) (* Normalize a date, disregarding leap seconds: *) - + fun normalizedate yr0 mo0 dy0 hr0 mn0 sec0 offset = let val mn1 = mn0 + sec0 div 60 val second = sec0 mod 60 @@ -182,10 +182,10 @@ structure Date :> DATE = wday = weekday dayno, yday = dayinyear year month day, offset = offset, - isDst = case offset of - NONE => NONE + isDst = case offset of + NONE => NONE | SOME _ => SOME false } - in + in (* One cannot reliably compute DST in non-local timezones, not even given the offset from UTC. Countries in the Northern hemisphere have DST during Mar-Oct, those around @@ -193,25 +193,25 @@ structure Date :> DATE = hemisphere have DST during Oct-Mar. *) if year < 1970 orelse year > 2037 then date1 - else - case offset of - NONE => + else + case offset of + NONE => tmozToDate (getlocaltime_ (mktime_ (dateToTmoz date1))) offset | SOME t => date1 end - fun fromTimeLocal t = + fun fromTimeLocal t = tmozToDate (getlocaltime_ (Time.toReal t)) NONE; - fun fromTimeUniv t = + fun fromTimeUniv t = tmozToDate (getunivtime_ (Time.toReal t)) (SOME 0); - (* The following implements conversion from a local date to + (* The following implements conversion from a local date to a Time.time. It IGNORES wday and yday. *) - fun toTime (date as DATE {offset, ...}) = - let val secoffset = + fun toTime (date as DATE {offset, ...}) = + let val secoffset = case offset of NONE => 0.0 | SOME secs => localoffset + real secs @@ -224,12 +224,12 @@ structure Date :> DATE = fun localOffset () = Time.fromSeconds (LargeInt.fromInt(Real.round localoffset mod 86400)) fun toString date = - String.substring(asctime_ (dateToTmoz date), 0, 24) + String.substring(asctime_ (dateToTmoz date), 0, 24) handle Fail _ => raise Date | Subscript => raise (Fail "Date.toString: internal error"); fun fmt fmtstr date = - (strftime_ (fmtstr, dateToTmoz date)) + (strftime_ (fmtstr, dateToTmoz date)) handle Fail _ => raise Date (* To scan dates in the format "Wed Mar 8 19:06:45 1995" *) @@ -237,7 +237,7 @@ structure Date :> DATE = exception BadFormat; fun getVal (SOME v) = v | getVal NONE = raise BadFormat; - + fun scan getc src = let val getstring = StringCvt.splitl Char.isAlpha getc fun getint src = getVal (Int.scan StringCvt.DEC getc src) @@ -247,11 +247,11 @@ structure Date :> DATE = val getMonth = fn "Jan" => Jan | "Feb" => Feb | "Mar" => Mar | "Apr" => Apr | "May" => May | "Jun" => Jun | "Jul" => Jul | "Aug" => Aug | "Sep" => Sep - | "Oct" => Oct | "Nov" => Nov | "Dec" => Dec + | "Oct" => Oct | "Nov" => Nov | "Dec" => Dec | _ => raise BadFormat val getWday = fn "Sun" => Sun | "Mon" => Mon | "Tue" => Tue | "Wed" => Wed | "Thu" => Thu | "Fri" => Fri - | "Sat" => Sat + | "Sat" => Sat | _ => raise BadFormat val (wday, src1) = getstring src @@ -263,10 +263,10 @@ structure Date :> DATE = val (year, src7) = getint src6 val month = getMonth month in SOME (DATE {year = year, month = month, - day = day, hour = hour, minute = min, - second = sec, wday = getWday wday, - yday = dayinyear year month day, - isDst = NONE, offset = NONE}, src7) + day = day, hour = hour, minute = min, + second = sec, wday = getWday wday, + yday = dayinyear year month day, + isDst = NONE, offset = NONE}, src7) end handle BadFormat => NONE @@ -274,17 +274,17 @@ structure Date :> DATE = (* Ignore timezone and DST when comparing dates: *) - fun compare + fun compare (DATE {year=y1,month=mo1,day=d1,hour=h1,minute=mi1,second=s1, ...}, DATE {year=y2,month=mo2,day=d2,hour=h2,minute=mi2,second=s2, ...}) = - let fun cmp(v1, v2, cmpnext) = - if v1 < v2 then LESS + let fun cmp(v1, v2, cmpnext) = + if v1 < v2 then LESS else if v1 > v2 then GREATER else (* EQUAL *) cmpnext () - in - cmp(y1, y2, - fn _ => cmp(frommonth mo1, frommonth mo2, - fn _ => cmp(d1, d2, + in + cmp(y1, y2, + fn _ => cmp(frommonth mo1, frommonth mo2, + fn _ => cmp(d1, d2, fn _ => cmp(h1, h2, fn _ => cmp(mi1, mi2, fn _ => cmp(s1, s2, @@ -292,14 +292,14 @@ structure Date :> DATE = end fun date { year, month, day, hour, minute, second, offset } = - if year < 0 then raise Date + if year < 0 then raise Date else - let val (dayoffset, offset') = + let val (dayoffset, offset') = case offset of NONE => (0, NONE) - | SOME time => + | SOME time => let val secs = LargeInt.toInt(Time.toSeconds time) - val secoffset = + val secoffset = if secs <= 43200 then ~secs else 86400 - secs in (Int.quot(secs, 86400), SOME secoffset) end val day' = day + dayoffset @@ -308,9 +308,9 @@ structure Date :> DATE = end fun year (DATE { year, ... }) = year - + fun month (DATE { month, ... }) = month - + fun day (DATE { day, ... }) = day fun hour (DATE { hour, ... }) = hour @@ -325,7 +325,7 @@ structure Date :> DATE = fun isDst (DATE { isDst, ... }) = isDst - fun offset (DATE { offset, ... }) = - Option.map (fn secs => Time.fromSeconds (LargeInt.fromInt((86400 + secs) mod 86400))) + fun offset (DATE { offset, ... }) = + Option.map (fn secs => Time.fromSeconds (LargeInt.fromInt((86400 + secs) mod 86400))) offset end diff --git a/basis/TIME.sig b/basis/TIME.sig index 0ac768556..63311f9af 100644 --- a/basis/TIME.sig +++ b/basis/TIME.sig @@ -29,7 +29,8 @@ signature TIME = val toString : time -> string val scan : (char, 'a) StringCvt.reader -> (time, 'a) StringCvt.reader - val fromString : string -> time option + val fromString : string -> time option + val toPair : time -> {sec:int, usec : int} end (* @@ -144,7 +145,7 @@ fromString s recognize a number of seconds specified as a string that matches the regular expression: - [+~-]?([0-9]+.[0-9]+? | .[0-9]+) + [+~-]?([0-9]+.[0-9]+? | .[0-9]+) Initial whitespace is ignored. Both functions raise Time when the value is syntactically correct but not representable. diff --git a/basis/Time.sml b/basis/Time.sml index 1b35d70ab..2c3cf2a69 100644 --- a/basis/Time.sml +++ b/basis/Time.sml @@ -13,7 +13,7 @@ structure Time : TIME = type time = {sec : int, usec : int} (* Invariant: sec >= timebase and 0 <= usec < 1000000. - Represents the duration (sec-timebase)+usec/1000000 seconds; + Represents the duration (sec-timebase)+usec/1000000 seconds; or the duration since UTC 00:00 on 1 Jan 1970). *) @@ -22,33 +22,33 @@ structure Time : TIME = val zeroTime = {sec = timebase, usec = 0}; fun now () = getrealtime (); - fun fromSeconds s = + fun fromSeconds s = if IntInf.<(s, 0) then raise Time else {sec=LargeInt.toInt s + timebase, usec=0}; - fun fromMilliseconds ms = - if IntInf.<(ms, 0) then raise Time else + fun fromMilliseconds ms = + if IntInf.<(ms, 0) then raise Time else {sec=LargeInt.toInt ms div 1000+timebase, usec=LargeInt.toInt ms mod 1000 * 1000} - fun fromMicroseconds us = - if IntInf.<(us, 0) then raise Time else + fun fromMicroseconds us = + if IntInf.<(us, 0) then raise Time else {sec=LargeInt.toInt us div 1000000+timebase, usec=LargeInt.toInt us mod 1000000} - fun toSeconds {sec, usec} = + fun toSeconds {sec, usec} = IntInf.-(LargeInt.fromInt sec, LargeInt.fromInt timebase) - fun toMilliseconds {sec, usec} = - IntInf.+(IntInf.*(IntInf.-(LargeInt.fromInt sec, LargeInt.fromInt timebase), 1000), + fun toMilliseconds {sec, usec} = + IntInf.+(IntInf.*(IntInf.-(LargeInt.fromInt sec, LargeInt.fromInt timebase), 1000), IntInf.div(LargeInt.fromInt usec, 1000)) - fun toMicroseconds {sec, usec} = + fun toMicroseconds {sec, usec} = IntInf.+(IntInf.*(IntInf.-(LargeInt.fromInt sec, LargeInt.fromInt timebase), 1000000), LargeInt.fromInt usec) - fun fromReal r = - let + fun fromReal r = + let val rf = if r < 0.0 then raise Time else floor (r + real timebase) in - {sec = rf, usec = floor (1000000.0 * (r+real timebase-real rf))} + {sec = rf, usec = floor (1000000.0 * (r+real timebase-real rf))} end handle Overflow => raise Time; fun toReal {sec, usec} = @@ -61,17 +61,17 @@ structure Time : TIME = (* Y2004 bug-fix fun fmt p {sec, usec} = - let fun frac r = r - real (floor r) - val rnd = if p < 0 then 0.5 - else 0.5 * negpow10 p + let fun frac r = r - real (floor r) + val rnd = if p < 0 then 0.5 + else 0.5 * negpow10 p val usecr = real usec / 1000000.0 + rnd val ints = Int.toString (sec - timebase + floor usecr) fun h v i = if i <= 0 then [] - else Char.chr (floor v + Char.ord #"0") + else Char.chr (floor v + Char.ord #"0") :: h (10.0 * frac v) (i-1) - in - if p > 0 then - ints ^ "." ^ String.implode (h (10.0 * frac usecr) + in + if p > 0 then + ints ^ "." ^ String.implode (h (10.0 * frac usecr) (if p > 6 then 6 else p)) else ints end; @@ -79,7 +79,7 @@ structure Time : TIME = fun toString t = fmt 3 t; fun scan getc source = - let fun skipWSget getc source = + let fun skipWSget getc source = getc (StringCvt.dropl Char.isSpace getc source) fun decval c = Char.ord c - 48; fun pow10 0 = 1 @@ -87,40 +87,40 @@ structure Time : TIME = fun mktime intgv decs fracv = let val usecs = (pow10 (7-decs) * fracv + 5) div 10 in - {sec = floor(intgv+real timebase+0.5) + usecs div 1000000, + {sec = floor(intgv+real timebase+0.5) + usecs div 1000000, usec = usecs mod 1000000} end fun skipdigs src = - case getc src of + case getc src of NONE => src - | SOME(c, rest) => if Char.isDigit c then skipdigs rest + | SOME(c, rest) => if Char.isDigit c then skipdigs rest else src fun frac intgv decs fracv src = if decs >= 7 then SOME(mktime intgv decs fracv, skipdigs src) else case getc src of NONE => SOME(mktime intgv decs fracv, src) - | SOME(c, rest) => - if Char.isDigit c then + | SOME(c, rest) => + if Char.isDigit c then frac intgv (decs+1) (10 * fracv + decval c) rest - else + else SOME(mktime intgv decs fracv, src) - fun intg intgv src = + fun intg intgv src = case getc src of NONE => SOME(mktime intgv 6 0, src) | SOME (#".", rest) => frac intgv 0 0 rest - | SOME (c, rest) => - if Char.isDigit c then - intg (10.0 * intgv + real(decval c)) rest + | SOME (c, rest) => + if Char.isDigit c then + intg (10.0 * intgv + real(decval c)) rest else SOME(mktime intgv 6 0, src) in case skipWSget getc source of NONE => NONE - | SOME(#".", rest) => + | SOME(#".", rest) => (case getc rest of NONE => NONE - | SOME(c, rest) => + | SOME(c, rest) => if Char.isDigit c then frac 0.0 1 (decval c) rest else NONE) - | SOME(c, rest) => + | SOME(c, rest) => if Char.isDigit c then intg (real (decval c)) rest else NONE end; @@ -128,22 +128,22 @@ structure Time : TIME = val op + = fn ({sec=sec1, usec=usec1} : time, {sec=sec2, usec=usec2}) => let val usecs = usec1 + usec2 in - {sec = trunc(real sec1 - real timebase + {sec = trunc(real sec1 - real timebase + real sec2 + real(usecs div 1000000)), usec = usecs mod 1000000} - end + end (*Y2004 bug-fix; mael 2005-03-16 val op + = fn ({sec=sec1, usec=usec1} : time, {sec=sec2, usec=usec2}) => let val usecs = usec1 + usec2 in {sec = sec1 - timebase + sec2 + usecs div 1000000, usec = usecs mod 1000000} - end + end *) and op - = fn ({sec=sec1, usec=usec1} : time, {sec=sec2, usec=usec2}) => - let val usecs = usec1 - usec2 + let val usecs = usec1 - usec2 val secs = sec1 - sec2 + usecs div 1000000 in - if secs < 0 then raise Time + if secs < 0 then raise Time else {sec = secs + timebase, usec = usecs mod 1000000} end handle Overflow => raise Time; @@ -156,7 +156,8 @@ structure Time : TIME = and op >= = fn ({sec=sec1, usec=usec1} : time, {sec=sec2, usec=usec2}) => (sec1 > sec2) orelse (sec1=sec2 andalso usec1 >= usec2); - fun compare (x, y: time) = + fun compare (x, y: time) = if xy then GREATER else EQUAL; + fun toPair x = x end diff --git a/src/CUtils/.gitignore b/src/CUtils/.gitignore index 15309787a..3f65ba1ae 100644 --- a/src/CUtils/.gitignore +++ b/src/CUtils/.gitignore @@ -1 +1,3 @@ -*.o \ No newline at end of file +*.o +*.out +*.res \ No newline at end of file diff --git a/src/CUtils/Makefile b/src/CUtils/Makefile index 6d2b98a3c..b4749ea7d 100644 --- a/src/CUtils/Makefile +++ b/src/CUtils/Makefile @@ -1,15 +1,38 @@ +RESFILES=hashmap_typed_test.res binaryheap_test.res +CFLAGS=-Wall -pedantic + .PHONY: all +all: test + +hashmap_typed_test.out: + gcc $(CFLAGS) hashmap.c hashmap_typed.c hashmap_typed_test.c + ./a.out > $@ -all: hashmap_typed_test binaryheap_test +binaryheap_test.out: + gcc $(CFLAGS) binaryheap_test.c +# @echo "output should be: 5 4 1 7 2 3 6" + ./a.out 3 4 5 2 1 6 3 > $@ -hashmap_typed_test: - gcc hashmap.c hashmap_typed.c hashmap_typed_test.c - ./a.out +%.res: %.out + @(diff -aq $< $<.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*: OK" > $@ \ + ; else \ + if [ -e $<.ok ]; then \ + echo "Test $*: *** ERR: file $< differs from $<.ok ***" > $@ \ + ; else \ + echo "Test $*: *** ERR: file $<.ok does not exist ***" > $@ \ + ; fi \ + ; fi) -binaryheap_test: - gcc -Wall -pedantic binaryheap_test.c - @echo "output should be: 5 4 1 7 2 3 6" - ./a.out 3 4 5 2 1 6 3 +.PHONY: test +test: $(RESFILES) + @cat $(RESFILES) + @echo "-------T E S T --- R E P O R T-------" + @echo "Tests succeeded: `grep "OK" $(RESFILES) | wc -l` /`grep "Test" $(RESFILES) | wc -l`" + @echo "Test errors: `grep "ERR" $(RESFILES) | wc -l` /`grep "Test" $(RESFILES) | wc -l`" + @echo "-------------------------------------" + @exit `grep "ERR" $(RESFILES) | wc -l` clean: - rm -rf *~ a.out *.o + rm -rf *~ *.o *.res *.out diff --git a/src/CUtils/binaryheap_test.c b/src/CUtils/binaryheap_test.c index da4fb2f63..ababffd73 100644 --- a/src/CUtils/binaryheap_test.c +++ b/src/CUtils/binaryheap_test.c @@ -10,7 +10,7 @@ struct elem_t long key; }; -int order (struct elem_t *a, struct elem_t *b) +int order (struct elem_t *a, struct elem_t *b) { if (a->key == b->key) return 0; if (a->key < b->key) return -1; @@ -22,7 +22,7 @@ void newpos (struct elem_t *a, unsigned long pos) return; } -void setkey (struct elem_t *a, long newkey) +void mysetkey (struct elem_t *a, long newkey) { a->key = newkey; return; @@ -30,7 +30,7 @@ void setkey (struct elem_t *a, long newkey) DECLARE_BINARYHEAP(test,struct elem_t,long) -DEFINE_BINARYHEAP(test,order,newpos,setkey) +DEFINE_BINARYHEAP(test,order,newpos,mysetkey) int main(int argc, char **argv) { @@ -38,7 +38,7 @@ int main(int argc, char **argv) test_binaryheap_t heap; struct elem_t tmp; test_heapinit(&heap); - for (i=1;ihashTableSize + 3; } - else + else { if ((tinfo->hashTableUsed >= ((tinfo->hashTableSize / 1024) * MINHASH)) || tinfo->hashTableSize == MINHASHSIZE) @@ -224,7 +224,7 @@ hashrehash (hashtable * tinfo) } // apply -void +void hashapply(hashtable *tinfo, void (*f)(void *value)) { hashmember *table = tinfo->table; @@ -240,7 +240,7 @@ hashapply(hashtable *tinfo, void (*f)(void *value)) } // Apply -void +void hashApply(hashtable *tinfo, void (*f)(void *key,void *value)) { hashmember *table = tinfo->table; @@ -256,7 +256,7 @@ hashApply(hashtable *tinfo, void (*f)(void *key,void *value)) } // map -void +void hashmap(hashtable *tinfo, void* (*f)(void *value)) { hashmember *table = tinfo->table; @@ -272,7 +272,7 @@ hashmap(hashtable *tinfo, void* (*f)(void *value)) } // Map -void +void hashMap(hashtable *tinfo, void* (*f)(void *key,void *value)) { hashmember *table = tinfo->table; @@ -321,12 +321,12 @@ hashFold(hashtable *tinfo, void *(*f)(void *, void *, void *), void *first) return t; } -// char * -> unsigned long +// char * -> unsigned long unsigned long -charhashfunction (const char *key) +charhashfunction (char *s) { unsigned long result = 0; - unsigned char *k = (unsigned char *) key; + unsigned char *k = (unsigned char *) s; while (*k) { // Will not overflow as the type is unsigned diff --git a/src/CUtils/hashmap.h b/src/CUtils/hashmap.h index 8011d35fe..fe88cc9a7 100644 --- a/src/CUtils/hashmap.h +++ b/src/CUtils/hashmap.h @@ -84,5 +84,5 @@ void hashMap(hashtable *tinfo, void* (*f)(void *key, void *value)); void hashmap(hashtable *tinfo, void* (*f)(void *value)); // an efficient hashfunction on char arrays -unsigned long charhashfunction (const char *key); +unsigned long charhashfunction (char *s); #endif diff --git a/src/CUtils/hashmap_typed.h b/src/CUtils/hashmap_typed.h index 6f9fa6281..78f21ae9d 100644 --- a/src/CUtils/hashmap_typed.h +++ b/src/CUtils/hashmap_typed.h @@ -4,14 +4,14 @@ #include "hashmap.h" // a new function for generating new hash tables (uses malloc) -hashtable* +hashtable* hashnew(unsigned long (*hash) (void *key), int (*equal) (void *key1, void *key2)); // as hashupdate, but exits with an error message in case of an error void hashupd (hashtable * tinfo, void *key, void *value); -// free all entries in hashtable and memory allocated +// free all entries in hashtable and memory allocated // for the hashtable struct void hashdrop (hashtable*); diff --git a/src/CUtils/hashmap_typed_test.c b/src/CUtils/hashmap_typed_test.c index af26cac32..ced713cc6 100644 --- a/src/CUtils/hashmap_typed_test.c +++ b/src/CUtils/hashmap_typed_test.c @@ -2,14 +2,14 @@ #include #include "hashmap_typed.h" -DECLARE_HASHMAP(stringToIntMap,char*,int) +DECLARE_HASHMAP(stringToIntMap,char*,long int) -DEFINE_HASHMAP(stringToIntMap,char*,int) +DEFINE_HASHMAP(stringToIntMap,char*,long int) void -pr(char* k,int v) +pr(char* k,long int v) { - printf("%s : %d\n",k,v); + printf("%s : %ld\n",k,v); } int @@ -20,20 +20,33 @@ streq(char* s1,char* s2) return 0; } +// char * -> unsigned long +unsigned long +strhash (char *s) +{ + unsigned long result = 0; + unsigned char *k = (unsigned char *) s; + while (*k) + { // Will not overflow as the type is unsigned + result = 31 * result + *k++; + } + return result; +} + int main(void) { stringToIntMap m; char* k1 = "Martin"; char* k2 = "Carsten"; - int r, v; - r = -1; + long int r, v; + r = -1; v = -1; m = new_stringToIntMap(charhashfunction,streq); stringToIntMap_upd(m,k1,3); stringToIntMap_upd(m,k2,8); stringToIntMap_apply(m,pr); r = stringToIntMap_find(m,"Carsten",&v); - printf("r = %d; v = %d\n",r,v); + printf("r = %ld; v = %ld\n",r,v); return 0; } diff --git a/src/CUtils/hashmap_typed_test.out.ok b/src/CUtils/hashmap_typed_test.out.ok new file mode 100644 index 000000000..dc78d2fea --- /dev/null +++ b/src/CUtils/hashmap_typed_test.out.ok @@ -0,0 +1,3 @@ +Carsten : 8 +Martin : 3 +r = 0; v = 8 diff --git a/src/Common/KitX64.sml b/src/Common/KitX64.sml new file mode 100644 index 000000000..75b287cad --- /dev/null +++ b/src/Common/KitX64.sml @@ -0,0 +1,6 @@ + +structure K = + let structure KC = KitCompiler(ExecutionX64) + val _ = Flags.turn_on "garbage_collection" + in KitMain(KC) + end diff --git a/src/Compiler/Backend/BACKEND_INFO.sml b/src/Compiler/Backend/BACKEND_INFO.sml index 076a280f2..fe8d89c5b 100644 --- a/src/Compiler/Backend/BACKEND_INFO.sml +++ b/src/Compiler/Backend/BACKEND_INFO.sml @@ -5,7 +5,7 @@ signature BACKEND_INFO = type label type offset = int - val init_clos_offset : offset (* First offset in FN closure is 1 and + val init_clos_offset : offset (* First offset in FN closure is 1 and * code pointer is at offset 0 *) val init_sclos_offset : offset (* First offset in shared closure is 0 *) val init_regvec_offset : offset (* First offset in region vector is 0 *) @@ -45,9 +45,9 @@ signature BACKEND_INFO = val size_of_reg_desc : unit -> int (* dependent on whether region profiling is enabled *) - val finiteRegionDescSizeP : int (* Number of words in a finite region + val finiteRegionDescSizeP : int (* Number of words in a finite region * descriptor when profiling is used. *) - val objectDescSizeP : int (* Number of words in an object descriptor + val objectDescSizeP : int (* Number of words in an object descriptor * when profiling is used. *) val defaultIntPrecision : unit -> int val defaultWordPrecision : unit -> int @@ -76,20 +76,12 @@ signature BACKEND_INFO = (* is_prim(name) returns true if name is not implemented by a C call, * but rather in machine code; primitives do not destroy all * caller save registers, as C calls do. *) - - val is_prim : string -> bool - (* is_flow_prim(name) returns true if name is a flow primitive such + val is_prim : string -> bool + + (* is_flow_prim(name) returns true if name is a flow primitive such * as __less_int31 and __equal_word32ub. *) val is_flow_prim : string -> bool - val down_growing_stack : bool (* true for x86 code generation *) + val down_growing_stack : bool (* true for x86/x64 code generation *) end - - - - - - - - diff --git a/src/Compiler/Backend/LineStmt.sml b/src/Compiler/Backend/LineStmt.sml index ef7c4f868..21969de72 100644 --- a/src/Compiler/Backend/LineStmt.sml +++ b/src/Compiler/Backend/LineStmt.sml @@ -1,4 +1,4 @@ -functor LineStmt(structure CallConv: CALL_CONV +functor LineStmt(structure CallConv: CALL_CONV where type lvar = Lvars.lvar structure ClosExp: CLOS_EXP where type con = Con.con @@ -11,8 +11,8 @@ functor LineStmt(structure CallConv: CALL_CONV sharing type CallConv.cc = ClosExp.cc structure BI : BACKEND_INFO structure RI : REGISTER_INFO - where type lvar = Lvars.lvar) - : LINE_STMT = + where type lvar = Lvars.lvar) + : LINE_STMT = struct structure Labels = AddressLabels structure PP = PrettyPrint @@ -49,7 +49,7 @@ struct fun log_st st = PP.outputTree(fn s => TextIO.output(!Flags.log,s), st, 70) fun pr_st st = PP.outputTree(fn s => TextIO.output(TextIO.stdOut,s), st, 70) fun die s = Crash.impossible ("LineStmt." ^ s) - fun fast_pr stringtree = + fun fast_pr stringtree = (PP.outputTree ((fn s => TextIO.output(!Flags.log, s)) , stringtree, !Flags.colwidth); TextIO.output(!Flags.log, "\n")) @@ -109,23 +109,23 @@ struct (* The boolean is true if the region has an untagged type *) | PASS_PTR_TO_RHO of 'aty sma (* Used only by CCALL *) - and ('sty,'offset,'aty) LineStmt = + and ('sty,'offset,'aty) LineStmt = ASSIGN of {pat: 'aty, bind: 'aty SimpleExp} | FLUSH of 'aty * 'offset | FETCH of 'aty * 'offset - | FNJMP of {opr: 'aty, args: 'aty list, clos: 'aty option, + | FNJMP of {opr: 'aty, args: 'aty list, clos: 'aty option, res: 'aty list, bv: Word32.word list} - | FNCALL of {opr: 'aty, args: 'aty list, clos: 'aty option, + | FNCALL of {opr: 'aty, args: 'aty list, clos: 'aty option, res: 'aty list, bv: Word32.word list} - | JMP of {opr: label, args: 'aty list, reg_vec: 'aty option, + | JMP of {opr: label, args: 'aty list, reg_vec: 'aty option, reg_args: 'aty list, clos: 'aty option, res: 'aty list, bv: Word32.word list} - | FUNCALL of {opr: label, args: 'aty list, reg_vec: 'aty option, + | FUNCALL of {opr: label, args: 'aty list, reg_vec: 'aty option, reg_args: 'aty list, clos: 'aty option, res: 'aty list, bv: Word32.word list} | LETREGION of {rhos: (binder*'offset) list, body: ('sty,'offset,'aty) LineStmt list} | SCOPE of {pat: 'sty list, scope: ('sty,'offset,'aty) LineStmt list} - | HANDLE of {default: ('sty,'offset,'aty) LineStmt list, - handl: ('sty,'offset,'aty) LineStmt list * 'aty, - handl_return: ('sty,'offset,'aty) LineStmt list * 'aty * (Word32.word list), + | HANDLE of {default: ('sty,'offset,'aty) LineStmt list, + handl: ('sty,'offset,'aty) LineStmt list * 'aty, + handl_return: ('sty,'offset,'aty) LineStmt list * 'aty * (Word32.word list), offset: 'offset} | RAISE of {arg: 'aty,defined_atys: 'aty list} | SWITCH_I of {switch: (Int32.int,'sty,'offset,'aty) Switch, precision: int} @@ -133,7 +133,7 @@ struct | SWITCH_S of (string,'sty,'offset,'aty) Switch | SWITCH_C of ((con*con_kind),'sty,'offset,'aty) Switch | SWITCH_E of (excon,'sty,'offset,'aty) Switch - | RESET_REGIONS of {force: bool, + | RESET_REGIONS of {force: bool, regions_for_resetting: 'aty sma list} | PRIM of {name: string, args: 'aty list, res: 'aty list} | CCALL of {name: string, args: 'aty list, @@ -144,7 +144,7 @@ struct and ('a,'sty,'offset,'aty) Switch = SWITCH of 'aty * ('a * (('sty,'offset,'aty) LineStmt list)) list * (('sty,'offset,'aty) LineStmt list) - and 'aty sma = + and 'aty sma = ATTOP_LI of 'aty * pp | ATTOP_LF of 'aty * pp | ATTOP_FI of 'aty * pp @@ -155,10 +155,10 @@ struct | SAT_FF of 'aty * pp | IGNORE - datatype ('sty,'offset,'aty) TopDecl = + datatype ('sty,'offset,'aty) TopDecl = FUN of label * cc * ('sty,'offset,'aty) LineStmt list | FN of label * cc * ('sty,'offset,'aty) LineStmt list - + type ('sty,'offset,'aty) LinePrg = ('sty,'offset,'aty) TopDecl list fun smash_free (lvs,excons,rhos) = rhos@excons@lvs @@ -198,7 +198,7 @@ struct fun pr_phsize(PhysSizeInf.INF) = "inf" | pr_phsize(PhysSizeInf.WORDS i) = Int.toString i - fun pr_binder(place,phsize) = + fun pr_binder(place,phsize) = (PP.flatten1(Effect.layout_effect place) ^ ":" ^ pr_phsize phsize) fun pr_con_kind(ENUM i) = "enum " ^ Int.toString i @@ -208,7 +208,7 @@ struct fun pr_pp pp = "pp" ^ Int.toString pp fun layout_aty pr_aty aty = LEAF(pr_aty aty) - + fun layout_aty_opt pr_aty (SOME aty) = layout_aty pr_aty aty | layout_aty_opt pr_aty (NONE) = LEAF "" @@ -216,8 +216,8 @@ struct | pr_bv([mark]) = die "pr_bv:Bit Vector with only one element" | pr_bv([mark,offsetToReturn]) = die "pr_bv:Bit Vector with only two elements" | pr_bv([mark,offsetToReturn,size]) = die "pr_bv:Bit Vector with only three elements" - | pr_bv(mark::offsetToReturn::size::bvs) = - (foldl (fn (w,C) => (Word32.fmt StringCvt.BIN w) ^ ":" ^ C) "" bvs) ^ + | pr_bv(mark::offsetToReturn::size::bvs) = + (foldl (fn (w,C) => (Word32.fmt StringCvt.BIN w) ^ ":" ^ C) "" bvs) ^ (Word32.fmt StringCvt.DEC size) ^ ":" ^ (Word32.fmt StringCvt.DEC offsetToReturn) ^ ":" ^ (Word32.fmt StringCvt.DEC mark) @@ -227,20 +227,20 @@ struct NODE{start="",finish="",indent=0, children=[LEAF (pr_const const),layout_lss ls_sel], childsep=RIGHT " => "} - val t1 = NODE{start="(case ",finish=" ",indent=2, childsep = NOSEP, + val t1 = NODE{start="(case ",finish=" ",indent=2, childsep = NOSEP, children=[layout_aty pr_aty aty_arg]} val t2 = NODE{start="of " ,finish="",indent=6,childsep=LEFT " | ", - children=(map layout_sels sels) @ + children=(map layout_sels sels) @ [NODE{start="",finish="",indent=0, children=[LEAF "_",layout_lss default], childsep=RIGHT " => "}]} val t3 = NODE{start="",finish=") (*case*) ",indent=3,childsep=NOSEP,children=[t2]} - in + in NODE{start = "", finish = "", indent=0, childsep=NOSEP,children=[t1,t3]} end fun layout_foreign_type ft = - case ft of + case ft of CharArray => LEAF "CharArray" | Int => LEAF "Int" | Bool => LEAF "Bool" @@ -280,7 +280,7 @@ struct finish="]aux " ^ pr_sma pr_aty alloc, childsep=RIGHT ",", children=map (layout_sma pr_aty) aux_regions} - | CON1{con,con_kind,alloc,arg} => + | CON1{con,con_kind,alloc,arg} => HNODE{start=Con.pr_con con ^ "(" ^ pr_con_kind con_kind ^ ") ", finish="" ^ pr_sma pr_aty alloc, childsep=NOSEP, @@ -296,9 +296,9 @@ struct | PASS_PTR_TO_MEM(sma,i,b) => LEAF("MEM(" ^ pr_sma pr_aty sma ^ "," ^ Int.toString i ^ "," ^ Bool.toString b ^ ")") | PASS_PTR_TO_RHO(sma) => LEAF("PTR(" ^ pr_sma pr_aty sma ^ ")")) - + and layout_ls pr_sty pr_offset pr_aty simplify ls = - let + let fun layout_lss_local lss = layout_lss pr_sty pr_offset pr_aty simplify lss in (case ls of @@ -379,11 +379,11 @@ struct | LETREGION{rhos,body} => let val rhos = if simplify then remove_finite_rhos rhos else rhos - val binders = HNODE{start = "", - finish = "", - childsep = RIGHT", ", + val binders = HNODE{start = "", + finish = "", + childsep = RIGHT", ", children = map (fn (b,offset) => LEAF(pr_binder b ^ pr_offset offset)) rhos} - in + in (case rhos of [] => layout_lss_local body | _ => NODE{start= "letregion " ^ flatten1(binders) ^ " in ", @@ -408,8 +408,8 @@ struct end | HANDLE{default,handl=(handl,handl_aty),handl_return=(handl_return,handl_return_aty,[]),offset} => let - val node_exn = NODE{start="[",finish="]",childsep=RIGHT("](" ^ pr_aty handl_aty ^ - ") handlereturn(" ^ pr_aty handl_return_aty ^ ") ["), + val node_exn = NODE{start="[",finish="]",childsep=RIGHT("](" ^ pr_aty handl_aty ^ + ") handlereturn(" ^ pr_aty handl_return_aty ^ ") ["), indent=2,children=[layout_lss_local handl,layout_lss_local handl_return]} in NODE{start="[",finish="",childsep=RIGHT("] handle " ^ pr_offset offset ^ " "),indent=2,children=[layout_lss_local default,node_exn]} @@ -417,14 +417,14 @@ struct | HANDLE{default,handl=(handl,handl_aty),handl_return=(handl_return,handl_return_aty,bv),offset} => let val hnode_bv = HNODE{start="<",finish=">",childsep=RIGHT ",",children=[PP.LEAF(pr_bv bv)]} - val node_exn = NODE{start="[",finish="](bv: " ^ flatten1(hnode_bv) ^ ")",childsep=RIGHT("](" ^ pr_aty handl_aty ^ - ") handlereturn(" ^ pr_aty handl_return_aty ^ ") ["), + val node_exn = NODE{start="[",finish="](bv: " ^ flatten1(hnode_bv) ^ ")",childsep=RIGHT("](" ^ pr_aty handl_aty ^ + ") handlereturn(" ^ pr_aty handl_return_aty ^ ") ["), indent=2,children=[layout_lss_local handl,layout_lss_local handl_return]} in NODE{start="[",finish="",childsep=RIGHT("] handle " ^ pr_offset offset ^ " "),indent=2,children=[layout_lss_local default,node_exn]} end - | RAISE{arg,defined_atys} => + | RAISE{arg,defined_atys} => let val lay_stys = flatten1(HNODE{start="<",finish=">",childsep=RIGHT ",",children=map (fn aty => LEAF(pr_aty aty)) defined_atys}) in @@ -450,7 +450,7 @@ struct let val t0 = HNODE{start="<",finish=">",childsep=RIGHT ",",children= map (layout_aty pr_aty) res} in - HNODE{start=flatten1(t0) ^ " = prim(\"" ^ name ^ "\", <", + HNODE{start=flatten1(t0) ^ " = prim(\"" ^ name ^ "\", <", finish=">)", childsep=RIGHT ",", children=map (layout_aty pr_aty) args} @@ -459,7 +459,7 @@ struct let val t0 = HNODE{start="<",finish=">",childsep=RIGHT ",",children= map (layout_aty pr_aty) res} in - HNODE{start=flatten1(t0) ^ " = ccall(\"" ^ name ^ "\", <", + HNODE{start=flatten1(t0) ^ " = ccall(\"" ^ name ^ "\", <", finish=">)", childsep=RIGHT ",", children=(map (layout_aty pr_aty) rhos_for_result) @ (map (layout_aty pr_aty) args)} @@ -470,12 +470,12 @@ struct children=[layout_aty pr_aty aty, layout_foreign_type f]} val t0 = layout_pair res in - HNODE{start=flatten1(t0) ^ " = ccall_auto(\"" ^ name ^ "\", <", + HNODE{start=flatten1(t0) ^ " = ccall_auto(\"" ^ name ^ "\", <", finish=">)", childsep=RIGHT ",", children=map layout_pair args} end - | EXPORT{name,clos_lab, arg=(aty,ft1,ft2)} => + | EXPORT{name,clos_lab, arg=(aty,ft1,ft2)} => HNODE{start="_export(" ^ name ^ ",", finish=")", childsep=RIGHT ",", @@ -485,8 +485,8 @@ struct ) end - - and layout_lss pr_sty pr_offset pr_aty simplify lss = + + and layout_lss pr_sty pr_offset pr_aty simplify lss = NODE{start="", finish= "", indent= 0, @@ -508,15 +508,15 @@ struct and layout_sma pr_aty sma = LEAF(pr_sma pr_aty sma) fun layout_top_decl pr_sty pr_offset pr_aty simplify (FUN(lab,cc,lss)) = - NODE{start = "FUN " ^ Labels.pr_label lab ^ "{" ^ CallConv.pr_cc cc ^ "}=", - finish = "", - indent = 2, - childsep = NOSEP, + NODE{start = "FUN " ^ Labels.pr_label lab ^ "{" ^ CallConv.pr_cc cc ^ "}=", + finish = "", + indent = 2, + childsep = NOSEP, children = [layout_lss pr_sty pr_offset pr_aty simplify lss]} | layout_top_decl pr_sty pr_offset pr_aty simplify (FN(lab,cc,lss)) = - NODE{start = "FN " ^ Labels.pr_label lab ^ "{" ^ CallConv.pr_cc cc ^ "}=", - finish = "", - indent = 2, + NODE{start = "FN " ^ Labels.pr_label lab ^ "{" ^ CallConv.pr_cc cc ^ "}=", + finish = "", + indent = 2, childsep = NOSEP, children = [layout_lss pr_sty pr_offset pr_aty simplify lss]} @@ -528,7 +528,7 @@ struct childsep=NOSEP, children = map (layout_top_decl pr_sty pr_offset pr_aty simplify) top_decls} in - fun layout_line_prg pr_sty pr_offset pr_aty simplify top_decls = + fun layout_line_prg pr_sty pr_offset pr_aty simplify top_decls = layout_line_prg' pr_sty pr_offset pr_aty simplify top_decls fun layout_line_stmt pr_sty pr_offset pr_aty simplify ls = layout_line_stmt' pr_sty pr_offset pr_aty simplify ls @@ -544,7 +544,7 @@ struct | zip _ = die "zip: Cannot zip two lists." fun is_region_pair place = - case Effect.get_place_ty place of + case Effect.get_place_ty place of NONE => die "is_region_pair" | SOME Effect.PAIR_RT => true | SOME _ => false @@ -607,7 +607,7 @@ struct fun maybe_assign ([], bind, acc) = acc | maybe_assign ([lv], bind, acc) = ASSIGN{pat=VAR lv, bind=bind} :: acc - | maybe_assign _ = die "maybe_assign.more than one lvar to bind!" + | maybe_assign _ = die "maybe_assign.more than one lvar to bind!" fun L_ce(ce,lvars_res,acc) = case ce @@ -620,8 +620,8 @@ struct | ClosExp.WORD i => maybe_assign (lvars_res, ATOM(WORD i), acc) | ClosExp.STRING s => maybe_assign (lvars_res, STRING s, acc) | ClosExp.REAL s => maybe_assign (lvars_res, REAL s, acc) - | ClosExp.PASS_PTR_TO_MEM(sma,i) => - let fun untagged_region_type sma = + | ClosExp.PASS_PTR_TO_MEM(sma,i) => + let fun untagged_region_type sma = case ce_of_sma sma of SOME (ClosExp.RVAR rho) => is_region_pair rho | _ => false @@ -630,16 +630,16 @@ struct end | ClosExp.PASS_PTR_TO_RHO sma => maybe_assign (lvars_res, PASS_PTR_TO_RHO(sma_to_sma sma), acc) | ClosExp.UB_RECORD ces => List.foldr (fn ((ce,lv_res),acc) => L_ce(ce,[lv_res],acc)) acc (zip(ces,lvars_res)) - | ClosExp.CLOS_RECORD{label,elems=(lvs,excons,rhos),alloc} => + | ClosExp.CLOS_RECORD{label,elems=(lvs,excons,rhos),alloc} => maybe_assign (lvars_res, CLOS_RECORD{label=label, elems=(ces_to_atoms lvs,ces_to_atoms excons,ces_to_atoms rhos), alloc=sma_to_sma alloc}, acc) - | ClosExp.REGVEC_RECORD{elems,alloc} => + | ClosExp.REGVEC_RECORD{elems,alloc} => maybe_assign (lvars_res, REGVEC_RECORD{elems=smas_to_smas elems,alloc=sma_to_sma alloc}, acc) - | ClosExp.SCLOS_RECORD{elems=(lvs,excons,rhos),alloc} => + | ClosExp.SCLOS_RECORD{elems=(lvs,excons,rhos),alloc} => maybe_assign (lvars_res, SCLOS_RECORD{elems=(ces_to_atoms lvs,ces_to_atoms excons,ces_to_atoms rhos), alloc=sma_to_sma alloc}, acc) - | ClosExp.RECORD{elems,alloc,tag,maybeuntag} => + | ClosExp.RECORD{elems,alloc,tag,maybeuntag} => maybe_assign (lvars_res, RECORD{elems=ces_to_atoms elems,alloc=sma_to_sma alloc,tag=tag,maybeuntag=maybeuntag}, acc) | ClosExp.SELECT(i,ce) => maybe_assign (lvars_res, SELECT(i,ce_to_atom ce), acc) @@ -674,10 +674,10 @@ struct handl=([SCOPE{pat=[mk_sty clos_lv],scope=L_ce(ce2,[clos_lv],[])}],VAR clos_lv), handl_return=([],aty,[]),offset=()} :: acc (* for now, offset is unit *) end - | ClosExp.SWITCH_I {switch, precision} => + | ClosExp.SWITCH_I {switch, precision} => SWITCH_I {switch=L_ce_sw(switch,fn (ce,acc) => L_ce(ce,lvars_res,acc),fn i => i), precision=precision} ::acc - | ClosExp.SWITCH_W {switch, precision} => + | ClosExp.SWITCH_W {switch, precision} => SWITCH_W {switch=L_ce_sw(switch,fn (ce,acc) => L_ce(ce,lvars_res,acc),fn i => i), precision=precision} ::acc | ClosExp.SWITCH_S sw => SWITCH_S(L_ce_sw(sw,fn (ce,acc) => L_ce(ce,lvars_res,acc),fn s => s))::acc @@ -687,7 +687,7 @@ struct maybe_assign (lvars_res, CON0{con=con,con_kind=con_kind_to_con_kind con_kind, aux_regions=smas_to_smas aux_regions, alloc=sma_to_sma alloc}, acc) - | ClosExp.CON1{con,con_kind,alloc,arg} => + | ClosExp.CON1{con,con_kind,alloc,arg} => maybe_assign (lvars_res, CON1{con=con,con_kind=con_kind_to_con_kind con_kind, alloc=sma_to_sma alloc,arg=ce_to_atom arg}, acc) | ClosExp.DECON{con,con_kind,con_exp} => @@ -700,20 +700,20 @@ struct | ClosExp.ASSIGN(sma,ce1,ce2) => maybe_assign (lvars_res, ASSIGNREF(sma_to_sma sma,ce_to_atom ce1,ce_to_atom ce2), acc) | ClosExp.DROP(ce) => L_ce(ce,lvars_res,acc) - | ClosExp.RESET_REGIONS{force,regions_for_resetting} => + | ClosExp.RESET_REGIONS{force,regions_for_resetting} => (* We must have RESET_REGIONS return unit. *) RESET_REGIONS{force=force,regions_for_resetting=smas_to_smas regions_for_resetting}:: maybe_assign (lvars_res, ATOM UNIT, acc) - | ClosExp.CCALL{name,rhos_for_result,args} => + | ClosExp.CCALL{name,rhos_for_result,args} => if BI.is_prim name then PRIM{name=name,args=ces_to_atoms rhos_for_result @ ces_to_atoms args, res=map VAR lvars_res}::acc else CCALL{name=name,args=ces_to_atoms args, rhos_for_result=ces_to_atoms rhos_for_result, res=map VAR lvars_res}::acc - | ClosExp.CCALL_AUTO{name,args,res} => - if BI.is_prim name then + | ClosExp.CCALL_AUTO{name,args,res} => + if BI.is_prim name then die ("CCALL_AUTO." ^ name ^ " appears to be a PRIM!") - else + else let val res = case lvars_res of [lv] => (VAR lv, res) | _ => die ("CCALL_AUTO.result mismatch (SOME) " @@ -721,7 +721,7 @@ struct val args = map (fn (ce,ft) => (ce_to_atom ce, ft)) args in CCALL_AUTO{name=name, args=args, res=res}::acc end - | ClosExp.EXPORT{name,clos_lab,arg=(ce,ft1,ft2)} => + | ClosExp.EXPORT{name,clos_lab,arg=(ce,ft1,ft2)} => EXPORT{name=name,clos_lab=clos_lab,arg=(ce_to_atom ce,ft1,ft2)}:: maybe_assign (lvars_res, ATOM UNIT, acc) | ClosExp.FRAME{declared_lvars,declared_excons} => acc @@ -731,7 +731,7 @@ struct val lvars_res = CallConv.get_res_lvars(cc) in FUN(lab,cc,L_ce(ce,lvars_res,[])) - end + end | L_top_decl(ClosExp.FN(lab,cc,ce)) = let val lvars_res = CallConv.get_res_lvars(cc) @@ -759,7 +759,7 @@ struct of FNJMP a => if count_tail_calls then 1 else 0 | FNCALL a => 1 | JMP a => if count_tail_calls then 1 else 0 - | FUNCALL a => 1 + | FUNCALL a => 1 | LETREGION{rhos,body} => NA_lss body | SCOPE{pat,scope} => NA_lss scope | HANDLE{default,handl=(handl,handl_lv),handl_return=([],handl_return_lv,bv),offset} => NA_lss default + NA_lss handl @@ -770,17 +770,17 @@ struct | SWITCH_C sw => NA_sw sw NA_lss | SWITCH_E sw => NA_sw sw NA_lss | _ => 0 - in + in foldr (fn (ls,n) => n + NA_ls ls) 0 lss end in fun NA_prg top_decls = - let - fun NA_top_decl func = - case func + let + fun NA_top_decl func = + case func of FUN(lab,cc,lss) => NA_lss lss | FN(lab,cc,lss) => NA_lss lss - in + in foldr (fn (func,n) => n + NA_top_decl func) 0 top_decls end end @@ -807,7 +807,7 @@ struct | get_phreg_sma(SAT_FI(atom,pp),acc) = get_phreg_atom(atom,acc) | get_phreg_sma(SAT_FF(atom,pp),acc) = get_phreg_atom(atom,acc) | get_phreg_sma(IGNORE,acc) = acc - + fun get_phreg_smas(smas,acc) = foldr (fn (sma,acc) => get_phreg_sma(sma,acc)) acc smas fun get_phreg_se(ATOM atom,acc) = get_phreg_atom(atom,acc) @@ -875,34 +875,6 @@ struct fun get_var_smas(smas,acc) = foldr (fn (sma,acc) => get_var_sma(sma,acc)) acc smas -(* <<<<< LineStmt.sml *) -(* - fun def_var_se (se: Atom SimpleExp,acc:lvar list) = acc - - fun use_var_se(ATOM atom,acc) = get_var_atom(atom,acc) - | use_var_se(LOAD lab,acc) = acc - | use_var_se(STORE(atom,lab),acc) = get_var_atom(atom,acc) - | use_var_se(STRING str,acc) = acc - | use_var_se(REAL str,acc) = acc - | use_var_se(CLOS_RECORD{label,elems,alloc},acc) = get_var_sma(alloc, get_var_atoms(smash_free elems,acc)) - | use_var_se(REGVEC_RECORD{elems,alloc},acc) = get_var_sma(alloc, get_var_smas(elems,acc)) - | use_var_se(SCLOS_RECORD{elems,alloc},acc) = get_var_sma(alloc, get_var_atoms(smash_free elems,acc)) - | use_var_se(RECORD{elems,alloc,tag},acc) = get_var_sma(alloc, get_var_atoms(elems,acc)) - | use_var_se(SELECT(i,atom),acc) = get_var_atom(atom,acc) - | use_var_se(CON0{con,con_kind,aux_regions,alloc},acc) = get_var_sma(alloc, get_var_smas(aux_regions,acc)) - | use_var_se(CON1{con,con_kind,alloc,arg},acc) = get_var_sma(alloc,get_var_atom(arg,acc)) - | use_var_se(DECON{con,con_kind,con_aty},acc) = get_var_atom(con_aty,acc) - | use_var_se(DEREF atom,acc) = get_var_atom(atom,acc) - | use_var_se(REF(sma,atom),acc) = get_var_sma(sma,get_var_atom(atom,acc)) - | use_var_se(ASSIGNREF(sma,atom1,atom2),acc) = get_var_sma(sma,get_var_atom(atom1,get_var_atom(atom2,acc))) - | use_var_se(PASS_PTR_TO_MEM(sma,i),acc) = get_var_sma(sma,acc) - | use_var_se(PASS_PTR_TO_RHO sma,acc) = get_var_sma(sma,acc) - - fun use_var_on_fun{opr,args,reg_vec,reg_args,clos,res,bv} = (* Operand is always a label *) - get_var_atoms(args,get_var_atom_opt(reg_vec, - get_var_atoms(reg_args,get_var_atom_opt(clos,[])))) -*) -(* ======= *) fun get_var_sma_ignore(ATTOP_LI(atom,pp),acc) = acc | get_var_sma_ignore(ATTOP_LF(atom,pp),acc) = acc | get_var_sma_ignore(ATTOP_FI(atom,pp),acc) = acc @@ -917,16 +889,8 @@ struct fun smash_free_ignore (lvs,excons,rhos) = excons@lvs -(* >>>>> 1.22 - - <<<<< LineStmt.sml - ===== -*) - fun def_var_se (se: Atom SimpleExp,acc:lvar list) = acc -(* >>>>> 1.22 *) - fun def_var_on_fun{opr,args,reg_vec,reg_args,clos,res,bv} = get_var_atoms(res,[]) fun use_var_on_fn{opr,args,clos,res,bv} = @@ -934,7 +898,7 @@ struct fun def_var_on_fn{opr,args,clos,res,bv} = get_var_atoms(res,[]) - fun def_var_ls(ASSIGN{pat,bind}) = get_var_atom(pat,[]) + fun def_var_ls(ASSIGN{pat,bind}) = get_var_atom(pat,[]) | def_var_ls(FLUSH(atom,_)) = [] | def_var_ls(FETCH(atom,_)) = get_var_atom(atom,[]) | def_var_ls(FNJMP cc) = def_var_on_fn cc @@ -960,13 +924,13 @@ struct local fun get_var_sma' ignore_rvars = if ignore_rvars then get_var_sma_ignore else get_var_sma - fun get_var_smas' ignore_rvars = + fun get_var_smas' ignore_rvars = if ignore_rvars then get_var_smas_ignore else get_var_smas - fun smash_free' ignore_rvars = + fun smash_free' ignore_rvars = if ignore_rvars then smash_free_ignore else smash_free fun use_var_se' get_var_sma get_var_smas smash_free arg = - case arg of + case arg of (ATOM atom,acc) => get_var_atom(atom,acc) | (LOAD lab,acc) => acc | (STORE(atom,lab),acc) => get_var_atom(atom,acc) @@ -992,7 +956,7 @@ struct else get_var_atoms(args,get_var_atom_opt(reg_vec, get_var_atoms(reg_args,get_var_atom_opt(clos,[])))) - + fun use_var_ls' ignore_rvars ls = let fun use_var_on_fun arg = use_var_on_fun' ignore_rvars arg @@ -1042,7 +1006,7 @@ struct fun get_lvar_atoms(atoms,acc) = filter_out_phregs (get_var_atoms(atoms,acc)) fun get_lvar_atom_opt(atom_opt,acc) = filter_out_phregs (get_var_atom_opt(atom_opt,acc)) - fun get_lvar_sma(sma,acc) = filter_out_phregs (get_var_sma(sma,acc)) + fun get_lvar_sma(sma,acc) = filter_out_phregs (get_var_sma(sma,acc)) fun get_lvar_smas(smas,acc) = filter_out_phregs(get_var_smas(smas,acc)) fun def_lvar_se (se:Atom SimpleExp,acc:lvar list) = filter_out_phregs acc @@ -1095,7 +1059,7 @@ struct val default' = map_lss default in switch_con(SWITCH(map_aty atom,sels',default')) - end + end fun map_fn_app{opr,args,clos,res,bv} = {opr=map_aty opr, @@ -1118,12 +1082,12 @@ struct | map_se(STORE(aty,label)) = STORE(map_aty aty,label) | map_se(STRING str) = STRING str | map_se(REAL str) = REAL str - | map_se(CLOS_RECORD{label,elems=(lvs,excons,rhos),alloc}) = + | map_se(CLOS_RECORD{label,elems=(lvs,excons,rhos),alloc}) = CLOS_RECORD{label=label, elems=(map_atys lvs,map_atys excons,map_atys rhos), alloc= map_sma alloc} | map_se(REGVEC_RECORD{elems,alloc}) = REGVEC_RECORD{elems=map_smas elems,alloc=map_sma alloc} - | map_se(SCLOS_RECORD{elems=(lvs,excons,rhos),alloc}) = + | map_se(SCLOS_RECORD{elems=(lvs,excons,rhos),alloc}) = SCLOS_RECORD{elems=(map_atys lvs,map_atys excons,map_atys rhos), alloc = map_sma alloc} | map_se(RECORD{elems,alloc,tag,maybeuntag}) = RECORD{elems=map_atys elems,alloc=map_sma alloc,tag=tag,maybeuntag=maybeuntag} @@ -1153,20 +1117,20 @@ struct handl_return=(map_lss' handl_return,map_aty handl_return_lv,bv), offset=f_offset offset} :: map_lss' lss | map_lss'(RAISE{arg,defined_atys}::lss) = RAISE{arg=map_aty arg,defined_atys=map_atys defined_atys} :: map_lss' lss - | map_lss'(SWITCH_I {switch, precision} :: lss) = + | map_lss'(SWITCH_I {switch, precision} :: lss) = map_sw(map_lss',fn sw => SWITCH_I {switch=sw, precision=precision},switch) :: map_lss' lss - | map_lss'(SWITCH_W {switch, precision} :: lss) = + | map_lss'(SWITCH_W {switch, precision} :: lss) = map_sw(map_lss',fn sw => SWITCH_W {switch=sw, precision=precision},switch) :: map_lss' lss | map_lss'(SWITCH_S sw::lss) = map_sw(map_lss',SWITCH_S,sw) :: map_lss' lss | map_lss'(SWITCH_C sw::lss) = map_sw(map_lss',SWITCH_C,sw) :: map_lss' lss | map_lss'(SWITCH_E sw::lss) = map_sw(map_lss',SWITCH_E,sw) :: map_lss' lss | map_lss'(RESET_REGIONS{force,regions_for_resetting}::lss) = RESET_REGIONS{force=force,regions_for_resetting=map_smas regions_for_resetting} :: map_lss' lss - | map_lss'(PRIM{name,args,res}::lss) = + | map_lss'(PRIM{name,args,res}::lss) = PRIM{name=name,args=map_atys args,res=map_atys res} :: map_lss' lss - | map_lss'(CCALL{name,args,rhos_for_result,res}::lss) = + | map_lss'(CCALL{name,args,rhos_for_result,res}::lss) = CCALL{name=name,args=map_atys args,rhos_for_result=map_atys rhos_for_result,res=map_atys res} :: map_lss' lss - | map_lss'(CCALL_AUTO{name,args,res}::lss) = + | map_lss'(CCALL_AUTO{name,args,res}::lss) = CCALL_AUTO{name=name,args=map_pair_atys args,res=map_pair_aty res} :: map_lss' lss | map_lss'(EXPORT{name,clos_lab,arg=(aty,ft1,ft2)}::lss) = EXPORT{name=name,clos_lab=clos_lab,arg=(map_aty aty,ft1,ft2)} :: map_lss' lss @@ -1179,12 +1143,12 @@ struct code=top_decls:('sty1,'offset1,'aty1) LinePrg, imports:label list * label list, exports:label list * label list} = - let - fun map_top_decl func = - case func + let + fun map_top_decl func = + case func of FUN(lab,cc,lss) => FUN(lab,cc,map_lss f_aty f_offset f_sty lss) | FN(lab,cc,lss) => FN(lab,cc,map_lss f_aty f_offset f_sty lss) - in + in {main_lab = main_lab, code = foldr (fn (func,acc) => map_top_decl func :: acc) [] top_decls, imports = imports, @@ -1204,7 +1168,7 @@ struct end local - fun add_ok_use(lv,(OKset,notOKset,_)) = + fun add_ok_use(lv,(OKset,notOKset,_)) = if Lvarset.member(lv,OKset) then (Lvarset.delete(OKset,lv),Lvarset.add(notOKset,lv),NONE) else @@ -1213,13 +1177,13 @@ struct else (Lvarset.add(OKset,lv),notOKset,SOME lv) fun add_not_ok_use(lvs,(OKset,notOKset,_)) = - foldl (fn (lv,(OKset,notOKset,next_prev_use_lv)) => + foldl (fn (lv,(OKset,notOKset,next_prev_use_lv)) => (Lvarset.delete(OKset,lv),Lvarset.add(notOKset,lv),next_prev_use_lv)) (OKset,notOKset,NONE) lvs fun add_not_ok_def(lvs,(OKset,notOKset,_)) = - foldl (fn (lv,(OKset,notOKset,next_prev_use_lv)) => + foldl (fn (lv,(OKset,notOKset,next_prev_use_lv)) => (Lvarset.delete(OKset,lv),Lvarset.add(notOKset,lv),next_prev_use_lv)) (OKset,notOKset,NONE) lvs fun add_ok_def(lv,NONE,(OKset,notOKset,_)) = add_not_ok_def([lv],(OKset,notOKset,NONE)) - | add_ok_def(lv,SOME lv_to_match,(OKset,notOKset,_)) = + | add_ok_def(lv,SOME lv_to_match,(OKset,notOKset,_)) = if Lvars.eq(lv,lv_to_match) then (OKset,notOKset,NONE) else @@ -1235,14 +1199,14 @@ struct (* because we may only have ONE use of each flow variable. *) let val (OKset_sels,notOKset_sels,_) = - foldr (fn ((sel,lss),(OKset,notOKset,_)) => + foldr (fn ((sel,lss),(OKset,notOKset,_)) => FV_CalcSets_lss(lss,(OKset,notOKset,prev_use_lv))) (OKset,notOKset,NONE) sels in add_not_ok_use(get_lvar_atom(atom,[]),FV_CalcSets_lss(default,(OKset_sels,notOKset_sels,prev_use_lv))) end fun pr_prev(NONE) = "none" - | pr_prev(SOME lv) = Lvars.pr_lvar lv + | pr_prev(SOME lv) = Lvars.pr_lvar lv fun FV_CalcSets_ls(ls,OKset,notOKset,prev_use_lv) = (case ls of @@ -1262,7 +1226,7 @@ struct add_not_ok_def([lv_res],add_not_ok_use(use_var_ls ls,(OKset,notOKset,NONE))) (* Pattern: case lv of true => lss | _ => lss *) (* Pattern: case lv of false => lss | _ => lss *) - | SWITCH_C(sw as SWITCH(VAR lv,[((con,con_kind),lss)],default)) => + | SWITCH_C(sw as SWITCH(VAR lv,[((con,con_kind),lss)],default)) => if Con.eq(con,Con.con_TRUE) orelse Con.eq(con,Con.con_FALSE) then let @@ -1274,8 +1238,8 @@ struct FV_CalcSets_sw(FV_CalcSets_lss,sw,OKset,notOKset,prev_use_lv) (* Pattern: case lv of 3 => lss | _ => lss *) (* Pattern: case lv of 1 => lss | _ => lss *) - | SWITCH_I {switch=sw as SWITCH(VAR lv,[(sel_val,lss)],default), precision} => - if (sel_val = Int32.fromInt BI.ml_true + | SWITCH_I {switch=sw as SWITCH(VAR lv,[(sel_val,lss)],default), precision} => + if (sel_val = Int32.fromInt BI.ml_true orelse sel_val = Int32.fromInt BI.ml_false) then let val (OKset',notOKset',_) = FV_CalcSets_lss(default,(OKset,notOKset,prev_use_lv)) @@ -1284,12 +1248,12 @@ struct end else FV_CalcSets_sw(FV_CalcSets_lss,sw,OKset,notOKset,prev_use_lv) - | LETREGION{rhos,body} => + | LETREGION{rhos,body} => (* if region_profiling is disabled, then only infinite regions execute code *) (* if region_profiling is enabled, then all non zero regions execute code *) (case (if Flags.is_on "region_profiling" then remove_zero_rhos else remove_finite_rhos) rhos of [] => FV_CalcSets_lss(body,(OKset,notOKset,prev_use_lv)) - | _ => + | _ => let val (OKset',notOKset',_) = FV_CalcSets_lss(body,(OKset,notOKset,NONE)) in @@ -1335,13 +1299,13 @@ struct let (* Add cc to nonOKset *) val notOKset = Lvarset.lvarsetof (CallConv.get_res_lvars cc @ CallConv.get_arg_lvars cc) - val (OKset,_,_) = FV_CalcSets_lss(lss,(Lvarset.empty,notOKset,NONE)) + val (OKset,_,_) = FV_CalcSets_lss(lss,(Lvarset.empty,notOKset,NONE)) val _ = inc_flow_var (List.length(Lvarset.members OKset)) - val OKmap = - Lvarset.foldset - (fn (OKmap,lv) => + val OKmap = + Lvarset.foldset + (fn (OKmap,lv) => LvarFinMap.add (lv, - (Labels.new_named (Lvars.pr_lvar lv ^ "T"), + (Labels.new_named (Lvars.pr_lvar lv ^ "T"), Labels.new_named (Lvars.pr_lvar lv ^ "F")), OKmap)) (LvarFinMap.empty,OKset) val lss' = map_lss (fn aty => ann_aty(aty,OKmap)) (fn i => i) (fn sty => ann_sty(sty,OKmap)) lss @@ -1350,12 +1314,12 @@ struct end in fun FV_prg top_decls = - let - fun FV_top_decl func = - case func + let + fun FV_top_decl func = + case func of FUN(lab,cc,lss) => FV_top_decl' (fn lss => FUN(lab,cc,lss)) (cc,lss) | FN(lab,cc,lss) => FV_top_decl' (fn lss => FN(lab,cc,lss)) (cc,lss) - in + in foldr (fn (func,acc) => FV_top_decl func :: acc) [] top_decls end end @@ -1370,13 +1334,13 @@ struct let val _ = chat "[Linearisation..." val _ = reset_flow_var_stat() - val line_prg = L_clos_prg clos_prg - val line_prg_flow_var = + val line_prg = L_clos_prg clos_prg + val line_prg_flow_var = if not (Flags.is_on "disable_flow_var") then FV_prg line_prg else line_prg - val _ = + val _ = if Flags.is_on "print_linearised_program" then (print ("Number of functions: " ^ (Int.toString(length(line_prg))) ^ "\n"); print ("Number of applications: " ^ (Int.toString(NA_prg line_prg)) ^ "\n"); @@ -1388,4 +1352,4 @@ struct in {main_lab=main_lab,code=line_prg_flow_var,imports=imports,exports=exports} end -end; \ No newline at end of file +end; diff --git a/src/Compiler/Backend/REGISTER_INFO.sml b/src/Compiler/Backend/REGISTER_INFO.sml index 5762cd567..c7571df40 100644 --- a/src/Compiler/Backend/REGISTER_INFO.sml +++ b/src/Compiler/Backend/REGISTER_INFO.sml @@ -1,26 +1,29 @@ signature REGISTER_INFO = sig - eqtype reg - type lvar + eqtype reg + type lvar type lvarset val is_reg : lvar -> bool val lv_to_reg : lvar -> reg (* Die if lvar is not a precolored register *) - val args_phreg : lvar list (* Machine registers containing arguments *) - val res_phreg : lvar list (* Machine registers containing results *) + val args_phreg : lvar list (* Machine registers containing arguments *) + val res_phreg : lvar list (* Machine registers containing results *) val all_regs : lvar list - val args_phreg_ccall : lvar list (* Machine registers containing arguments in CCALLs *) - val res_phreg_ccall : lvar list (* Machine registers containing results in CCALLs *) - val caller_save_phregs : lvar list val caller_save_phregset : lvarset - val is_caller_save : lvar -> bool + val is_caller_save : lvar -> bool + + (* CCALLs *) + val args_reg_ccall : reg list (* Machine registers containing arguments in CCALLs *) + val args_phreg_ccall : lvar list (* Machine registers containing arguments in CCALLs *) + val args_ccall_phregset : lvarset (* Machine registers containing arguments in CCALLs *) + val res_phreg_ccall : lvar list (* Machine registers containing results in CCALLs *) val callee_save_ccall_phregs : lvar list val callee_save_ccall_phregset : lvarset - val is_callee_save_ccall : lvar -> bool + val is_callee_save_ccall : lvar -> bool val caller_save_ccall_phregs : lvar list val caller_save_ccall_phregset : lvarset @@ -28,5 +31,4 @@ signature REGISTER_INFO = val pr_reg : reg -> string val reg_eq : reg * reg -> bool - - end \ No newline at end of file + end diff --git a/src/Compiler/Backend/RegAlloc.sml b/src/Compiler/Backend/RegAlloc.sml index 6ad81d7d7..560d56231 100644 --- a/src/Compiler/Backend/RegAlloc.sml +++ b/src/Compiler/Backend/RegAlloc.sml @@ -10,7 +10,7 @@ functor RegAlloc(structure CallConv: CALL_CONV sharing type CallConv.cc = LineStmt.cc structure RI : REGISTER_INFO where type lvar = Lvars.lvar - where type lvarset = Lvarset.lvarset) + where type lvarset = Lvarset.lvarset) : REG_ALLOC = struct structure Labels = AddressLabels @@ -29,7 +29,7 @@ struct \you save about 15 percent on compile time."} val region_profiling = Flags.is_on0 "region_profiling" - + type lvarset = Lvarset.lvarset type place = Effect.place type excon = Excon.excon @@ -47,7 +47,7 @@ struct STACK_STY of lvar | PHREG_STY of lvar * lvar | FV_STY of lvar * label * label - + fun pr_sty(STACK_STY lv) = Lvars.pr_lvar lv ^ ":stack" | pr_sty(PHREG_STY(lv,phreg)) = Lvars.pr_lvar lv ^ ":" ^ LS.pr_phreg phreg | pr_sty(FV_STY(lv,l1,l2)) = Lvars.pr_lvar lv ^ ":FV(" ^ Labels.pr_label l1 ^ "," ^ Labels.pr_label l2 ^ ")" @@ -58,9 +58,9 @@ struct (* Logging *) (***********) fun log s = TextIO.output(!Flags.log,s ^ "\n") - fun chat(s: string) = if !Flags.chat then print (s ^ "\n") else () + fun chat (s: string) = if !Flags.chat then print (s ^ "\n") else () fun die s = Crash.impossible ("RegAlloc." ^ s) - fun fast_pr stringtree = + fun fast_pr stringtree = (PP.outputTree ((fn s => TextIO.output(!Flags.log, s)) , stringtree, !Flags.colwidth); TextIO.output(!Flags.log, "\n")) @@ -85,11 +85,11 @@ struct local fun mk_sty lv = LS.V lv (* Flow variables are annotated later *) fun resolve_args([],lss) = lss - | resolve_args((atom,phreg)::args,lss) = + | resolve_args((atom,phreg)::args,lss) = resolve_args(args,LS.ASSIGN{pat=atom,bind=LS.ATOM(LS.PHREG phreg)}::lss) fun resolve_res([],lss) = lss - | resolve_res((atom,phreg)::res,lss) = + | resolve_res((atom,phreg)::res,lss) = resolve_res(res,LS.ASSIGN{pat=LS.PHREG phreg,bind=LS.ATOM atom}::lss) fun CC_sw CC_lss (LS.SWITCH(atom_arg,sels,default)) = @@ -97,7 +97,7 @@ struct fun CC_ls(LS.FNJMP{opr,args,clos,res,bv},rest) = let - val ({clos,args,res,...},assign_list_args,assign_list_res) = + val ({clos,args,res,...},assign_list_args,assign_list_res) = CallConv.resolve_app RI.args_phreg RI.res_phreg LS.PHREG {clos=clos,args=args,reg_vec=NONE,reg_args=[],res=res} in resolve_res(assign_list_args, @@ -106,7 +106,7 @@ struct end | CC_ls(LS.FNCALL{opr,args,clos,res,bv},rest) = let - val ({clos,args,res,...},assign_list_args,assign_list_res) = + val ({clos,args,res,...},assign_list_args,assign_list_res) = CallConv.resolve_app RI.args_phreg RI.res_phreg LS.PHREG {clos=clos,args=args,reg_vec=NONE,reg_args=[],res=res} in resolve_res(assign_list_args, @@ -115,7 +115,7 @@ struct end | CC_ls(LS.JMP{opr,args,reg_vec,reg_args,clos,res,bv},rest) = let - val ({clos,args,res,reg_vec,reg_args},assign_list_args,assign_list_res) = + val ({clos,args,res,reg_vec,reg_args},assign_list_args,assign_list_res) = CallConv.resolve_app RI.args_phreg RI.res_phreg LS.PHREG {clos=clos,args=args,reg_vec=reg_vec,reg_args=reg_args,res=res} in resolve_res(assign_list_args, @@ -124,7 +124,7 @@ struct end | CC_ls(LS.FUNCALL{opr,args,reg_vec,reg_args,clos,res,bv},rest) = let - val ({clos,args,res,reg_vec,reg_args},assign_list_args,assign_list_res) = + val ({clos,args,res,reg_vec,reg_args},assign_list_args,assign_list_res) = CallConv.resolve_app RI.args_phreg RI.res_phreg LS.PHREG {clos=clos,args=args,reg_vec=reg_vec,reg_args=reg_args,res=res} in resolve_res(assign_list_args, @@ -133,7 +133,7 @@ struct end | CC_ls(LS.LETREGION{rhos,body},rest) = LS.LETREGION{rhos=rhos,body=CC_lss body}::rest | CC_ls(LS.SCOPE{pat,scope},rest) = LS.SCOPE{pat=pat,scope=CC_lss scope}::rest - | CC_ls(LS.HANDLE{default,handl=(handl,handl_lv),handl_return=([],handl_return_lv,bv),offset},rest) = + | CC_ls(LS.HANDLE{default,handl=(handl,handl_lv),handl_return=([],handl_return_lv,bv),offset},rest) = LS.HANDLE{default=CC_lss default,handl=(CC_lss handl,handl_lv),handl_return=([],handl_return_lv,bv),offset=offset}::rest | CC_ls(LS.HANDLE{default,handl,handl_return,offset},rest) = die "CC_ls: handl_return in HANDLE not empty" | CC_ls(LS.SWITCH_I {switch,precision},rest) = LS.SWITCH_I {switch=CC_sw CC_lss switch, @@ -143,18 +143,18 @@ struct | CC_ls(LS.SWITCH_S sw,rest) = LS.SWITCH_S(CC_sw CC_lss sw)::rest | CC_ls(LS.SWITCH_C sw,rest) = LS.SWITCH_C(CC_sw CC_lss sw)::rest | CC_ls(LS.SWITCH_E sw,rest) = LS.SWITCH_E(CC_sw CC_lss sw)::rest - | CC_ls(LS.CCALL{name,args,rhos_for_result,res},rest) = + | CC_ls(LS.CCALL{name,args,rhos_for_result,res},rest) = let - val ({args,rhos_for_result,res},assign_list_args,assign_list_res) = + val ({args,rhos_for_result,res},assign_list_args,assign_list_res) = CallConv.resolve_ccall RI.args_phreg_ccall RI.res_phreg_ccall LS.PHREG {args=args,rhos_for_result=rhos_for_result,res=res} in resolve_res(assign_list_args, LS.CCALL{name=name,args=args,rhos_for_result=rhos_for_result,res=res}:: resolve_args(assign_list_res,rest)) end - | CC_ls(LS.CCALL_AUTO{name,args,res},rest) = + | CC_ls(LS.CCALL_AUTO{name,args,res},rest) = let - val ({args,res},assign_list_args,assign_list_res) = + val ({args,res},assign_list_args,assign_list_res) = CallConv.resolve_ccall_auto RI.args_phreg_ccall RI.res_phreg_ccall LS.PHREG {args=args,res=res} in resolve_res(assign_list_args, @@ -162,29 +162,29 @@ struct resolve_args(assign_list_res,rest)) end | CC_ls (ls,rest) = ls::rest - + and CC_lss(lss) = List.foldr (fn (ls,acc) => CC_ls(ls,acc)) [] lss in - fun CC_top_decl(LS.FUN(lab,cc,lss)) = + fun CC_top_decl(LS.FUN(lab,cc,lss)) = let val (cc',args,res) = CallConv.resolve_cc RI.args_phreg RI.res_phreg cc val args' = map (fn (lv,i) => (LS.VAR lv,i)) args val res' = map (fn (lv,i) => (LS.VAR lv,i)) res val body_lss = CC_lss(lss) - val body_args = + val body_args = LS.SCOPE{pat=map (mk_sty o #1) args,scope=resolve_args(args',body_lss)} val body_res = LS.SCOPE{pat=map (mk_sty o #1) res,scope=body_args::resolve_res(res',[])} in LS.FUN(lab,cc',[body_res]) end - | CC_top_decl(LS.FN(lab,cc,lss)) = + | CC_top_decl(LS.FN(lab,cc,lss)) = let val (cc',args,res) = CallConv.resolve_cc RI.args_phreg RI.res_phreg cc val args' = map (fn (lv,i) => (LS.VAR lv,i)) args val res' = map (fn (lv,i) => (LS.VAR lv,i)) res val body_lss = CC_lss(lss) - val body_args = + val body_args = LS.SCOPE{pat=map (mk_sty o #1) args,scope=resolve_args(args',body_lss)} val body_res = LS.SCOPE{pat=map (mk_sty o #1) res,scope=body_args::resolve_res(res',[])} @@ -203,10 +203,10 @@ struct * ----------------------------- *) fun ra_assign (assign : StoreTypeLI -> StoreType) lss = - let + let fun ra_assign_sw ra_assign_lss (LS.SWITCH(atom_arg,sels,default)) = LS.SWITCH(atom_arg,map (fn (s,lss) => (s,ra_assign_lss lss)) sels, ra_assign_lss default) - + fun ra_assign_ls ls = case ls of LS.ASSIGN a => LS.ASSIGN a @@ -218,14 +218,14 @@ struct | LS.FUNCALL a => LS.FUNCALL a | LS.LETREGION{rhos,body} => LS.LETREGION{rhos=rhos,body=ra_assign_lss body} | LS.SCOPE{pat,scope} => LS.SCOPE{pat=map assign pat,scope=ra_assign_lss scope} - | LS.HANDLE{default,handl=(handl,handl_lv),handl_return=([],handl_return_lv,bv),offset} => + | LS.HANDLE{default,handl=(handl,handl_lv),handl_return=([],handl_return_lv,bv),offset} => LS.HANDLE{default=ra_assign_lss default,handl=(ra_assign_lss handl,handl_lv), handl_return=([],handl_return_lv,bv),offset=offset} | LS.HANDLE{default,handl,handl_return,offset} => die "ra_dummy_ls: handl_return in HANDLE not empty" | LS.RAISE{arg,defined_atys} => LS.RAISE{arg=arg,defined_atys=defined_atys} - | LS.SWITCH_I {switch,precision} => LS.SWITCH_I{switch=ra_assign_sw ra_assign_lss switch, + | LS.SWITCH_I {switch,precision} => LS.SWITCH_I{switch=ra_assign_sw ra_assign_lss switch, precision=precision} - | LS.SWITCH_W {switch,precision} => LS.SWITCH_W{switch=ra_assign_sw ra_assign_lss switch, + | LS.SWITCH_W {switch,precision} => LS.SWITCH_W{switch=ra_assign_sw ra_assign_lss switch, precision=precision} | LS.SWITCH_S sw => LS.SWITCH_S(ra_assign_sw ra_assign_lss sw) | LS.SWITCH_C sw => LS.SWITCH_C(ra_assign_sw ra_assign_lss sw) @@ -235,26 +235,26 @@ struct | LS.CCALL a => LS.CCALL a | LS.CCALL_AUTO a => LS.CCALL_AUTO a | LS.EXPORT a => LS.EXPORT a - + and ra_assign_lss lss = List.foldr (fn (ls,acc) => ra_assign_ls ls :: acc) [] lss - + in ra_assign_lss lss end - + (* ----------------------------------- * Dummy Assignment; implement all * lambda variables on the stack. * ----------------------------------- *) fun ra_dummy_prg funcs = - let - fun assign(LS.V lv) = STACK_STY lv + let + fun assign(LS.V lv) = STACK_STY lv | assign(LS.FV lv) = FV_STY lv fun ra_assign_func assign func = - case func + case func of LS.FUN(lab,cc,lss) => LS.FUN(lab,cc,ra_assign assign lss) | LS.FN(lab,cc,lss) => LS.FN(lab,cc,ra_assign assign lss) - in + in foldr (fn (func,acc) => ra_assign_func assign (CC_top_decl func) :: acc) [] funcs end @@ -266,7 +266,7 @@ struct (* Invariant: no_of_nodes = coalesce + spills + assigned_colors *) (* Invariant: no_of_moves = coalesced_moves+constrained_moves+frozen_moves *) (* We do not consider pre-colored variables. *) - local + local val no_of_nodes = ref 0 val spills = ref 0 val assigned_colors = ref 0 @@ -281,7 +281,7 @@ struct val ml_call = ref 0 in fun fix_int i = StringCvt.padLeft #" " 7 (Int.toString i) - fun procent(t:int,b:int) = + fun procent(t:int,b:int) = if b=0 then "(---)" else @@ -340,7 +340,7 @@ struct | coloredNodes_enum => "colored" | selectStack_enum => "select" - datatype live_range_status = + datatype live_range_status = no_call | c_call | ml_call (* Does the live range cross a c-call or a ml-call. *) fun merge_lrs(no_call,s2) = s2 @@ -357,13 +357,13 @@ struct fun key' (n : node) = key(#lv n) (* Precolored nodes *) - val precolored : node list = + val precolored : node list = map (fn lv => {lv=lv,degree=ref 0, mv_related=ref NONE, worklist=ref precolored_enum, adjList=ref nil, alias = ref NONE, color=ref (SOME lv), lrs = ref no_call, uses = ref 0}) - RI.caller_save_phregs - fun reset_precolored() = + RI.caller_save_phregs + fun reset_precolored() = app (fn ({lv,degree, mv_related, worklist, adjList, alias, color, lrs, uses} : node) => (degree:=0; mv_related:=NONE; worklist:=precolored_enum; adjList:=nil; alias:=NONE; color:=SOME lv; lrs:=no_call; uses:=0)) @@ -376,29 +376,29 @@ struct val initial : node list ref = ref [] val simplifyWorklist : node list ref = ref [] val freezeWorklist : node list ref = ref [] - val spillWorklist : node list ref = ref [] + val spillWorklist : node list ref = ref [] val spilledNodes : node list ref = ref [] val coalescedNodes : node list ref = ref [] val coloredNodes : node list ref = ref [] val selectStack : node list ref = ref [] - + fun worklistsReset () = (initial := nil; simplifyWorklist := nil; freezeWorklist := nil; spillWorklist := nil; spilledNodes := nil; coalescedNodes := nil; coalescedNodes := nil; coloredNodes := nil; selectStack := nil) - + fun isEmpty nil = true | isEmpty _ = false - - local - fun norm (wle:worklist_enum) (wl:node list ref) : unit = + + local + fun norm (wle:worklist_enum) (wl:node list ref) : unit = wl := List.filter (fn n => !(#worklist n) = wle) (!wl) fun norm_simplifyWorklist () = norm simplifyWorklist_enum simplifyWorklist fun norm_freezeWorklist() = norm freezeWorklist_enum freezeWorklist fun norm_spillWorklist() = norm spillWorklist_enum spillWorklist - in + in fun isEmpty_simplifyWorklist() = (norm_simplifyWorklist(); isEmpty(!simplifyWorklist)) fun isEmpty_freezeWorklist() = @@ -420,24 +420,24 @@ struct datatype movelist_enum = coalescedMoves_enum | constrainedMoves_enum | frozenMoves_enum | worklistMoves_enum | activeMoves_enum - + type move = {lv1:lvar, lv2:lvar, movelist:movelist_enum ref} (* why is a move not an instruction? There may be several moves from lv1 into lv2; hmm, no because we use SML *) - + (* Move lists *) val coalescedMoves : move list ref = ref [] val constrainedMoves : move list ref = ref [] val frozenMoves : move list ref = ref [] val worklistMoves : move list ref = ref [] val activeMoves : move list ref = ref [] - + fun movelistsReset() = (coalescedMoves := nil; constrainedMoves := nil; frozenMoves := nil; worklistMoves := nil; activeMoves := nil) - + local - fun norm (mle:movelist_enum) (ml:move list ref) : unit= + fun norm (mle:movelist_enum) (ml:move list ref) : unit= ml := List.filter (fn m => !(#movelist m) = mle) (!ml) - in + in fun norm_worklistMoves () = norm worklistMoves_enum worklistMoves fun isEmpty_worklistMoves() = (norm_worklistMoves(); isEmpty(!worklistMoves)) @@ -458,9 +458,9 @@ struct val nTable : (int*node)list Array.array = Array.array (512,nil) fun hash i = Word.toInt(Word.andb(Word.fromInt i, 0w511)) in - fun nTableLookup i : node option = + fun nTableLookup i : node option = let fun find [] = NONE - | find ((i',e)::is) = if i=i' then SOME e else find is + | find ((i',e)::is) = if i=i' then SOME e else find is in find (Array.sub(nTable, hash i)) end fun nTableAdd (i:int,n:node) : unit = @@ -491,9 +491,9 @@ struct fun hash i = Word.toInt(Word.andb(Word.fromInt i, 0w511)) in fun moveListReset () : unit = Array.modify (fn _ => nil) mTable - fun moveListLookup i : move list = + fun moveListLookup i : move list = let fun find [] = nil - | find ((i',ms)::is) = if i=i' then ms else find is + | find ((i',ms)::is) = if i=i' then ms else find is in find (Array.sub(mTable, hash i)) end fun moveListAdd (i:int,m:move) : unit = @@ -509,26 +509,26 @@ struct structure M = IntFinMap val mTable : (move list ref) M.map ref = ref M.empty in - fun moveListLookup i : move list = + fun moveListLookup i : move list = case M.lookup (!mTable) i - of SOME rl => !rl + of SOME rl => !rl | NONE => nil - fun moveListAdd (i:int, m:move) : unit = + fun moveListAdd (i:int, m:move) : unit = case M.lookup (!mTable) i of SOME rl => rl := m :: !rl | NONE => mTable := M.add(i,ref [m],!mTable) fun moveListReset() = mTable := M.empty end (* - local + local val adjSet : (int*int)list Array.array = Array.array (1024,nil) fun hash (i1,i2) = Word.toInt(Word.andb(0w65599 * Word.fromInt i1 + Word.fromInt i2, 0w1023)) fun order (i1:int,i2:int) = if i2 < i1 then (i2,i1) else (i1,i2) fun find (p:int*int) [] = false | find p ((p':int*int)::ps) = (#1 p' = #1 p andalso #2 p' = #2 p) orelse find p ps - in + in fun adjSetReset() : unit = Array.modify (fn _ => nil) adjSet - fun adjSetMember (p:int*int) : bool = + fun adjSetMember (p:int*int) : bool = let val p = order p in find p (Array.sub(adjSet, hash p)) end @@ -545,12 +545,12 @@ struct structure M = IntFinMap val adjSet : (S.Set ref) M.map ref = ref M.empty in - fun adjSetMember (i1,i2) : bool = + fun adjSetMember (i1,i2) : bool = if i1 < i2 then (case M.lookup (!adjSet) i1 of SOME s => S.member (Word.fromInt i2) (!s) | NONE => false) else adjSetMember(i2,i1) - fun adjSetAdd (i1,i2) : unit = + fun adjSetAdd (i1,i2) : unit = if i1 < i2 then (case M.lookup (!adjSet) i1 of SOME s => if S.member (Word.fromInt i2) (!s) then () else s := S.insert (Word.fromInt i2) (!s) @@ -559,21 +559,21 @@ struct fun adjSetReset() = adjSet := M.empty end - fun raReset () = (worklistsReset(); movelistsReset(); nTableReset(); + fun raReset () = (worklistsReset(); movelistsReset(); nTableReset(); moveListReset(); adjSetReset(); reset_precolored()) fun lvarset_atom a = Lvarset.lvarsetof(LS.get_var_atom(a,nil)) fun Adjecent (n:node) : node list = foldl (fn (lv,acc) => case nTableLookup (key lv) - of SOME n => + of SOME n => (case !(#worklist n) of selectStack_enum => acc | coalescedNodes_enum => acc | _ => n::acc) | NONE => die "Adjecent") nil (!(#adjList n)) - fun NodeMoves (n:node) : move list = + fun NodeMoves (n:node) : move list = foldl (fn (m,acc) => case !(#movelist m) of activeMoves_enum => m::acc (* nodes that have never been potentially *) | worklistMoves_enum => m::acc (* nodes that are already potentially *) @@ -582,31 +582,37 @@ struct fun MoveRelated (n:node) : bool = case NodeMoves n of nil => false | _ => true - + fun EnableMoves (nodes:node list) : unit = app (fn n => app (fn m => case !(#movelist m) of activeMoves_enum => worklistMovesAdd m | _ => ()) (NodeMoves n)) nodes - fun GetAlias (k : int) : node = + fun GetAlias (lv:lvar) (k : int) : node = case nTableLookup k of SOME n => - if !(#worklist n) = coalescedNodes_enum then + if !(#worklist n) = coalescedNodes_enum then case !(#alias n) - of SOME i => GetAlias i - | NONE => die "GetAlias.1" + of SOME i => GetAlias (#lv n) i + | NONE => die ("GetAlias.1: lvar=" ^ Lvars.pr_lvar lv) else n - | NONE => die "GetAlias.2" + | NONE => die ("GetAlias.2: lvar=" ^ Lvars.pr_lvar lv) - fun pr_node ({lv,degree,mv_related,worklist = ref wl,adjList,alias = ref NONE,color = ref (SOME color_lv),lrs,uses}:node) = - "{key: " ^ Int.toString (key lv) ^ ",lv:" ^ Lvars.pr_lvar lv ^ ",alias:NONE,color:" ^ + fun GetAliasLv (lv:lvar) : node = + GetAlias lv (key lv) + + fun GetAliasNode (n:node) : node = + GetAliasLv (#lv n) + + fun pr_node ({lv,degree,mv_related,worklist = ref wl,adjList,alias = ref NONE,color = ref (SOME color_lv),lrs,uses}:node) = + "{key: " ^ Int.toString (key lv) ^ ",lv:" ^ Lvars.pr_lvar lv ^ ",alias:NONE,color:" ^ Lvars.pr_lvar color_lv ^ ",wl:" ^ pr_worklist wl ^ "}" - | pr_node {lv,degree,mv_related,worklist = ref wl,adjList,alias = ref (SOME a_id),color = ref (SOME color_lv),lrs,uses} = - "{key: " ^ Int.toString (key lv) ^ ",lv:" ^ Lvars.pr_lvar lv ^ ",alias:" ^ - Lvars.pr_lvar (#lv(GetAlias a_id)) ^ ",color:" ^ Lvars.pr_lvar color_lv ^ ",wl:" ^ pr_worklist wl ^ "}" - | pr_node {lv,degree,mv_related,worklist = ref wl,adjList,alias = ref (SOME a_id),color = ref NONE,lrs,uses} = - "{key: " ^ Int.toString (key lv) ^ ",lv:" ^ Lvars.pr_lvar lv ^ ",alias:" ^ - Lvars.pr_lvar (#lv(GetAlias a_id)) ^ ",wl:" ^ pr_worklist wl ^ ",color:NONE}" + | pr_node {lv,degree,mv_related,worklist = ref wl,adjList,alias = ref (SOME a_id),color = ref (SOME color_lv),lrs,uses} = + "{key: " ^ Int.toString (key lv) ^ ",lv:" ^ Lvars.pr_lvar lv ^ ",alias:" ^ + Lvars.pr_lvar (#lv(GetAlias lv a_id)) ^ ",color:" ^ Lvars.pr_lvar color_lv ^ ",wl:" ^ pr_worklist wl ^ "}" + | pr_node {lv,degree,mv_related,worklist = ref wl,adjList,alias = ref (SOME a_id),color = ref NONE,lrs,uses} = + "{key: " ^ Int.toString (key lv) ^ ",lv:" ^ Lvars.pr_lvar lv ^ ",alias:" ^ + Lvars.pr_lvar (#lv(GetAlias lv a_id)) ^ ",wl:" ^ pr_worklist wl ^ ",color:NONE}" | pr_node {lv,degree,mv_related,worklist = ref wl,adjList,alias = ref NONE,color = ref NONE,lrs,uses} = "{key: " ^ Int.toString (key lv) ^ ",lv:" ^ Lvars.pr_lvar lv ^ ",wl:" ^ pr_worklist wl ^ ",alias:NONE,color:NONE}" @@ -617,7 +623,7 @@ struct in #degree m := d - 1; if d = K then (EnableMoves(m :: Adjecent m); - if MoveRelated m then freezeWorklistAdd m + if MoveRelated m then freezeWorklistAdd m else simplifyWorklistAdd m) else () end @@ -635,37 +641,37 @@ struct fun AddEdge (u : lvar ,v : lvar) : unit = let val (u_key, v_key) = (key u, key v) - in + in if u_key = v_key orelse adjSetMember(u_key, v_key) then () - else - (adjSetAdd(u_key,v_key); + else + (adjSetAdd(u_key,v_key); case nTableLookup u_key of SOME u_node => (case nTableLookup v_key - of SOME v_node => - (if !(#worklist u_node) <> precolored_enum then + of SOME v_node => + (if !(#worklist u_node) <> precolored_enum then ((#adjList u_node) := v :: !(#adjList u_node); (#degree u_node) := !(#degree u_node) + 1) else (); - if !(#worklist v_node) <> precolored_enum then + if !(#worklist v_node) <> precolored_enum then ((#adjList v_node) := u :: !(#adjList v_node); (#degree v_node) := !(#degree v_node) + 1) else ()) | NONE => () (*mael die ("AddEdge.nTableLookup v_key: " ^ Lvars.pr_lvar v) *)) | NONE => () (*mael die ("AddEdge.nTableLookup u_key: " ^ Lvars.pr_lvar u) *)) - end + end - fun MakeWorklist() = - let + fun MakeWorklist () = + let fun do_n n = - if !(#degree n) >= K then + if !(#degree n) >= K then spillWorklistAdd n - else - if MoveRelated n then + else + if MoveRelated n then freezeWorklistAdd n - else + else simplifyWorklistAdd n - in + in app do_n (!initial) end @@ -677,14 +683,14 @@ struct fun OK (t : node, r : node) : bool = !(#degree t) < K orelse !(#worklist t) = precolored_enum orelse adjSetMember(key' t, key' r) - fun Conservative(nodes:lvarset) : bool = + fun Conservative (nodes:lvarset) : bool = let val nodes = map (fn lv => case nTableLookup (key lv) of SOME n => n | NONE => die "Conservative") (Lvarset.members nodes) in (foldl (fn (n,k) => if !(#degree n) >= K then k+1 else k) 0 nodes) < K end - fun Combine(u : node, v : node) : unit = (* v is never precolored *) + fun Combine (u : node, v : node) : unit = (* v is never precolored *) (coalescedNodesAdd v; if !(#worklist u) <> precolored_enum then (* We only merge lrs for non precolored lvars. 19/03/1999, Niels *) #lrs u := merge_lrs(!(#lrs u),!(#lrs v)) @@ -699,12 +705,12 @@ struct spillWorklistAdd u else ()) - fun Coalesce() : unit = (* invariant : worklistMoves is normalised and non-empty *) + fun Coalesce () : unit = (* invariant : worklistMoves is normalised and non-empty *) case !worklistMoves of (m as {lv1,lv2,movelist}) :: _ => - let - val x = GetAlias (key lv1) - val y = GetAlias (key lv2) + let + val x = GetAliasLv lv1 + val y = GetAliasLv lv2 val (u,v) = if !(#worklist y) = precolored_enum then (y,x) else (x,y) in if key' u = key' v then (coalescedMovesAdd m; @@ -715,7 +721,7 @@ struct constrainedMovesAdd m; AddWorkList u; AddWorkList v) - else if (!(#worklist u) = precolored_enum andalso + else if (!(#worklist u) = precolored_enum andalso (foldl (fn (t, acc) => acc andalso OK(t,u)) true (Adjecent v))) orelse (!(#worklist u) <> precolored_enum andalso @@ -731,8 +737,8 @@ struct fun FreezeMoves (u: node) : unit = let fun on_move (m as {lv1=x,lv2=y,movelist}) : unit = - let val v = if key'(GetAlias (key y)) = key'(GetAlias(key' u)) then GetAlias(key x) - else GetAlias(key y) + let val v = if key'(GetAliasLv y) = key'(GetAliasNode u) then GetAliasLv x + else GetAliasLv y in inc_frozen(); frozenMovesAdd m; @@ -743,25 +749,25 @@ struct in app on_move (NodeMoves u) end - fun Freeze() : unit = (* invariant : freezeWorklist is normalised and non-empty *) + fun Freeze () : unit = (* invariant : freezeWorklist is normalised and non-empty *) case !freezeWorklist of u :: _ => (simplifyWorklistAdd u; FreezeMoves u) | _ => die "Freeze" - fun SelectSpill() : unit = (* invariant : spillWorklist is normalised and non-empty *) + fun SelectSpill () : unit = (* invariant : spillWorklist is normalised and non-empty *) let - fun lrs_factor(no_call) = 1.0 - | lrs_factor(c_call) = 1.2 - | lrs_factor(ml_call) = 1.5 + fun lrs_factor no_call = 1.0 + | lrs_factor c_call = 1.2 + | lrs_factor ml_call = 1.5 fun pri (n:node) = Real.fromInt(!(#uses n)) / Real.fromInt(!(#degree n)) (**lrs_factor(!(#lrs n))06/04/1999, Niels*) fun select_spill() = (* use lowest priority: uses/degree*lrs_factor *) case !spillWorklist of - m :: rest => #1(foldl (fn (n,(m,mpri)) => + m :: rest => #1(foldl (fn (n,(m,mpri)) => let val npri = pri n in if mpri < npri then (m,mpri) else (n,npri) end) (m,pri m) rest) | _ => die "SelectSpill.select_spill" - fun order_mv_related(n:node,m:node) = + fun order_mv_related(n:node,m:node) = if List.length(NodeMoves n) < List.length(NodeMoves m) then n else m fun select_spill2() = (* spill non-move related nodes *) case !spillWorklist of @@ -772,55 +778,62 @@ struct (simplifyWorklistAdd m; FreezeMoves m) end - fun AssignColors() : unit = +(* val caller_save_regs = Lvarset.union(RI.args_ccall_phregset, RI.caller_save_phregset) *) + val caller_save_regs = RI.caller_save_phregset +(* val callee_save_regs = Lvarset.difference(RI.callee_save_ccall_phregset, RI.caller_save_phregset) (* subtract rbx *) *) + val callee_save_regs = Lvarset.empty + + fun AssignColors () : unit = let fun assign_color (n:node,pri1,pri2,notOkColors) = (case Lvarset.members (Lvarset.difference(pri1,notOkColors)) of nil => (case Lvarset.members (Lvarset.difference(pri2,notOkColors)) of - nil => (spilledNodesAdd (n:node); inc_spills()) - | c::_ => (coloredNodesAdd (n:node); #color (n:node) := SOME c; inc_assigned_colors())) - | c::_ => (coloredNodesAdd (n:node); #color (n:node) := SOME c; inc_assigned_colors())) + nil => (spilledNodesAdd n; inc_spills()) + | c::_ => (coloredNodesAdd n; #color n := SOME c; inc_assigned_colors())) + | c::_ => (coloredNodesAdd n; #color n := SOME c; inc_assigned_colors())) fun find_color (n:node,notOkColors) = - if !(#lrs n) = ml_call then - (inc_ml_call(); assign_color(n,RI.callee_save_ccall_phregset,RI.caller_save_phregset,notOkColors)) - else - if !(#lrs n) = c_call then - (inc_c_call(); assign_color(n,RI.callee_save_ccall_phregset,RI.caller_save_phregset,notOkColors)) - else - (inc_no_call(); assign_color(n,RI.caller_save_phregset,RI.callee_save_ccall_phregset,notOkColors)) + case !(#lrs n) of + c_call => (* means: only ccall *) + (inc_c_call(); assign_color(n,callee_save_regs,Lvarset.empty,notOkColors)) (* RI.caller_save_phregset*) + | ml_call => (* means: ml call and/or c call; we have to be carefull that rbx is not assigned as it may be destroyed by an ml-call *) + (inc_ml_call(); assign_color(n,callee_save_regs,Lvarset.empty,notOkColors)) + | no_call => + (* prioritise to use caller-save regs so that callee-save regs are + * available for those variables with live ranges accross calls *) + (inc_no_call(); assign_color(n,caller_save_regs,RI.callee_save_ccall_phregset,notOkColors)) (* fun find_color_simple (n:node,notOkColors) = let - val okColors = Lvarset.difference(allColors,notOkColors) + val okColors = Lvarset.difference(allColors,notOkColors) in case Lvarset.members okColors of nil => (spilledNodesAdd (n:node); inc_spills()) | c::_ => (coloredNodesAdd (n:node); #color (n:node) := SOME c; inc_assigned_colors()) end -*) +*) fun pop_loop (ns : node list) = case ns of nil => app (fn n => if !(#worklist n) = coalescedNodes_enum then - (#color n := !(#color(GetAlias(key' n))); inc_assigned_colors()) + (#color n := !(#color(GetAliasNode n)); inc_assigned_colors()) else ()) (!coalescedNodes) | n::ns => - let + let val _ = if !(#worklist n) = coalescedNodes_enum then die "assigning color to coalesced node" else () - val notOkColors = + val notOkColors = foldl (fn (w:lvar,set) => - let val n = GetAlias(key w) + let val n = GetAliasLv w in if (case !(#worklist n) of coloredNodes_enum => true | precolored_enum => true | _ => false) then - case !(#color(GetAlias(key w))) + case !(#color(GetAliasLv w)) of SOME c => Lvarset.add(set,c) | NONE => die "pop_loop" else set end) Lvarset.empty (!(#adjList n)) - in + in find_color(*_simple*)(n,notOkColors); pop_loop ns end @@ -831,57 +844,59 @@ struct * the function on the stack! *) fun MakeInitial (args_on_stack_lvs, lss) = - let - fun add_use lv = - let - val i = key lv + let + fun add_use lv = + let + val i = key lv in case nTableLookup i of SOME n => #uses n := !(#uses n) + 1 | NONE => () (*mael die ("MakeInitial.add_use: " ^ Lvars.pr_lvar lv ^ " not in nTableLookup") *) end - fun add lv = - let - val i = key lv - in + fun add lv = + let + val i = key lv + in case nTableLookup i of SOME n => () (* Multiple definition in switch *) - | NONE => let + | NONE => let val n : node = {lv=lv,degree=ref 0, mv_related=ref NONE, worklist=ref initial_enum, adjList=ref nil, alias = ref NONE, color=ref NONE, lrs = ref no_call, uses = ref 0} - in + in nTableAdd(i,n); initial := n :: !initial; inc_initial() end end fun mk_sw mk (LS.SWITCH(a,sels,default)) = - (app add_use (LS.get_var_atom(a,nil)); - app (fn (_,lss) => app mk lss) sels; + (app add_use (LS.get_var_atom(a,nil)); + app (fn (_,lss) => app mk lss) sels; app mk default) + fun default ls = + let val (def,use) = LS.def_use_lvar_ls ls + in app add def; + app add_use use + end fun mk ls = case ls of LS.FLUSH _ => die "MakeInitial: FLUSH not inserted yet." | LS.FETCH _ => die "MakeInitial: FETCH not inserted yet." | LS.LETREGION{rhos,body} => app mk body | LS.SCOPE{pat,scope} => app mk scope - | LS.HANDLE{default,handl=(handl_lss,handl_lv),handl_return=(handl_return_lss,handl_return_lv,bv),offset} => + | LS.HANDLE{default,handl=(handl_lss,handl_lv),handl_return=(handl_return_lss,handl_return_lv,bv),offset} => (app add (LS.get_var_atom (handl_lv,nil)); app add (LS.get_var_atom (handl_return_lv,nil)); app mk handl_lss; - app mk default; + app mk default; app mk handl_return_lss) | LS.SWITCH_I {switch,precision} => mk_sw mk switch | LS.SWITCH_W {switch,precision} => mk_sw mk switch | LS.SWITCH_S sw => mk_sw mk sw | LS.SWITCH_C sw => mk_sw mk sw | LS.SWITCH_E sw => mk_sw mk sw - | _ => let - val (def,use) = LS.def_use_lvar_ls ls - in - app add def; - app add_use use - end + | ls as LS.CCALL _ => (app add RI.args_phreg_ccall; default ls) + | ls as LS.CCALL_AUTO _ => (app add RI.args_phreg_ccall; default ls) + | ls => default ls in app mk lss end @@ -890,8 +905,8 @@ struct * the IG because they are not to be colored. *) fun Build (args_on_stack_lvs, lss) = - let - fun set_lrs_status new_s lv = + let + fun set_lrs_status new_s lv = case nTableLookup (key lv) of SOME {lrs = (lrs as ref old_s),...} => lrs := merge_lrs(old_s,new_s) | NONE => die "set_lrs_status - nTableLookup failed" @@ -903,21 +918,21 @@ struct fun use_var_ls ls = Lvarset.difference(Lvarset.lvarsetof(LS.use_var_ls ls), args_on_stack_lvs) fun ig_sw (ig_lss, LS.SWITCH (a, sel, def), L) = - let val Ls = map (fn (_, lss) => ig_lss(lss, L)) sel + let val Ls = map (fn (_, lss) => ig_lss(lss, L)) sel val L = foldl Lvarset.union (ig_lss(def,L)) Ls in Lvarset.union (L, Lvarset.difference(lvarset_atom a, args_on_stack_lvs)) end fun do_non_tail_call (L, ls) = - let + let val (def, use) = def_use_var_ls ls (* def=flv(res) *) val lvars_to_flush = Lvarset.difference(L,def) - val _ = + val _ = case ls of LS.CCALL _ => lvarset_app (set_lrs_status c_call) lvars_to_flush | LS.CCALL_AUTO _ => lvarset_app (set_lrs_status c_call) lvars_to_flush | _ => lvarset_app (set_lrs_status ml_call) lvars_to_flush val L = Lvarset.union(L,def) (* We insert edges between def'ed variables *) - val _ = lvarset_app (fn d => lvarset_app (fn u => AddEdge(d,u)) L) def + val _ = lvarset_app (fn d => lvarset_app (fn u => AddEdge(d,u)) L) def val L = Lvarset.union(use, lvars_to_flush(*Lvarset.difference(L,def)*)) in L end @@ -927,7 +942,7 @@ struct val L = use_var_ls ls in L end - fun do_record(L,ls) = (* We must insert edges between def and use! *) + fun do_record (L,ls) = (* We must insert edges between def and use! *) let val (def,use) = def_use_var_ls ls val L' = Lvarset.union(Lvarset.union(L,def),use) @@ -936,7 +951,7 @@ struct in L end - fun do_move(L,lv1,lv2) = (* lv1 <-- lv2 *) + fun do_move (L,lv1,lv2) = (* lv1 <-- lv2 *) if Lvarset.member(lv1, args_on_stack_lvs) then if Lvarset.member(lv2, args_on_stack_lvs) then L @@ -945,30 +960,30 @@ struct (lvarset_app (fn l => AddEdge(l,lv1)) L; Lvarset.delete(L,lv1)) else - let + let val _ = inc_moves() val move : move = {lv1=lv1, lv2=lv2, movelist=ref worklistMoves_enum} val _ = (moveListAdd(key lv1, move); moveListAdd(key lv2, move)) - val _ = worklistMovesAdd move - val _ = lvarset_app (fn l => AddEdge(l,lv1)) (Lvarset.delete(L,lv2)) - val L = Lvarset.add(Lvarset.delete(L,lv1),lv2) + val _ = worklistMovesAdd move + val _ = lvarset_app (fn l => AddEdge(l,lv1)) (Lvarset.delete(L,lv2)) + val L = Lvarset.add(Lvarset.delete(L,lv1),lv2) in L end - fun remove_finite_rhos([]) = [] - | remove_finite_rhos(((place,LS.WORDS i),offset)::rest) = remove_finite_rhos rest - | remove_finite_rhos(rho::rest) = rho :: remove_finite_rhos rest + fun remove_finite_rhos ([]) = [] + | remove_finite_rhos (((place,LS.WORDS i),offset)::rest) = remove_finite_rhos rest + | remove_finite_rhos (rho::rest) = rho :: remove_finite_rhos rest fun ig_ls (ls, L) = case ls of LS.FLUSH _ => die "ig_ls: FLUSH not inserted yet." | LS.FETCH _ => die "ig_ls: FETCH not inserted yet." - | LS.FNJMP _ => do_tail_call(L,ls) + | LS.FNJMP _ => do_tail_call(L,ls) | LS.FNCALL _ => do_non_tail_call(L,ls) - | LS.JMP _ => do_tail_call(L,ls) + | LS.JMP _ => do_tail_call(L,ls) | LS.FUNCALL _ => do_non_tail_call(L,ls) - | LS.LETREGION{rhos,body} => + | LS.LETREGION{rhos,body} => let val L' = ig_lss(body,L) - + (* Infinite letregions involve C calls and so do * finite regions when profiling is enabled. C calls * are involved both at entrance to the body and at @@ -979,9 +994,9 @@ struct * setting is not crucial for soundness of the * register allocator. *) - (* Update live range status for live variables, if C + (* Update live range status for live variables, if C * calls are involved. *) - val _ = if List.null rhos orelse ( not(region_profiling()) + val _ = if List.null rhos orelse ( not(region_profiling()) andalso List.null (remove_finite_rhos rhos) ) then () else (lvarset_app (set_lrs_status c_call) L ; lvarset_app (set_lrs_status c_call) L') @@ -1063,18 +1078,18 @@ struct move_set := EdgeSet.insert (s1,s2) (!move_set) else move_set := EdgeSet.insert (s2,s1) (!move_set) - fun pp_edge (s1,s2,linestyle) = + fun pp_edge (s1,s2,linestyle) = "edge: {arrowstyle: none linestyle: " ^ linestyle ^ " sourcename: \"" ^ s1 ^ "\" targetname: \"" ^ s2 ^ "\" }\n" fun export_nodes stream = - let - fun do_n (n : node) = + let + fun do_n (n : node) = (TextIO.output(stream, "node: { title:\"" ^ pr_node n ^ "\" label:\"" ^ pr_node n ^ "\" }\n"); List.app (fn lv => add_edge(pr_node n, Lvars.pr_lvar lv)) (!(#adjList n)); List.app (fn (m:move) => add_move(Lvars.pr_lvar (#lv1 m),Lvars.pr_lvar (#lv2 m))) (NodeMoves n)) fun export_edges() = (EdgeSet.apply (fn (s1,s2) => TextIO.output(stream, pp_edge(s1,s2,"continuous"))) (!edge_set); EdgeSet.apply (fn (s1,s2) => TextIO.output(stream, pp_edge(s1,s2, "dotted"))) (!move_set)) - in + in (app do_n (!initial); app do_n precolored; export_edges()) @@ -1095,7 +1110,7 @@ struct else () end - + fun ra_body (fun_name, args_on_stack_lvs, lss) = let fun repeat() = (if not(isEmpty_simplifyWorklist()) then Simplify() @@ -1106,31 +1121,38 @@ struct if isEmpty_simplifyWorklist() andalso isEmpty_worklistMoves() andalso isEmpty_freezeWorklist() andalso isEmpty_spillWorklist() then () else repeat()) - - fun assign(LS.V lv) = + + fun assign(LS.V lv) = (case nTableLookup (key lv) - of SOME n => + of SOME n => (case !(#color n) of SOME c => PHREG_STY (lv,c) | NONE => STACK_STY lv) | NONE => die "ra_body.assign: lvar not assigned a color") - | assign(LS.FV lv) = FV_STY lv - - val _ = (raReset(); + | assign(LS.FV lv) = FV_STY lv + + val _ = (raReset(); MakeInitial (args_on_stack_lvs, lss); - Build (args_on_stack_lvs, lss); - export_ig ("/net/skuld/vol/topps/disk02/MLKIT-afterVersion1/niels/.trash/" ^ fun_name ^ ".vcg"); - MakeWorklist(); - repeat(); - AssignColors()) - + (*print ("MakeInitial done - " ^ fun_name ^ "\n");*) + Build (args_on_stack_lvs, lss); + (*print ("Build done\n");*) + (*export_ig ("/net/skuld/vol/topps/disk02/MLKIT-afterVersion1/niels/.trash/" ^ fun_name ^ ".vcg");*) + MakeWorklist(); + (*print ("MakeWorklist done\n");*) + repeat(); + (*print ("repeat done\n");*) + AssignColors(); + (*print ("AssignColors done\n");*) + () + ) + val res = ra_assign assign lss in raReset(); res end - + fun ra_top_decl f = - let - val f = CC_top_decl f + let + val f = CC_top_decl f fun process (lab,cc,lss) = let val args_on_stack_lvs = Lvarset.lvarsetof(CallConv.get_spilled_args cc) @@ -1139,16 +1161,16 @@ struct in (* fast_pr (LineStmt.layout_line_prg LineStmt.pr_sty (fn _ => "") pr_atom false [f]); *) case f - of LS.FUN f => LS.FUN(process f) + of LS.FUN f => LS.FUN(process f) | LS.FN f => LS.FN(process f) end - fun ra_prg funcs = + fun ra_prg funcs = foldr (fn (func,acc) => ra_top_decl func :: acc) [] funcs - - (******************************************************) - (* Funtion to invoke the register allocator of choice *) - (******************************************************) + + (*******************************************************) + (* Function to invoke the register allocator of choice *) + (*******************************************************) fun ra_main {main_lab:label, code=line_prg: (StoreTypeLI,unit,Atom) LinePrg, imports:label list * label list, @@ -1157,9 +1179,9 @@ struct val _ = chat "[Register allocation..." val _ = reset_stat() val line_prg_ra = ra_prg line_prg - val _ = + val _ = if Flags.is_on "print_register_allocated_program" then - display("\nReport: AFTER REGISTER ALLOCATION", + display("\nReport: AFTER REGISTER ALLOCATION", LS.layout_line_prg pr_sty (fn _ => "()") pr_atom false line_prg_ra) else () diff --git a/src/Compiler/Backend/X64/.gitignore b/src/Compiler/Backend/X64/.gitignore new file mode 100644 index 000000000..f1a62a145 --- /dev/null +++ b/src/Compiler/Backend/X64/.gitignore @@ -0,0 +1 @@ +MLB \ No newline at end of file diff --git a/src/Compiler/Backend/X64/CodeGenX64.sml b/src/Compiler/Backend/X64/CodeGenX64.sml new file mode 100644 index 000000000..16f36e2fb --- /dev/null +++ b/src/Compiler/Backend/X64/CodeGenX64.sml @@ -0,0 +1,3523 @@ +(* Generate Target Code *) + +functor CodeGenX64(structure BackendInfo : BACKEND_INFO + where type label = AddressLabels.label + structure JumpTables : JUMP_TABLES + structure CallConv: CALL_CONV + where type lvar = Lvars.lvar + structure LineStmt: LINE_STMT + where type con = Con.con + where type excon = Excon.excon + where type lvar = Lvars.lvar + where type label = AddressLabels.label + where type place = Effect.effect + where type StringTree = PrettyPrint.StringTree + sharing type CallConv.cc = LineStmt.cc + structure SubstAndSimplify: SUBST_AND_SIMPLIFY + where type ('a,'b,'c) LinePrg = ('a,'b,'c) LineStmt.LinePrg + where type lvar = Lvars.lvar + where type place = Effect.effect + where type reg = InstsX64.reg + where type label = AddressLabels.label) + : CODE_GEN = +struct + structure PP = PrettyPrint + structure Labels = AddressLabels + structure I = InstsX64 + structure RI = I.RI (* RegisterInfo *) + structure BI = BackendInfo + structure SS = SubstAndSimplify + structure LS = LineStmt + + val region_profiling : unit -> bool = Flags.is_on0 "region_profiling" + + type label = Labels.label + type ('sty,'offset,'aty) LinePrg = ('sty,'offset,'aty) LineStmt.LinePrg + type StoreTypeCO = SubstAndSimplify.StoreTypeCO + type AtySS = SubstAndSimplify.Aty + datatype reg = datatype I.reg + datatype ea = datatype I.ea + datatype lab = datatype I.lab + type offset = int + type AsmPrg = I.AsmPrg + + val tmp_reg0 = I.tmp_reg0 + val tmp_reg1 = I.tmp_reg1 + val caller_save_regs_ccall = map RI.lv_to_reg RI.caller_save_ccall_phregs + val callee_save_regs_ccall = map RI.lv_to_reg RI.callee_save_ccall_phregs + val all_regs = map RI.lv_to_reg RI.all_regs + + (***********) + (* Logging *) + (***********) + fun log s = TextIO.output(!Flags.log,s ^ "\n") + fun msg s = TextIO.output(TextIO.stdOut, s) + fun chat(s: string) = if !Flags.chat then msg (s) else () + fun die s = Crash.impossible ("CodeGenX64." ^ s) + fun not_impl n = die ("prim(" ^ n ^ ") not implemented") + fun fast_pr stringtree = + (PP.outputTree ((fn s => TextIO.output(!Flags.log, s)) , stringtree, !Flags.colwidth); + TextIO.output(!Flags.log, "\n")) + + fun display(title, tree) = + fast_pr(PP.NODE{start=title ^ ": ", + finish="", + indent=3, + children=[tree], + childsep=PP.NOSEP + }) + + (****************************************************************) + (* Add Dynamic Flags *) + (****************************************************************) + val _ = Flags.add_bool_entry {long="comments_in_x64_asmcode", short=NONE, item=ref false, + menu=["Debug", "comments in x64 assembler code"], neg=false, + desc="Insert comments in x64 assembler code."} + + val jump_tables = true + val comments_in_asmcode = Flags.lookup_flag_entry "comments_in_x64_asmcode" + val gc_p = Flags.is_on0 "garbage_collection" + val tag_pairs_p = Flags.is_on0 "tag_pairs" + + (* Simple memory profiling - remember to enable the flag + * SIMPLE_MEMPROF in Runtime/Flags.h when you change this flag. *) + fun simple_memprof_p () = false + val stack_min = NameLab "stack_min" + + (********************************** + * Some code generation utilities * + **********************************) + + fun comment(str,C) = if !comments_in_asmcode then I.comment str :: C + else C + fun comment_fn(f, C) = if !comments_in_asmcode then I.comment (f()) :: C + else C + + fun rem_dead_code nil = nil + | rem_dead_code (C as i :: C') = + case i + of I.lab _ => C + | I.dot_long _ => C + | I.dot_quad _ => C + | I.dot_byte _ => C + | I.dot_align _ => C + | I.dot_globl _ => C + | I.dot_text => C + | I.dot_data => C + | I.comment s => i :: rem_dead_code C' + | _ => rem_dead_code C' + + (********************************) + (* CG on Top Level Declarations *) + (********************************) + + local + (******************************) + (* Dynamicly linked functions *) + (******************************) + + local val dynamic = ref (Binarymap.mkDict String.compare) + in fun add_dynamic (name,l1,l2) = dynamic := Binarymap.insert(!dynamic, name, (l1,l2)) + val get_dynamic = fn x=> Binarymap.peek (!dynamic, x) + end + + + (* Global Labels *) + val exn_ptr_lab = NameLab "exn_ptr" + val exn_counter_lab = NameLab "exnameCounter" + val time_to_gc_lab = NameLab "time_to_gc" (* Declared in GC.c *) + val data_lab_ptr_lab = NameLab "data_lab_ptr" (* Declared in GC.c *) + val stack_bot_gc_lab = NameLab "stack_bot_gc" (* Declared in GC.c *) + val gc_stub_lab = NameLab "__gc_stub" + val global_region_labs = + [(Effect.toplevel_region_withtype_top, BI.toplevel_region_withtype_top_lab), + (Effect.toplevel_region_withtype_string, BI.toplevel_region_withtype_string_lab), + (Effect.toplevel_region_withtype_pair, BI.toplevel_region_withtype_pair_lab), + (Effect.toplevel_region_withtype_array, BI.toplevel_region_withtype_array_lab), + (Effect.toplevel_region_withtype_ref, BI.toplevel_region_withtype_ref_lab), + (Effect.toplevel_region_withtype_triple, BI.toplevel_region_withtype_triple_lab)] + + (* Labels Local To This Compilation Unit *) + fun new_local_lab name = LocalLab (Labels.new_named name) + local + val counter = ref 0 + fun incr() = (counter := !counter + 1; !counter) + in + fun new_dynamicFn_lab() : lab = DatLab(Labels.new_named ("DynLab" ^ Int.toString(incr()))) + fun new_string_lab() : lab = DatLab(Labels.new_named ("StringLab" ^ Int.toString(incr()))) + fun new_float_lab() : lab = DatLab(Labels.new_named ("FloatLab" ^ Int.toString(incr()))) + fun new_num_lab() : lab = DatLab(Labels.new_named ("BoxedNumLab" ^ Int.toString(incr()))) + fun reset_label_counter() = counter := 0 + end + + (* Static Data inserted at the beginning of the code. *) + local + val static_data : I.inst list ref = ref [] + in + fun add_static_data (insts) = (static_data := insts @ !static_data) + fun reset_static_data () = static_data := [] + fun get_static_data C = !static_data @ C + end + + (* giving numbers to registers---for garbage collection *) + fun lv_to_reg_no lv = + case RI.lv_to_reg lv of + rax => 0 | rbx => 1 | rcx => 2 | rdx => 3 + | rsi => 4 | rdi => 5 | rbp => 6 | rsp => 7 + | r8 => 8 | r9 => 9 | r10 => 10 | r11 => 11 + | r12 => 12 | r13 => 13 | r14 => 14 | r15 => 15 + | r => die ("lv_to_reg.no: " ^ I.pr_reg r) + + (* Convert ~n to -n; works for all int32 values including Int32.minInt *) + fun intToStr (i : Int32.int) : string = + let fun tr s = case explode s + of #"~"::rest => implode (#"-"::rest) + | _ => s + in tr (Int32.toString i) + end + + fun wordToStr (w : Word32.word) : string = + "0x" ^ Word32.toString w + + (* Convert ~n to -n *) + fun i2s i = if i >= 0 then Int.toString i + else "-" ^ Int.toString (~i) + + (* We make the offset base explicit in the following functions *) + datatype Offset = + WORDS of int + | BYTES of int + + fun isZeroOffset (WORDS 0) = true + | isZeroOffset (BYTES 0) = true + | isZeroOffset _ = false + + fun offset_bytes (WORDS w) = i2s (8*w) (* a WORD can contain a ptr or an unboxed integer or word value *) + | offset_bytes (BYTES b) = i2s b + + fun copy(r1, r2, C) = if r1 = r2 then C + else I.movq(R r1, R r2) :: C + + (* Can be used to load from the stack or from a record *) + (* d = b[n] *) + fun load_indexed(d:ea,b:reg,n:Offset,C) = + I.movq(D(offset_bytes n,b), d) :: C + + (* Can be used to update the stack or store in a record *) + (* b[n] = s *) + fun store_indexed(b:reg,n:Offset,s:ea,C) = + I.movq(s,D(offset_bytes n,b)) :: C + + (* Calculate an address given a base and an offset *) + (* dst = base + x *) + fun base_plus_offset(b:reg,n:Offset,d:reg,C) = + if d = b andalso isZeroOffset n then C + else I.leaq(D(offset_bytes n, b), R d) :: C + + fun mkIntAty i = SS.INTEGER_ATY {value=Int32.fromInt i, + precision=if BI.tag_values() then 31 else 32} + + fun maybeTagInt {value: Int32.int, precision:int} : Int32.int = + case precision + of 31 => ((2 * value + 1) (* use tagged-unboxed representation *) + handle Overflow => die "maybeTagInt.Overflow") + | 32 => value (* use untagged representation - maybe boxed *) + | _ => die "maybeTagInt" + + fun maybeTagWord {value: Word32.word, precision:int} : Word32.word = + case precision + of 31 => (* use tagged representation *) + let val w = 0w2 * value + 0w1 + in if w < value then die "maybeTagWord.Overflow" + else w + end + | 32 => value (* use untagged representation - maybe boxed *) + | _ => die "maybeTagWord" + + (* formatting of immediate integer and word values *) + fun fmtInt a : string = intToStr(maybeTagInt a) + fun fmtWord a : string = wordToStr(maybeTagWord a) + + (* Store a constant *) + fun store_immed(w:Word32.word,r:reg,offset:Offset,C) = + I.movq(I (wordToStr w), D(offset_bytes offset,r)) :: C + + fun move_immed(0,R d,C) = I.xorq(R d, R d) :: C + | move_immed(x,d:ea,C) = I.movq(I (intToStr x), d) :: C + + fun move_num(x,ea:ea,C) = + if (x = "0" orelse x = "0x0") andalso (case ea of R _ => true | _ => false) + then I.xorq(ea, ea) :: C + else I.movq(I x, ea) :: C + + fun move_num_boxed(x,ea:ea,C) = + if not(BI.tag_values()) then die "move_num_boxed.boxed integers/words necessary only when tagging is enabled" + else + let val num_lab = new_num_lab() + val _ = add_static_data [I.dot_data, + I.dot_align 8, + I.lab num_lab, + I.dot_quad(BI.pr_tag_w(BI.tag_word_boxed(true))), + I.dot_quad x] + in I.movq(LA num_lab, ea) :: C + end + + (* returns true if boxed representation is used for + * integers of the given precision *) + fun boxedNum (precision:int) : bool = + precision > 31 andalso BI.tag_values() + + + (* Find a register for aty and generate code to store into the aty *) + fun resolve_aty_def(SS.STACK_ATY offset,t:reg,size_ff,C) = + (t,store_indexed(rsp,WORDS(size_ff-offset-1),R t,C)) (*was ~size_ff+offset*) + | resolve_aty_def(SS.PHREG_ATY phreg,t:reg,size_ff,C) = (phreg,C) + | resolve_aty_def(SS.UNIT_ATY,t:reg,size_ff,C) = (t,C) + | resolve_aty_def _ = die "resolve_aty_def: ATY cannot be defined" + + fun move_num_generic (precision, num, ea, C) = + if boxedNum precision then move_num_boxed(num, ea, C) + else move_num(num, ea, C) + + fun move_unit(ea,C) = + if BI.tag_values() then + move_immed(Int32.fromInt BI.ml_unit,ea,C) (* gc needs value! *) + else C + + (* Make sure that the aty ends up in register dst_reg *) + fun move_aty_into_reg(aty,dst_reg,size_ff,C) = + case aty + of SS.REG_I_ATY offset => + base_plus_offset(rsp,BYTES(size_ff*8-offset*8-8+BI.inf_bit),dst_reg,C) + | SS.REG_F_ATY offset => + base_plus_offset(rsp,WORDS(size_ff-offset-1),dst_reg,C) + | SS.STACK_ATY offset => + load_indexed(R dst_reg,rsp,WORDS(size_ff-offset-1),C) + | SS.DROPPED_RVAR_ATY => C + | SS.PHREG_ATY phreg => copy(phreg,dst_reg,C) + | SS.INTEGER_ATY i => move_num_generic (#precision i, fmtInt i, R dst_reg, C) + | SS.WORD_ATY w => move_num_generic (#precision w, fmtWord w, R dst_reg, C) + | SS.UNIT_ATY => move_unit (R dst_reg, C) + | SS.FLOW_VAR_ATY _ => die "move_aty_into_reg: FLOW_VAR_ATY cannot be moved" + + (* dst_aty = src_reg *) + fun move_reg_into_aty(src_reg:reg,dst_aty,size_ff,C) = + case dst_aty + of SS.PHREG_ATY dst_reg => copy(src_reg,dst_reg,C) + | SS.STACK_ATY offset => store_indexed(rsp,WORDS(size_ff-offset-1),R src_reg,C) (*was ~size_ff+offset*) + | SS.UNIT_ATY => C (* wild card definition - do nothing *) + | _ => die "move_reg_into_aty: ATY not recognized" + + (* dst_aty = src_aty *) + fun move_aty_to_aty(SS.PHREG_ATY src_reg,dst_aty,size_ff,C) = move_reg_into_aty(src_reg,dst_aty,size_ff,C) + | move_aty_to_aty(src_aty,SS.PHREG_ATY dst_reg,size_ff,C) = move_aty_into_reg(src_aty,dst_reg,size_ff,C) + | move_aty_to_aty(src_aty,SS.UNIT_ATY,size_ff,C) = C + | move_aty_to_aty(src_aty,dst_aty,size_ff,C) = + let val (reg_for_result,C') = resolve_aty_def(dst_aty,tmp_reg1,size_ff,C) + in move_aty_into_reg(src_aty,reg_for_result,size_ff,C') + end + + (* dst_aty = src_aty[offset] *) + fun move_index_aty_to_aty(SS.PHREG_ATY src_reg,SS.PHREG_ATY dst_reg,offset:Offset,t:reg,size_ff,C) = + load_indexed(R dst_reg,src_reg,offset,C) + | move_index_aty_to_aty(SS.PHREG_ATY src_reg,dst_aty,offset:Offset,t:reg,size_ff,C) = + load_indexed(R t,src_reg,offset, + move_reg_into_aty(t,dst_aty,size_ff,C)) + | move_index_aty_to_aty(src_aty,dst_aty,offset,t:reg,size_ff,C) = (* can be optimised!! *) + move_aty_into_reg(src_aty,t,size_ff, + load_indexed(R t,t,offset, + move_reg_into_aty(t,dst_aty,size_ff,C))) + + (* dst_aty = &lab *) + fun load_label_addr(lab,dst_aty,t:reg,size_ff,C) = + case dst_aty of + SS.PHREG_ATY d => I.movq(LA lab, R d) :: C + | SS.STACK_ATY offset => + I.movq(LA lab, R t) :: store_indexed(rsp, WORDS(size_ff-offset-1), R t, C) + (*store_indexed(rsp, WORDS(size_ff-offset-1), LA lab, C)*) + | _ => die "load_label_addr.wrong ATY" + + (* dst_aty = lab[0] *) + fun load_from_label(lab,dst_aty,t:reg,size_ff,C) = + case dst_aty of + SS.PHREG_ATY d => + I.movq(LA lab, R d) :: + I.movq(D("0",d), R d) :: C + | SS.STACK_ATY offset => + I.movq(LA lab, R t) :: + I.movq(D("0",t), R t) :: + store_indexed(rsp, WORDS(size_ff-offset-1), R t, C) + | SS.UNIT_ATY => C + | _ => die "load_from_label.wrong ATY" + + (* lab[0] = src_aty *) + fun store_in_label(src_aty,lab,tmp1:reg,size_ff,C) = + case src_aty of + SS.PHREG_ATY s => + I.movq(LA lab,R tmp1) :: I.movq(R s, D("0",tmp1)) :: C + | SS.INTEGER_ATY i => + I.movq(LA lab,R tmp1) :: move_num_generic (#precision i, fmtInt i, D("0",tmp1), C) + | SS.WORD_ATY w => + I.movq(LA lab,R tmp1) :: move_num_generic (#precision w, fmtWord w, D("0",tmp1), C) + | SS.UNIT_ATY => + I.movq(LA lab,R tmp1) :: move_unit(D("0",tmp1), C) +(* | SS.STACK_ATY offset => load_indexed(L lab, rsp, WORDS(size_ff-offset-1), C) *) + | _ => move_aty_into_reg(src_aty,tmp1,size_ff, + I.movq(R tmp1, L lab) :: C) + + (* Generate a string label *) + fun gen_string_lab str = + let val string_lab = new_string_lab() + + (* generate a .byte pseudo instuction for each character in + * the string and generate a .byte 0 instruction at the end. *) + val bytes = + foldr(fn (ch, acc) => I.dot_byte (Int.toString(ord ch)) :: acc) + [I.dot_byte "0"] (explode str) + + val _ = add_static_data (I.dot_data :: + I.dot_align 8 :: + I.lab string_lab :: + I.dot_quad(BI.pr_tag_w(BI.tag_string(true,size(str)))) :: + bytes) + in string_lab + end + + (* Generate a Data label *) + fun gen_data_lab lab = add_static_data [I.dot_data, + I.dot_align 8, + I.lab (DatLab lab), + I.dot_quad (i2s BI.ml_unit)] (* was "0" but use ml_unit instead for GC 2001-01-09, Niels *) + + fun store_aty_indexed(b:reg,n:Offset,aty,t:reg,size_ff,C) = + let fun ea() = D(offset_bytes n,b) + fun default() = + move_aty_into_reg(aty,t,size_ff, + store_indexed(b,n,R t,C)) + fun direct_word (w:{value: Word32.word, precision:int}) : bool = + not(boxedNum(#precision w)) andalso + case #precision w of + 32 => #value w <= 0wxFFFF + | 31 => #value w <= 0wx7FFF + | _ => die "store_aty_indexed.direct_word - weird precision" + fun direct_int (i:{value: Int32.int, precision:int}) = + not(boxedNum(#precision i)) andalso + case #precision i of + 32 => #value i <= 0x7FFF andalso #value i > ~0x8000 + | 31 => #value i <= 0x3FFF andalso #value i > ~0x4000 + | _ => die "store_aty_indexed.direct_int - weird precision" + in + case aty of + SS.PHREG_ATY s => I.movq(R s,ea()) :: C + | SS.INTEGER_ATY i => if direct_int i then + move_num_generic (#precision i, fmtInt i, ea(), C) + else default() + | SS.WORD_ATY w => if direct_word w then move_num_generic (#precision w, fmtWord w, ea(), C) + else default() + | SS.UNIT_ATY => move_unit(ea(),C) + | _ => default() + end + + + (* Can be used to update the stack or a record when the argument is an ATY *) + (* base_reg[offset] = src_aty *) + fun store_aty_in_reg_record(aty,t:reg,b,n:Offset,size_ff,C) = + store_aty_indexed(b:reg,n:Offset,aty,t:reg,size_ff,C) + + (* Can be used to load from the stack or a record when destination is an ATY *) + (* dst_aty = base_reg[offset] *) + fun load_aty_from_reg_record(SS.PHREG_ATY dst_reg,t:reg,base_reg,offset:Offset,size_ff,C) = + load_indexed(R dst_reg,base_reg,offset,C) + | load_aty_from_reg_record(dst_aty,t:reg,base_reg,offset:Offset,size_ff,C) = + load_indexed(R t,base_reg,offset, + move_reg_into_aty(t,dst_aty,size_ff,C)) + + (* base_aty[offset] = src_aty *) + fun store_aty_in_aty_record(src_aty,base_aty,offset:Offset,t1:reg,t2:reg,size_ff,C) = + case (src_aty,base_aty) + of (SS.PHREG_ATY src_reg,SS.PHREG_ATY base_reg) => store_indexed(base_reg,offset,R src_reg,C) + | (SS.PHREG_ATY src_reg,base_aty) => move_aty_into_reg(base_aty,t2,size_ff, (* can be optimised *) + store_indexed(t2,offset,R src_reg,C)) + | (src_aty,SS.PHREG_ATY base_reg) => move_aty_into_reg(src_aty,t1,size_ff, + store_indexed(base_reg,offset,R t1,C)) + | (src_aty,base_aty) => move_aty_into_reg(src_aty,t1,size_ff, (* can be optimised *) + move_aty_into_reg(base_aty,t2,size_ff, + store_indexed(t2,offset,R t1,C))) + + (* push(aty), i.e., rsp-=8; rsp[0] = aty (different than on hp) *) + (* size_ff is for rsp before rsp is moved. *) + fun push_aty(aty,t:reg,size_ff,C) = + let + fun default() = move_aty_into_reg(aty,t,size_ff, + I.push(R t) :: C) + in case aty + of SS.PHREG_ATY aty_reg => I.push(R aty_reg) :: C + | SS.INTEGER_ATY i => + if boxedNum (#precision i) then default() + else I.push(I (fmtInt i)) :: C + | SS.WORD_ATY w => + if boxedNum (#precision w) then default() + else I.push(I (fmtWord w)) :: C + | _ => default() + end + + (* pop(aty), i.e., aty=rsp[0]; rsp+=8 *) + (* size_ff is for sp after pop *) + fun pop_aty(SS.PHREG_ATY aty_reg,t:reg,size_ff,C) = I.pop(R aty_reg) :: C + | pop_aty(aty,t:reg,size_ff,C) = (I.pop(R t) :: + move_reg_into_aty(t,aty,size_ff,C)) + + (* Returns a register with arg and a continuation function. *) + fun resolve_arg_aty(arg:SS.Aty,t:reg,size_ff:int) : reg * (I.inst list -> I.inst list) = + case arg + of SS.PHREG_ATY r => (r, fn C => C) + | _ => (t, fn C => move_aty_into_reg(arg,t,size_ff,C)) + + fun add_aty_to_reg(arg:SS.Aty,tmp:reg,t:reg,size_ff:int,C:I.inst list) : I.inst list = + case arg + of SS.PHREG_ATY r => I.addq(R r, R t) :: C + | _ => move_aty_into_reg(arg,tmp,size_ff, I.addq(R tmp, R t) :: C) + + (* Push float on float stack *) + fun load_float_aty(float_aty, t, size_ff, xmm_reg) = + let val disp = if BI.tag_values() then "8" + else "0" + in fn C => case float_aty + of SS.PHREG_ATY x => I.movsd(D(disp, x),R xmm_reg) :: C + | _ => move_aty_into_reg(float_aty,t,size_ff, + I.movsd(D(disp, t),R xmm_reg) :: C) + end + + (* Pop float from float stack *) + fun store_float_reg(base_reg,t:reg,xmm_reg,C) = + if BI.tag_values() then + store_immed(BI.tag_real false, base_reg, WORDS 0, + I.movsd (R xmm_reg,D("8",base_reg)) :: C) (* mael 2003-05-08 *) + else + I.movsd (R xmm_reg,D("0",base_reg)) :: C + + + (* When tag free collection of pairs is enabled, a bit is stored + in the region descriptor if the region is an infinite region + holding pairs, refs, triples and arrays. Here we arrange that + special C functions for allocating regions are called for + regions containing pairs, refs, triples and arrays; these C + functions then take care of setting the appropriate bit. + + Notice the difference between the function + values_in_region_untagged being regions containing untagged + values and the function + regions_holding_values_of_the_same_type_only being regions + holding values of the same type and this type is set in the + region descriptor.*) + + fun values_in_region_untagged (place:Effect.place) : bool = + BI.tag_values() andalso not(tag_pairs_p()) + andalso (case Effect.get_place_ty place of + SOME Effect.PAIR_RT => true + | SOME Effect.REF_RT => true + | SOME Effect.TRIPLE_RT => true + | _ => false) + + fun regions_holding_values_of_the_same_type_only (place:Effect.place) : bool = + BI.tag_values() andalso not(tag_pairs_p()) + andalso (case Effect.get_place_ty place of + SOME Effect.PAIR_RT => true + | SOME Effect.REF_RT => true + | SOME Effect.TRIPLE_RT => true + | SOME Effect.ARRAY_RT => true + | _ => false) + + + (***********************) + (* Calling C Functions *) + (***********************) + + local + + fun callc_static_or_dynamic (name : string, nargs, fnlab, C) = + case name of + ":" => + let + val () = die ("callc_static_or_dynamic.dynamic call not yet ported: '" ^ name ^ "'") + val () = + if nargs < 1 then + die "callc_static_or_dynamic: Dynamic linking requires a string as first argument." + else () + val fp = new_dynamicFn_lab() + val fcall = new_dynamicFn_lab() + val nfcall = new_dynamicFn_lab() + val finish = new_dynamicFn_lab() + in + I.movq (L fp, R rax) :: + I.cmpq (I "0",R rax) :: + I.je nfcall :: + I.lab fcall :: + I.addq (I "8",R rsp) :: + I.call' (R rax) :: + I.jmp (L finish) :: + I.lab nfcall :: + I.subq (I "8", R rsp) :: + I.movq (LA fp, R rdx) :: + I.movq (R rdx, D("0",rsp)) :: + I.call fnlab :: + I.addq (I "8", R rsp) :: + I.movq (L fp, R rax) :: + I.cmpq (I "0", R rax) :: + I.jne fcall:: + I.addq (I "8", R rsp):: + I.call (NameLab "__raise_match"):: + I.jmp (L finish):: + I.dot_data:: + I.dot_align 8:: + I.dot_size (fp, 8):: + I.lab fp :: + I.dot_quad "0" :: + I.dot_text :: + I.lab finish :: C + end + | _ => I.call(NameLab name) :: C + in + + (* better alignment technique that allows for arguments on the stack *) + fun push_args push_arg size_ff args C = + let fun loop ([], _) = C + | loop (arg :: rest, size_ff) = (push_arg(arg,size_ff, + loop (rest, size_ff + 1))) + in loop(rev args, size_ff) + end + + fun pop_args name nargs C = + case nargs + of 0 => C + | n => I.addq(I (i2s (8* (case name of ":" => n-1 | _ => n))), R rsp) :: C + + local + fun iterl f a n = + if n <= 0 then a + else iterl f (f(n,a)) (n-1) +(* + fun iterr f a n = + if n <= 0 then a + else f(n, iterr f a (n-1)) +*) + + (* for alignment of the stack, both tmp_reg0 and tmp_reg1 can be used *) + fun align nargs C = + let val tmp = tmp_reg0 + val tmp1 = tmp_reg1 + in + I.leaq(D(i2s(8*nargs), rsp), R tmp) :: (* tmp = rsp + 8n; memoize esp as it should be *) + (* restored after call *) + I.subq(I(i2s(8*(nargs+5))), R rsp) :: (* rsp = rsp - 32 - 8 - 8n ; alignment *) + I.andq(I "0xFFFFFFFFFFFFFFF0", R rsp) :: (* rsp = rsp & 0xFFFFFFFFFFFFFFF0; alignment *) + I.addq(I(i2s(8*(nargs+1))), R rsp) :: (* Make room for args to be pushed, so that once *) + I.push(R tmp) :: (* the args are pushed, the stack is aligned *) + iterl (fn (i,C) => + I.movq(D(i2s(~8*i), tmp), R tmp1) :: (* notice: for x64, rsp points to the last slot used *) + I.push(R tmp1) :: C + ) + C nargs + end + + fun restore_stack_alignment nargs C = + let val tmp = tmp_reg0 + in I.movq(D(i2s(8*nargs), rsp), R tmp) :: (* notice: for x64, rsp points to the last slot used *) + I.movq(R tmp, R rsp) :: + C + end + in + fun needs_align () = true + (* I.sysname() = "Darwin" *) + + fun maybe_align nargs F C = + if needs_align() then + align nargs (F (restore_stack_alignment nargs C)) + else F C + end +(* + fun maybe_align {even:bool} F C = (* ME: maybe there is a better way *) + let val tmp = I.rbx (* callee save scratch register *) + fun align C = + I.comment "ALIGN USING rbx" :: + I.push (R rbx) :: + I.movq(R rsp, R tmp) :: (* tmp = rsp; memoize rsp as it should be restored after call *) + I.subq(I "16", R rsp) :: (* rsp = rsp - 16; alignment *) + I.andq(I "0xFFFFFFFFFFFFFFF0", R rsp) :: (* rsp = rsp & 0xFFFFFFFFFFFFFFF0; alignment *) + if even then C else I.subq (I "8", R rsp) :: C + fun restore_align C = (* restore previous stack pointer *) + I.movq(R tmp, R rsp) :: + I.pop (R rbx) :: + C + fun needs_align () = I.sysname() = "Darwin" + in if needs_align() then + align(F(restore_align C)) + else F C + end +*) + fun regs_atys nil acc = nil + | regs_atys (SS.PHREG_ATY r::atys) acc = regs_atys atys (r::acc) + | regs_atys (_ ::atys) acc = regs_atys atys acc + + fun member r nil = false + | member r (x::xs) = r = x orelse member r xs +(* + fun subst_ea s t ea = + case ea of + R r => if r=s then R t else ea + | L _ => ea + | LA _ => ea + | I _ => ea + | D(str,r) => if r=s then D(str,t) else ea + | DD(str1,r1,r2,str2) => + if r1=s orelse r2=s then + let val r1'=if r1=s then t else r1 + val r2'=if r2=s then t else r2 + in DD(str1,r1',r2',str2) + end + else ea +*) + (* move the first six arguments into the appropriate registers *) + fun shuffle_args (size_ff:int) + (mv_aty_to_reg: SS.Aty * 'a * reg * int * I.inst list -> I.inst list) + (args:(SS.Aty * 'a * reg)list) + (C:I.inst list) : I.inst list = + let (*val args = List.filter (fn (aty,_,r) => not(SS.eq_aty (aty,SS.PHREG_ATY r))) args*) + val regs = regs_atys (List.map #1 args) nil + fun loop nil acc = acc + | loop ((aty,info,r)::args) (C,rem)= + if not (member r regs) then + let val (C,rem) = loop args (C,rem) + in (mv_aty_to_reg (aty:SS.Aty,info:'a,r:reg,size_ff,C),rem) + end + else loop args (C,(aty,info,r)::rem) + val (C,args) = loop args (C,nil) + in case args of + nil => C + | (_,_,r)::_ => die "shuffle_args: not quite done" + end + + fun warn s = print ("** WARNING: " ^ s ^ "\n") + + (* 1. push stack arguments + 2. shuffle register arguments (adjust size_ff) + 3. align rsp (and modify location of stack arguments) + 4. make the call + 5. on return, reestablish (esp) + *) + + fun compile_c_call_prim (name:string, args:SS.Aty list, opt_ret:SS.Aty option, size_ff:int, tmp:reg, C) = + let fun drop n nil = nil + | drop 0 xs = xs + | drop n (x::xs) = drop (n-1) xs + fun push_arg(aty,size_ff,C) = push_aty(aty,tmp,size_ff,C) + val nargs = List.length args +(* + val () = if nargs > List.length RI.args_reg_ccall then + warn ("compile_c_call_prim: at most " ^ + Int.toString (List.length RI.args_reg_ccall) ^ + " arguments are passed in registers - " ^ name ^ " takes " ^ + Int.toString nargs ^ " arguments") + else () +*) + val args_stack = drop (List.length RI.args_reg_ccall) args + val nargs_stack = List.length args_stack + val args = ListPair.zip (args, RI.args_reg_ccall) + val args = map (fn (x,y) => (x,(),y)) args + fun store_ret(SOME d,C) = move_reg_into_aty(rax,d,size_ff,C) + | store_ret(NONE,C) = C + (* val _ = print ("CodeGen: Compiling C Call - " ^ name ^ "\n") *) + (* With dynamic linking there must be at least one argument (the name to be bound). *) + val dynlinklab = "localResolveLibFnManual" + fun mv (aty,_,r,sz_ff,C) = move_aty_into_reg(aty,r,sz_ff,C) + in shuffle_args size_ff mv args + (push_args push_arg size_ff args_stack + (maybe_align nargs_stack + (fn C => callc_static_or_dynamic (name, nargs, NameLab dynlinklab, C)) + (store_ret(opt_ret,C)))) + end + + (* Compile a C call with auto-conversion: convert ML arguments to C arguments and + * convert the C result to an ML result. Currently supports at most 6 arguments. *) + fun compile_c_call_auto (name,args,opt_res,size_ff,tmp,C) = + let val args = if List.length args > List.length RI.args_reg_ccall then + die ("compile_c_call_auto: at most " ^ + Int.toString (List.length RI.args_reg_ccall) ^ + " arguments are supported") + else ListPair.zip (args, RI.args_reg_ccall) + val args = List.map (fn ((x:SS.Aty,y:LS.foreign_type),z:reg) => (x,y,z)) args + fun mov_bool ((aty,r),size_ff,C) = + move_aty_into_reg(aty,r,size_ff, + I.shrq(I "1", R r) :: C) + + fun mov_int ((aty,r),size_ff,C) = + if BI.tag_values() then + move_aty_into_reg(aty,r,size_ff, + I.shrq(I "1", R r) :: C) + else + move_aty_into_reg(aty,r,size_ff,C) + + fun mov_foreignptr ((aty,r),size_ff,C) = + if BI.tag_values() then + case aty of + SS.PHREG_ATY r => I.leaq(D("-1", r), R r) :: C + | _ => move_aty_into_reg(aty,r,size_ff, + I.leaq(D("-1", r), R r) :: C) + else move_aty_into_reg(aty,r,size_ff,C) + + fun mov_chararray ((aty,r),size_ff,C) = + case aty of + SS.PHREG_ATY r' => I.leaq(D("8", r'), R r) :: C + | _ => move_aty_into_reg(aty,r,size_ff, + I.leaq(D("8", r), R r) :: C) + + fun mov_arg (aty,ft:LS.foreign_type,r,size_ff,C) = + let val mov_fun = case ft + of LS.Bool => mov_bool + | LS.Int => mov_int + | LS.ForeignPtr => mov_foreignptr + | LS.CharArray => mov_chararray + | LS.Unit => die "CCALL_AUTO.Unit type in argument not supported" + in mov_fun((aty,r),size_ff,C) + end + + fun tag_bool_result (r,C) = I.leaq(DD("1", r, r, ""), R r) :: C + + fun maybe_tag_int_result (r,C) = + if BI.tag_values() then I.leaq(DD("1", r, r, ""), R r) :: C + else C + + fun maybe_tag_foreignptr_result (r,C) = + if BI.tag_values() then I.leaq(D("1", r), R r) :: C + else C + + fun convert_result ft = + case ft of + LS.Bool => tag_bool_result + | LS.Int => maybe_tag_int_result + | LS.ForeignPtr => maybe_tag_foreignptr_result + | LS.Unit => die "convert_result.Unit already dealt with" + | LS.CharArray => die "convert_result.CharArray foreign type not supported in auto-conversion result" + + fun store_result ((aty,ft:LS.foreign_type), C) = + case ft of + LS.Unit => C + | _ => convert_result ft (rax, move_reg_into_aty(rax,aty,size_ff,C)) + + val dynlinklab = "localResolveLibFnAuto" + val nargs = List.length args (* not used for static calls *) + in shuffle_args size_ff mov_arg args + (maybe_align 0 (fn C => callc_static_or_dynamic (name, nargs, NameLab dynlinklab,C)) + (store_result(opt_res,C))) + end + end + + (**********************) + (* Garbage Collection *) + (**********************) + + (* Put a bitvector into the code. *) + fun gen_bv (ws,C) = + let fun gen_bv'([],C) = C + | gen_bv'(w::ws,C) = gen_bv'(ws,I.dot_quad ("0x"^Word32.fmt StringCvt.HEX w)::C) + in if gc_p() then gen_bv'(ws,C) + else C + end + + (* reg_map is a register map describing live registers at entry to the function *) + (* The stub requires reg_map to reside in tmp_reg1 and the return address in tmp_reg0 *) + fun do_gc(reg_map: Word32.word,size_ccf,size_rcf,size_spilled_region_args,C) = + if gc_p() then + let + val l = new_local_lab "return_from_gc_stub" + val reg_map_immed = "0x" ^ Word32.fmt StringCvt.HEX reg_map + val size_ff = 0 (*dummy*) + in +(* + load_label_addr(time_to_gc_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, (* tmp_reg1 = &gc_flag *) + I.movq(D("0",tmp_reg1),R tmp_reg1) :: (* tmp_reg1 = gc_flag *) +*) + I.cmpq(I "1", L time_to_gc_lab) :: +(* I.jmp (L l) :: (* for disabling gc *) *) + I.jne l :: + I.movq(I reg_map_immed, R tmp_reg1) :: (* tmp_reg1 = reg_map *) + load_label_addr(l,SS.PHREG_ATY tmp_reg0,tmp_reg0,size_ff, (* tmp_reg0 = return address *) + I.push(I (i2s size_ccf)) :: + I.push(I (i2s size_rcf)) :: + I.push(I (i2s size_spilled_region_args)) :: + I.jmp(L gc_stub_lab) :: + I.lab l :: C) + end + else C + + (*********************) + (* Allocation Points *) + (*********************) + + (* Status Bits Are Not Cleared! We preserve the value in register t, + * t may be used in a call to alloc. *) + + fun reset_region(t:reg,tmp:reg,size_ff,C) = + let val l = new_local_lab "return_from_alloc" + in copy(t,tmp_reg1, + I.push(LA l) :: + I.jmp(L(NameLab "__reset_region")) :: + I.lab l :: + copy(tmp_reg1, t, C)) + end + + fun alloc_kill_tmp01(t:reg,n0:int,size_ff,pp:LS.pp,C) = + let val n = if region_profiling() then n0 + BI.objectDescSizeP + else n0 + val l = new_local_lab "return_from_alloc" + fun post_prof C = + if region_profiling() then (* tmp_reg1 now points at the object descriptor; initialize it *) + I.movq(I (i2s pp), D("0",tmp_reg1)) :: (* first word is pp *) + I.movq(I (i2s n0), D("8",tmp_reg1)) :: (* second word is object size *) + I.leaq(D (i2s (8*BI.objectDescSizeP), tmp_reg1), R tmp_reg1) :: C (* make tmp_reg1 point at object *) + else C + in + copy(t,tmp_reg1, + I.push(LA l) :: + move_immed(Int32.fromInt n, R tmp_reg0, + I.jmp(L(NameLab "__allocate")) :: (* assumes args in tmp_reg1 and tmp_reg0; result in tmp_reg1 *) + I.lab l :: + post_prof + (copy(tmp_reg1,t,C)))) + end + + (* When tagging is enabled (for gc) and tag-free pairs (and triples) are enabled + * then the following function is used for allocating pairs in + * infinite regions. *) + + fun alloc_untagged_value_kill_tmp01(t:reg,size_alloc,size_ff,pp:LS.pp,C) = + let val n0 = size_alloc (* size of untagged pair, e.g. *) + val n = if region_profiling() then n0 + BI.objectDescSizeP + else n0 + val l = new_local_lab "return_from_alloc" + fun post (t, C) = + if region_profiling() then (* tmp_reg1 now points at the object descriptor; initialize it *) + I.movq(I (i2s pp), D("0",tmp_reg1)) :: (* first word is pp *) + I.movq(I (i2s n0), D("8",tmp_reg1)) :: (* second word is object size *) + I.leaq(D (i2s (8*(BI.objectDescSizeP-1)), tmp_reg1), R t) :: C (* make tmp_reg1 point at + * word before object *) + else + I.leaq(D("-8",tmp_reg1), R t) :: C (* make tmp_reg1 point at + * word before object *) + in + copy(t,tmp_reg1, + I.push(LA l) :: + move_immed(Int32.fromInt n, R tmp_reg0, + I.jmp(L(NameLab "__allocate")) :: (* assumes args in tmp_reg1 and tmp_reg0; result in tmp_reg1 *) + I.lab l :: + post (t,C))) + end + + fun set_atbot_bit(dst_reg:reg,C) = + I.orq(I "2", R dst_reg) :: C + + fun clear_atbot_bit(dst_reg:reg,C) = + I.btrq (I "1", R dst_reg) :: C + + fun set_inf_bit(dst_reg:reg,C) = + I.orq(I "1", R dst_reg) :: C + + fun set_inf_bit_and_atbot_bit(dst_reg:reg,C) = + I.orq(I "3", R dst_reg) :: C + + (* move_aty_into_reg_ap differs from move_aty_into_reg in the case where aty is a phreg! *) + (* We must always make a copy of phreg because we may overwrite status bits in phreg. *) + fun move_aty_into_reg_ap(aty,dst_reg,size_ff,C) = + case aty + of SS.REG_I_ATY offset => base_plus_offset(rsp,BYTES(size_ff*8-offset*8-8(*+BI.inf_bit*)),dst_reg, + set_inf_bit(dst_reg,C)) + | SS.REG_F_ATY offset => base_plus_offset(rsp,WORDS(size_ff-offset-1),dst_reg,C) + | SS.STACK_ATY offset => load_indexed(R dst_reg,rsp,WORDS(size_ff-offset-1),C) + | SS.PHREG_ATY phreg => copy(phreg,dst_reg, C) + | _ => die "move_aty_into_reg_ap: ATY cannot be used to allocate memory" + + fun store_pp_prof (obj_ptr:reg, pp:LS.pp, C) = + if region_profiling() then + if pp < 2 then die ("store_pp_prof.pp (" ^ Int.toString pp ^ ") is less than two.") + else I.movq(I(i2s pp), D("-16", obj_ptr)) :: C (* two words offset *) + else C + + fun alloc_ap_kill_tmp01(sma, dst_reg:reg, n, size_ff, C) = + case sma + of LS.ATTOP_LI(SS.DROPPED_RVAR_ATY,pp) => C + | LS.ATTOP_LF(SS.DROPPED_RVAR_ATY,pp) => C + | LS.ATTOP_FI(SS.DROPPED_RVAR_ATY,pp) => C + | LS.ATTOP_FF(SS.DROPPED_RVAR_ATY,pp) => C + | LS.ATBOT_LI(SS.DROPPED_RVAR_ATY,pp) => C + | LS.ATBOT_LF(SS.DROPPED_RVAR_ATY,pp) => C + | LS.SAT_FI(SS.DROPPED_RVAR_ATY,pp) => C + | LS.SAT_FF(SS.DROPPED_RVAR_ATY,pp) => C + | LS.IGNORE => C + | LS.ATTOP_LI(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff, + alloc_kill_tmp01(dst_reg,n,size_ff,pp,C)) + | LS.ATTOP_LF(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff, + store_pp_prof(dst_reg,pp,C)) + | LS.ATBOT_LF(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff, (* atbot bit not set; its a finite region *) + store_pp_prof(dst_reg,pp,C)) + | LS.ATTOP_FI(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff, + alloc_kill_tmp01(dst_reg,n,size_ff,pp,C)) + | LS.ATTOP_FF(aty,pp) => + let val cont_lab = new_local_lab "no_alloc" + in move_aty_into_reg_ap(aty,dst_reg,size_ff, + I.btq(I "0", R dst_reg) :: (* inf bit set? *) + I.jnc cont_lab :: + alloc_kill_tmp01(dst_reg,n,size_ff,pp, + I.lab cont_lab :: C)) + end + | LS.ATBOT_LI(aty,pp) => + move_aty_into_reg_ap(aty,dst_reg,size_ff, + reset_region(dst_reg,tmp_reg0,size_ff, (* dst_reg is preserved for alloc *) + alloc_kill_tmp01(dst_reg,n,size_ff,pp,C))) + | LS.SAT_FI(aty,pp) => + let val default_lab = new_local_lab "no_reset" + in move_aty_into_reg_ap(aty,dst_reg,size_ff, + I.btq(I "1", R dst_reg) :: (* atbot bit set? *) + I.jnc default_lab :: + reset_region(dst_reg,tmp_reg0,size_ff, + I.lab default_lab :: (* dst_reg is preverved over the call *) + alloc_kill_tmp01(dst_reg,n,size_ff,pp,C))) + end + | LS.SAT_FF(aty,pp) => + let val finite_lab = new_local_lab "no_alloc" + val attop_lab = new_local_lab "no_reset" + in move_aty_into_reg_ap(aty,dst_reg,size_ff, + I.btq (I "0", R dst_reg) :: (* inf bit set? *) + I.jnc finite_lab :: + I.btq (I "1", R dst_reg) :: (* atbot bit set? *) + I.jnc attop_lab :: + reset_region(dst_reg,tmp_reg0,size_ff, (* dst_reg is preserved over the call *) + I.lab attop_lab :: + alloc_kill_tmp01(dst_reg,n,size_ff,pp, + I.lab finite_lab :: C))) + end + + fun alloc_untagged_value_ap_kill_tmp01 (sma, dst_reg:reg, size_alloc, size_ff, C) = + case sma + of LS.ATTOP_LI(SS.DROPPED_RVAR_ATY,pp) => die "alloc_untagged_value_ap_kill_tmp01.1" + | LS.ATTOP_LF(SS.DROPPED_RVAR_ATY,pp) => die "alloc_untagged_value_ap_kill_tmp01.2" + | LS.ATTOP_FI(SS.DROPPED_RVAR_ATY,pp) => die "alloc_untagged_value_ap_kill_tmp01.3" + | LS.ATTOP_FF(SS.DROPPED_RVAR_ATY,pp) => die "alloc_untagged_value_ap_kill_tmp01.4" + | LS.ATBOT_LI(SS.DROPPED_RVAR_ATY,pp) => die "alloc_untagged_value_ap_kill_tmp01.5" + | LS.ATBOT_LF(SS.DROPPED_RVAR_ATY,pp) => die "alloc_untagged_value_ap_kill_tmp01.6" + | LS.SAT_FI(SS.DROPPED_RVAR_ATY,pp) => die "alloc_untagged_value_ap_kill_tmp01.7" + | LS.SAT_FF(SS.DROPPED_RVAR_ATY,pp) => die "alloc_untagged_value_ap_kill_tmp01.8" + | LS.IGNORE => die "alloc_untagged_value_ap_kill_tmp01.9" + | LS.ATTOP_LI(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff, + alloc_untagged_value_kill_tmp01(dst_reg,size_alloc,size_ff,pp,C)) + | LS.ATTOP_LF(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff, + store_pp_prof(dst_reg,pp, C)) + | LS.ATBOT_LF(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff, (* atbot bit not set; its a finite region *) + store_pp_prof(dst_reg,pp, C)) + | LS.ATTOP_FI(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff, + alloc_untagged_value_kill_tmp01(dst_reg,size_alloc,size_ff,pp,C)) + | LS.ATTOP_FF(aty,pp) => + let val cont_lab = new_local_lab "cont" + in move_aty_into_reg_ap(aty,dst_reg,size_ff, + I.btq(I "0", R dst_reg) :: (* inf bit set? *) + I.jnc cont_lab :: + alloc_untagged_value_kill_tmp01(dst_reg,size_alloc,size_ff,pp, + I.lab cont_lab :: C)) + end + | LS.ATBOT_LI(aty,pp) => + move_aty_into_reg_ap(aty,dst_reg,size_ff, + reset_region(dst_reg,tmp_reg0,size_ff, (* dst_reg is preserved for alloc *) + alloc_untagged_value_kill_tmp01(dst_reg,size_alloc,size_ff,pp,C))) + | LS.SAT_FI(aty,pp) => + let val default_lab = new_local_lab "no_reset" + in move_aty_into_reg_ap(aty,dst_reg,size_ff, + I.btq(I "1", R dst_reg) :: (* atbot bit set? *) + I.jnc default_lab :: + reset_region(dst_reg,tmp_reg0,size_ff, + I.lab default_lab :: (* dst_reg is preverved over the call *) + alloc_untagged_value_kill_tmp01(dst_reg,size_alloc,size_ff,pp,C))) + end + | LS.SAT_FF(aty,pp) => + let val finite_lab = new_local_lab "no_alloc" + val attop_lab = new_local_lab "no_reset" + val cont_lab = new_local_lab "cont" + in move_aty_into_reg_ap(aty,dst_reg,size_ff, + I.btq (I "0", R dst_reg) :: (* inf bit set? *) + I.jnc cont_lab :: + I.btq (I "1", R dst_reg) :: (* atbot bit set? *) + I.jnc attop_lab :: + reset_region(dst_reg,tmp_reg0,size_ff, (* dst_reg is preserved over the call *) + I.lab attop_lab :: + alloc_untagged_value_kill_tmp01(dst_reg,size_alloc,size_ff,pp, + I.lab cont_lab :: C))) + end + + (* Set Atbot bits on region variables *) + fun prefix_sm(sma,dst_reg:reg,size_ff,C) = + case sma + of LS.ATTOP_LI(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm: DROPPED_RVAR_ATY not implemented." + | LS.ATTOP_LF(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm: DROPPED_RVAR_ATY not implemented." + | LS.ATTOP_FI(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm: DROPPED_RVAR_ATY not implemented." + | LS.ATTOP_FF(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm: DROPPED_RVAR_ATY not implemented." + | LS.ATBOT_LI(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm: DROPPED_RVAR_ATY not implemented." + | LS.ATBOT_LF(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm: DROPPED_RVAR_ATY not implemented." + | LS.SAT_FI(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm: DROPPED_RVAR_ATY not implemented." + | LS.SAT_FF(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm: DROPPED_RVAR_ATY not implemented." + | LS.IGNORE => die "prefix_sm: IGNORE not implemented." + | LS.ATTOP_LI(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff,C) + | LS.ATTOP_LF(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff,C) + | LS.ATTOP_FI(aty,pp) => + move_aty_into_reg_ap(aty,dst_reg,size_ff, + clear_atbot_bit(dst_reg,C)) + | LS.ATTOP_FF(aty,pp) => + move_aty_into_reg_ap(aty,dst_reg,size_ff, (* It is necessary to clear atbot bit *) + clear_atbot_bit(dst_reg,C)) (* because the region may be infinite *) + | LS.ATBOT_LI(SS.REG_I_ATY offset_reg_i,pp) => + base_plus_offset(rsp,BYTES(size_ff*8-offset_reg_i*8-8(*+BI.inf_bit+BI.atbot_bit*)),dst_reg, + set_inf_bit_and_atbot_bit(dst_reg, C)) + | LS.ATBOT_LI(aty,pp) => + move_aty_into_reg_ap(aty,dst_reg,size_ff, + set_atbot_bit(dst_reg,C)) + | LS.ATBOT_LF(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff,C) + | LS.SAT_FI(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff,C) + | LS.SAT_FF(aty,pp) => move_aty_into_reg_ap(aty,dst_reg,size_ff,C) + + (* Used to build a region vector *) + fun store_sm_in_record(sma,tmp:reg,base_reg,offset,size_ff,C) = + case sma + of LS.ATTOP_LI(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record: DROPPED_RVAR_ATY not implemented." + | LS.ATTOP_LF(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record: DROPPED_RVAR_ATY not implemented." + | LS.ATTOP_FI(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record: DROPPED_RVAR_ATY not implemented." + | LS.ATTOP_FF(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record: DROPPED_RVAR_ATY not implemented." + | LS.ATBOT_LI(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record: DROPPED_RVAR_ATY not implemented." + | LS.ATBOT_LF(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record: DROPPED_RVAR_ATY not implemented." + | LS.SAT_FI(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record: DROPPED_RVAR_ATY not implemented." + | LS.SAT_FF(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record: DROPPED_RVAR_ATY not implemented." + | LS.IGNORE => die "store_sm_in_record: IGNORE not implemented." + | LS.ATTOP_LI(SS.PHREG_ATY phreg,pp) => store_indexed(base_reg,offset,R phreg,C) + | LS.ATTOP_LI(aty,pp) => move_aty_into_reg_ap(aty,tmp,size_ff, + store_indexed(base_reg,offset,R tmp,C)) + | LS.ATTOP_LF(SS.PHREG_ATY phreg,pp) => store_indexed(base_reg,offset,R phreg,C) + | LS.ATTOP_LF(aty,pp) => move_aty_into_reg_ap(aty,tmp,size_ff, + store_indexed(base_reg,offset,R tmp,C)) + | LS.ATTOP_FI(aty,pp) => move_aty_into_reg_ap(aty,tmp,size_ff, + clear_atbot_bit(tmp, + store_indexed(base_reg,offset,R tmp,C))) + | LS.ATTOP_FF(aty,pp) => move_aty_into_reg_ap(aty,tmp,size_ff, + clear_atbot_bit(tmp, (* The region may be infinite *) + store_indexed(base_reg,offset,R tmp,C))) (* so we clear the atbot bit *) + | LS.ATBOT_LI(SS.REG_I_ATY offset_reg_i,pp) => + base_plus_offset(rsp,BYTES(size_ff*8-offset_reg_i*8-8(*+BI.inf_bit+BI.atbot_bit*)),tmp, + set_inf_bit_and_atbot_bit(tmp, + store_indexed(base_reg,offset,R tmp,C))) + | LS.ATBOT_LI(aty,pp) => + move_aty_into_reg_ap(aty,tmp,size_ff, + set_atbot_bit(tmp, + store_indexed(base_reg,offset,R tmp,C))) + | LS.ATBOT_LF(SS.PHREG_ATY phreg,pp) => + store_indexed(base_reg,offset,R phreg,C) (* The region is finite so no atbot bit is necessary *) + | LS.ATBOT_LF(aty,pp) => + move_aty_into_reg_ap(aty,tmp,size_ff, + store_indexed(base_reg,offset,R tmp,C)) + | LS.SAT_FI(SS.PHREG_ATY phreg,pp) => + store_indexed(base_reg,offset,R phreg,C) (* The storage bit is already recorded in phreg *) + | LS.SAT_FI(aty,pp) => move_aty_into_reg_ap(aty,tmp,size_ff, + store_indexed(base_reg,offset,R tmp,C)) + | LS.SAT_FF(SS.PHREG_ATY phreg,pp) => + store_indexed(base_reg,offset,R phreg,C) (* The storage bit is already recorded in phreg *) + | LS.SAT_FF(aty,pp) => move_aty_into_reg_ap(aty,tmp,size_ff, + store_indexed(base_reg,offset,R tmp,C)) + + fun force_reset_aux_region_kill_tmp0(sma,t:reg,size_ff,C) = + let fun do_reset(aty,pp) = move_aty_into_reg_ap(aty,t,size_ff, + reset_region(t,tmp_reg0,size_ff,C)) + fun maybe_reset(aty,pp) = + let val default_lab = new_local_lab "no_reset" + in move_aty_into_reg_ap(aty,t,size_ff, (* We check the inf bit but not the storage mode *) + I.btq(I "0", R t) :: (* Is region infinite? kill tmp_reg0. *) + I.jnc default_lab :: + reset_region(t,tmp_reg0,size_ff, + I.lab default_lab :: C)) + end + in case sma + of LS.ATTOP_LI(aty,pp) => do_reset(aty,pp) + | LS.ATTOP_LF _ => C + | LS.ATTOP_FI(aty,pp) => do_reset(aty,pp) + | LS.ATTOP_FF(aty,pp) => maybe_reset(aty,pp) + | LS.ATBOT_LI(aty,pp) => do_reset(aty,pp) + | LS.ATBOT_LF _ => C + | LS.SAT_FI(aty,pp) => do_reset(aty,pp) (* We do not check the storage mode *) + | LS.SAT_FF(aty,pp) => maybe_reset(aty,pp) + | LS.IGNORE => C + end + + fun maybe_reset_aux_region_kill_tmp0(sma,t:reg,size_ff,C) = + case sma + of LS.ATBOT_LI(aty,pp) => move_aty_into_reg_ap(aty,t,size_ff, + reset_region(t,tmp_reg0,size_ff,C)) + | LS.SAT_FI(aty,pp) => + let val default_lab = new_local_lab "no_reset" + in move_aty_into_reg_ap(aty,t,size_ff, + I.btq(I "1", R t) :: (* Is storage mode atbot? kill tmp_reg0. *) + I.jnc default_lab :: + reset_region(t,tmp_reg0,size_ff, + I.lab default_lab :: C)) + end + | LS.SAT_FF(aty,pp) => + let val default_lab = new_local_lab "no_reset" + in move_aty_into_reg_ap(aty,t,size_ff, + I.btq (I "0", R t) :: (* Is region infinite? *) + I.jnc default_lab :: + I.btq (I "1", R t) :: (* Is atbot bit set? *) + I.jnc default_lab :: + reset_region(t,tmp_reg0,size_ff, + I.lab default_lab :: C)) + end + | _ => C + + (* Compile Switch Statements *) + local + fun new_label str = new_local_lab str + fun label(lab,C) = I.lab lab :: C + fun jmp(lab,C) = I.jmp(L lab) :: rem_dead_code C + fun inline_cont C = + case C + of (i as I.jmp _) :: _ => SOME (fn C => i :: rem_dead_code C) + | _ => NONE + in + fun binary_search(sels, + default, + opr: I.ea, + compile_insts, + toInt : 'a -> Int32.int, + C) = + let + val sels = map (fn (i,e) => (toInt i, e)) sels + fun if_not_equal_go_lab (lab,i,C) = I.cmpq(I (intToStr i),opr) :: I.jne lab :: C + fun if_less_than_go_lab (lab,i,C) = I.cmpq(I (intToStr i),opr) :: I.jl lab :: C + fun if_greater_than_go_lab (lab,i,C) = I.cmpq(I (intToStr i),opr) :: I.jg lab :: C + in + if jump_tables then + JumpTables.binary_search_new + (sels, + default, + comment, + new_label, + if_not_equal_go_lab, + if_less_than_go_lab, + if_greater_than_go_lab, + compile_insts, + label, + jmp, + fn (sel1,sel2) => Int32.abs(sel1-sel2), (* sel_dist *) + fn (lab,sel,_,C) => (I.movq(opr, R tmp_reg0) :: + I.salq(I "3", R tmp_reg0) :: + I.push(R tmp_reg1) :: + I.movq(LA lab,R tmp_reg1) :: + I.addq(R tmp_reg1, R tmp_reg0) :: + I.pop(R tmp_reg1) :: + I.jmp(D(intToStr(~8*sel), tmp_reg0)) :: + rem_dead_code C), + fn (lab,C) => I.dot_quad (I.pr_lab lab) :: C, (*add_label_to_jump_tab*) + I.eq_lab, + inline_cont, + C) + else + JumpTables.linear_search_new(sels, + default, + comment, + new_label, + if_not_equal_go_lab, + compile_insts, + label, + jmp, + inline_cont, + C) + end + end + + (* Compile switches on constructors, integers, and words *) + fun compileNumSwitch {size_ff,size_ccf,CG_lss,toInt,opr_aty,oprBoxed,sels,default,C} = + let + val (opr_reg, F) = + case opr_aty + of SS.PHREG_ATY r => (r, fn C => C) + | _ => (tmp_reg1, fn C => move_aty_into_reg(opr_aty,tmp_reg1,size_ff, C)) + val opr = if oprBoxed then D("8", opr_reg) (* boxed representation of nums *) + else R opr_reg (* unboxed representation of nums *) + in + F (binary_search(sels, + default, + opr, + fn (lss,C) => CG_lss(lss,size_ff,size_ccf,C), (* compile_insts *) + toInt, + C)) + end + + + fun cmpi_kill_tmp01 {box} (jump,x,y,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + val true_lab = new_local_lab "true" + val cont_lab = new_local_lab "cont" + fun compare C = + if box then + I.movq(D("8",y_reg), R tmp_reg1) :: + I.movq(D("8",x_reg), R tmp_reg0) :: + I.cmpl(R (I.doubleOfQuadReg tmp_reg1), + R (I.doubleOfQuadReg tmp_reg0)) :: C + else I.cmpl(R (I.doubleOfQuadReg y_reg), + R (I.doubleOfQuadReg x_reg)) :: C + in + x_C( + y_C( + compare ( + jump true_lab :: + I.movq(I (i2s BI.ml_false), R d_reg) :: + I.jmp(L cont_lab) :: + I.lab true_lab :: + I.movq(I (i2s BI.ml_true), R d_reg) :: + I.lab cont_lab :: C'))) + end + + fun cmpi_and_jmp_kill_tmp01(jump,x,y,lab_t,lab_f,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + in + x_C(y_C( + I.cmpl(R (I.doubleOfQuadReg y_reg), R (I.doubleOfQuadReg x_reg)) :: + jump lab_t :: + I.jmp (L lab_f) :: rem_dead_code C)) + end + + (* version with boxed arguments; assume tagging is enabled *) + fun cmpbi_and_jmp_kill_tmp01(jump,x,y,lab_t,lab_f,size_ff,C) = + if BI.tag_values() then + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + in + x_C(y_C( + I.movq(D("8", y_reg), R tmp_reg1) :: + I.movq(D("8", x_reg), R tmp_reg0) :: + I.cmpl(R (I.doubleOfQuadReg tmp_reg1), + R (I.doubleOfQuadReg tmp_reg0)) :: + jump lab_t :: + I.jmp (L lab_f) :: rem_dead_code C)) + end + else die "cmpbi_and_jmp_kill_tmp01: tagging disabled!" + + fun jump_overflow C = I.jo (NameLab "__raise_overflow") :: C + + fun sub_num_kill_tmp01 {ovf : bool, tag: bool} (x,y,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + fun check_ovf C = if ovf then jump_overflow C else C + fun do_tag C = if tag then I.addq(I "1",R d_reg) :: check_ovf C (* check twice *) + else C + in + x_C(y_C( + copy(y_reg, tmp_reg1, + copy(x_reg, d_reg, + I.subl(R (I.doubleOfQuadReg tmp_reg1), + R (I.doubleOfQuadReg d_reg)) :: + check_ovf (do_tag C'))))) + end + + fun add_num_kill_tmp01 {ovf,tag} (x,y,d,size_ff,C) = (* Be careful - when tag and ovf, add may + * raise overflow when it is not supposed + * to, if one is not careful! sub_num above + * is ok, I think! mael 2001-05-19 *) + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + fun check_ovf C = if ovf then jump_overflow C else C + fun do_tag C = if tag then I.addl(I "-1", R (I.doubleOfQuadReg d_reg)) :: check_ovf C + else C + in if tag andalso ovf then + (x_C(y_C( + copy(y_reg, tmp_reg1, I.sarl(I "1", R (I.doubleOfQuadReg tmp_reg1)) :: (* t1 = untag y *) + copy(x_reg, tmp_reg0, I.sarl(I "1", R (I.doubleOfQuadReg tmp_reg0)) :: (* t0 = untag x *) + I.addl(R (I.doubleOfQuadReg tmp_reg0), + R (I.doubleOfQuadReg tmp_reg1)) :: (* t1 = t1 + t0 *) + copy(tmp_reg1, d_reg, + I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: (* d = tag d *) + I.sarl(I "1", R (I.doubleOfQuadReg d_reg)) :: (* d = untag d *) + I.cmpl(R (I.doubleOfQuadReg d_reg), + R (I.doubleOfQuadReg tmp_reg1)) :: + I.jne (NameLab "__raise_overflow") :: + I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: (* d = tag d *) + C')))))) + else + (x_C(y_C( + copy(y_reg, tmp_reg1, + copy(x_reg, d_reg, + I.addl(R (I.doubleOfQuadReg tmp_reg1), + R (I.doubleOfQuadReg d_reg)) :: + check_ovf (do_tag C')))))) + end + + fun mul_num_kill_tmp01 {ovf,tag} (x,y,d,size_ff,C) = (* does (1 * valOf Int31.minInt) raise Overflow ? *) + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + fun check_ovf C = if ovf then jump_overflow C else C + in x_C(y_C( + copy(y_reg, tmp_reg1, + copy(x_reg, d_reg, + if tag then (* A[i*j] = 1 + (A[i] >> 1) * (A[j]-1) *) + I.sarl(I "1", R (I.doubleOfQuadReg d_reg)) :: + I.subl(I "1", R (I.doubleOfQuadReg tmp_reg1)) :: + I.imull(R (I.doubleOfQuadReg tmp_reg1), + R (I.doubleOfQuadReg d_reg)) :: + check_ovf ( + I.addl(I "1", R (I.doubleOfQuadReg d_reg)) :: + check_ovf C') + else + I.imull(R (I.doubleOfQuadReg tmp_reg1), + R (I.doubleOfQuadReg d_reg)) :: + check_ovf C')))) + end + + fun neg_int_kill_tmp0 {tag} (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + fun do_tag C = if tag then I.addl(I "2", R (I.doubleOfQuadReg d_reg)) :: + jump_overflow C + else C + in x_C(copy(x_reg, d_reg, + I.negl (R (I.doubleOfQuadReg d_reg)) :: + jump_overflow ( + do_tag C'))) + end + + fun neg_int32b_kill_tmp0 (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "neg_int32b_kill_tmp0.tagging required" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + in x_C( + load_indexed(R tmp_reg0,x_reg,WORDS 1, + I.negl(R (I.doubleOfQuadReg tmp_reg0)) :: + jump_overflow ( + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg,WORDS 1, R tmp_reg0, (* store negated value *) + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))) (* store tag *) + end + + fun abs_int_kill_tmp0 {tag} (x,d,size_ff,C) = + let val cont_lab = new_local_lab "cont" + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun do_tag C = if tag then I.addl(I "2", R (I.doubleOfQuadReg d_reg)) :: + jump_overflow C + else C + in + x_C(copy(x_reg,d_reg, + I.cmpl(I "0", R (I.doubleOfQuadReg d_reg)) :: + I.jge cont_lab :: + I.negl (R (I.doubleOfQuadReg d_reg)) :: + jump_overflow ( + do_tag ( + I.lab cont_lab :: C')))) + end + + + fun abs_int32b_kill_tmp0 (b,x,d,size_ff,C) = + let val cont_lab = new_local_lab "cont" + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + in + x_C( + load_indexed(R tmp_reg0,x_reg,WORDS 1, + I.cmpl(I "0", R (I.doubleOfQuadReg tmp_reg0)) :: + I.jge cont_lab :: + I.negl (R (I.doubleOfQuadReg tmp_reg0)) :: + jump_overflow ( + I.lab cont_lab :: + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, (* store negated value *) + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))) (* store tag *) + end + + fun word32ub_to_int32ub (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + in x_C(copy(x_reg, d_reg, + I.btq(I "31", R d_reg) :: (* sign bit set? *) + I.jc (NameLab "__raise_overflow") :: C')) + end + + fun num31_to_num32ub (x,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + in x_C(copy(x_reg, d_reg, I.sarl (I "1", R (I.doubleOfQuadReg d_reg)) :: C')) + end + + fun int32_to_int31 {boxedarg} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + in x_C( + maybe_unbox( + I.imull(I "2", R (I.doubleOfQuadReg d_reg)) :: + jump_overflow ( + I.addq(I "1", R d_reg) :: C'))) (* No need to check for overflow after adding 1; the + * intermediate result is even (after multiplying + * with 2) so adding one cannot give Overflow because the + * largest integer is odd! mael 2001-04-29 *) + end + + fun word32_to_int31 {boxedarg,ovf} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + fun check_ovf C = + if ovf then + I.btq(I "30", R d_reg) :: + I.jc (NameLab "__raise_overflow") :: + C + else C + in x_C( + maybe_unbox( + check_ovf( + I.imull(I "2", R (I.doubleOfQuadReg d_reg)) :: + jump_overflow ( + I.addq(I "1", R d_reg) :: C')))) (* No need to check for overflow after adding 1; the + * intermediate result is even (after multiplying + * with 2) so adding one cannot give Overflow because the + * largest integer is odd! mael 2001-04-29 *) + end + + fun word32_to_word31 {boxedarg} (x,d,size_ff,C) = + let + val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff, C) + fun maybe_unbox C = if boxedarg then load_indexed(R d_reg,x_reg,WORDS 1,C) + else copy(x_reg,d_reg,C) + in x_C( + maybe_unbox( +(* + I.salq(I "1", R d_reg) :: + I.addq(I "1", R d_reg) :: +*) I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: + C')) + end + + fun bin_float_op_kill_tmp01 finst (x,y,b,d,size_ff,C) = + let val x_C = load_float_aty(x, tmp_reg0, size_ff, xmm1) + val y_C = load_float_aty(y, tmp_reg0, size_ff, xmm0) + val (b_reg, b_C) = resolve_arg_aty(b, tmp_reg0, size_ff) + val (d_reg, C') = resolve_aty_def(d, tmp_reg0, size_ff, C) + in + y_C(x_C(finst(R xmm0,R xmm1) :: + b_C(store_float_reg(b_reg,tmp_reg1,xmm1, + copy(b_reg,d_reg, C'))))) + end + + fun addf_kill_tmp01 a = bin_float_op_kill_tmp01 I.addsd a + fun subf_kill_tmp01 a = bin_float_op_kill_tmp01 I.subsd a + fun mulf_kill_tmp01 a = bin_float_op_kill_tmp01 I.mulsd a + fun divf_kill_tmp01 a = bin_float_op_kill_tmp01 I.divsd a + + fun negf_kill_tmp01 (b,x,d,size_ff,C) = + let val x_C = load_float_aty(x, tmp_reg0, size_ff,xmm1) + val (b_reg, b_C) = resolve_arg_aty(b, tmp_reg0, size_ff) + val (d_reg, C') = resolve_aty_def(d, tmp_reg0, size_ff, C) + in + x_C(I.xorps (R xmm0,R xmm0) :: I.subsd (R xmm1,R xmm0) :: + b_C(store_float_reg(b_reg,tmp_reg1,xmm0, + copy(b_reg,d_reg, C')))) + end + + fun absf_kill_tmp01 (b,x,d,size_ff,C) = + let val x_C = load_float_aty(x, tmp_reg0, size_ff,xmm1) + val (b_reg, b_C) = resolve_arg_aty(b, tmp_reg0, size_ff) + val (d_reg, C') = resolve_aty_def(d, tmp_reg0, size_ff, C) + in + x_C(I.xorps (R xmm0,R xmm0) :: I.subsd (R xmm1,R xmm0) :: I.maxsd (R xmm1,R xmm0) :: + b_C(store_float_reg(b_reg,tmp_reg1,xmm0, + copy(b_reg,d_reg, C')))) + end + + datatype cond = LESSTHAN | LESSEQUAL | GREATERTHAN | GREATEREQUAL + + fun cmpf_kill_tmp01 (cond,x,y,d,size_ff,C) = (* ME MEMO *) + let val x_C = load_float_aty(x, tmp_reg0, size_ff, xmm0) + val y_C = load_float_aty(y, tmp_reg0, size_ff, xmm1) + val (d_reg, C') = resolve_aty_def(d, tmp_reg0, size_ff, C) + val true_lab = new_local_lab "true" + val cont_lab = new_local_lab "cont" + val jump = (* from gcc experiments *) + case cond of + LESSTHAN => I.jb (*below*) + | LESSEQUAL => I.jbe (*below or equal*) + | GREATERTHAN => I.ja (*above*) + | GREATEREQUAL => I.jae (*above or equal*) + val load_args = x_C o y_C + in + load_args(I.ucomisd (R xmm1, R xmm0) :: + jump true_lab :: + I.movq(I (i2s BI.ml_false), R d_reg) :: + I.jmp(L cont_lab) :: + I.lab true_lab :: + I.movq(I (i2s BI.ml_true), R d_reg) :: + I.lab cont_lab :: + C') + end + + fun bin_op_kill_tmp01 inst (x,y,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + in + x_C(y_C( + copy(y_reg, tmp_reg1, + copy(x_reg, d_reg, + inst(R (I.doubleOfQuadReg tmp_reg1), + R (I.doubleOfQuadReg d_reg)) :: C')))) + end + + (* andb and orb are the same for 31 bit (tagged) and + * 32 bit (untagged) representations *) + fun andb_word_kill_tmp01 a = bin_op_kill_tmp01 I.andl a (* A[x&y] = A[x] & A[y] tagging *) + fun orb_word_kill_tmp01 a = bin_op_kill_tmp01 I.orl a (* A[x|y] = A[x] | A[y] tagging *) + + (* xorb needs to set the lowest bit for the 31 bit (tagged) version *) + fun xorb_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + fun do_tag C = if tag then I.orq(I "1", R d_reg) :: C else C + in + x_C(y_C( + copy(y_reg, tmp_reg1, + copy(x_reg, d_reg, + I.xorl(R (I.doubleOfQuadReg tmp_reg1), + R (I.doubleOfQuadReg d_reg)) :: + do_tag C')))) + end + + fun bin_op_w32boxed__ {ovf} inst (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + if not(BI.tag_values()) then die "bin_op_w32boxed__.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg1,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + fun check_ovf C = if ovf then jump_overflow C else C + in + x_C( + load_indexed(R tmp_reg0,x_reg,WORDS 1, + y_C( + load_indexed(R tmp_reg1,y_reg,WORDS 1, + inst(R (I.doubleOfQuadReg tmp_reg0), + R (I.doubleOfQuadReg tmp_reg1)) :: + check_ovf ( + move_aty_into_reg(r,d_reg,size_ff, + store_indexed(d_reg,WORDS 1,R tmp_reg1, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))))) (* store tag *) + end + + fun addw32boxed(r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + bin_op_w32boxed__ {ovf=false} I.addl (r,x,y,d,size_ff,C) + + fun subw32boxed(r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + bin_op_w32boxed__ {ovf=false} I.subl (r,y,x,d,size_ff,C) (* x and y swapped, see spec for subq *) + + fun mulw32boxed(r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + bin_op_w32boxed__ {ovf=false} I.imull (r,x,y,d,size_ff,C) + + fun orw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + bin_op_w32boxed__ {ovf=false} I.orl (r,x,y,d,size_ff,C) + + fun andw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + bin_op_w32boxed__ {ovf=false} I.andl (r,x,y,d,size_ff,C) + + fun xorw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + bin_op_w32boxed__ {ovf=false} I.xorl (r,x,y,d,size_ff,C) + + fun mul_int32b (b,x,y,d,size_ff,C) = + bin_op_w32boxed__ {ovf=true} I.imull (b,x,y,d,size_ff,C) + + fun sub_int32b (b,x,y,d,size_ff,C) = + bin_op_w32boxed__ {ovf=true} I.subl (b,y,x,d,size_ff,C) + + fun add_int32b (b,x,y,d,size_ff,C) = + bin_op_w32boxed__ {ovf=true} I.addl (b,x,y,d,size_ff,C) + + fun num31_to_num32b(b,x,d,size_ff,C) = (* a boxed word is tagged as a scalar record *) + if BI.tag_values() then + let val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + in + move_aty_into_reg(x,tmp_reg0,size_ff, + I.sarl(I "1", R (I.doubleOfQuadReg tmp_reg0)) :: + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg,WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))) (* store tag *) + end + else die "num31_to_num32b.tagging_disabled" + + fun num32b_to_num32b {ovf:bool} (b,x,d,size_ff,C) = + if not(BI.tag_values()) then die "num32b_to_num32b.tagging_disabled" + else + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff, C) + fun check_ovf C = + if ovf then + I.btq(I "31", R tmp_reg0) :: (* sign bit set? *) + I.jc (NameLab "__raise_overflow") :: C + else C + in + x_C ( + load_indexed(R tmp_reg0,x_reg,WORDS 1, + check_ovf ( + move_aty_into_reg(b,d_reg,size_ff, + store_indexed(d_reg, WORDS 1, R tmp_reg0, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C')))))) (* store tag *) + end + + fun shift_w32boxed__ inst (r,x,y,d,size_ff,C) = + if not(BI.tag_values()) then die "shift_w32boxed__.tagging is not enabled as required" + else + (* y is unboxed and tagged *) + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,rcx,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg0,size_ff,C) + in + x_C( + load_indexed(R tmp_reg1,x_reg,WORDS 1, + copy(rcx, tmp_reg0, (* save rcx *) + y_C( + copy(y_reg,rcx, (* tmp_reg0 = %r10, see InstsX64.sml *) + I.sarq (I "1", R rcx) :: (* untag y: y >> 1 *) + inst(R cl, R (I.doubleOfQuadReg tmp_reg1)) :: + copy(tmp_reg0, rcx, (* restore rcx *) + move_aty_into_reg(r,d_reg,size_ff, + store_indexed(d_reg,WORDS 1, R tmp_reg1, + store_immed(BI.tag_word_boxed false, d_reg, WORDS 0, C'))))))))) (* store tag *) + end + + fun shift_leftw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + shift_w32boxed__ I.sall (r,x,y,d,size_ff,C) + + fun shift_right_signedw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + shift_w32boxed__ I.sarl (r,x,y,d,size_ff,C) + + fun shift_right_unsignedw32boxed__ (r,x,y,d,size_ff,C) = (* Only used when tagging is enabled; Word32.sml *) + shift_w32boxed__ I.shrl (r,x,y,d,size_ff,C) + + fun shift_left_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10*) + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,rcx,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + (* y is represented tagged only when BI.tag_values() is true *) + fun untag_y C = if BI.tag_values() then I.sarq (I "1", R rcx) :: C (* y >> 1 *) + else C + in + if tag then (* 1 + ((x - 1) << (y >> 1)) *) + x_C( + I.movq(R rcx, R tmp_reg0) :: (* save rcx *) + copy(x_reg, tmp_reg1, + y_C( + copy(y_reg, rcx, + I.decq (R tmp_reg1) :: (* x - 1 *) + untag_y ( (* y >> 1 *) + I.sall (R cl, R (I.doubleOfQuadReg tmp_reg1)) :: (* << *) + I.movq (R tmp_reg0, R rcx) :: (* restore rcx *) + I.incq (R tmp_reg1) :: (* 1 + *) + copy(tmp_reg1, d_reg, C')))))) + else + x_C( + copy(rcx, tmp_reg0, (* save rcx *) + copy(x_reg, tmp_reg1, + y_C( + copy(y_reg, rcx, + I.sall(R cl, R (I.doubleOfQuadReg tmp_reg1)) :: + copy(tmp_reg0, rcx, (* restore rcx *) + copy(tmp_reg1, d_reg, C'))))))) + end + + fun shift_right_signed_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10*) + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,rcx,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + (* y is represented tagged only when BI.tag_values() is true *) + fun untag_y C = if BI.tag_values() then I.sarq (I "1", R rcx) :: C (* y >> 1 *) + else C + in + if tag then (* 1 | ((x) >> (y >> 1)) *) + x_C( + I.movq(R rcx, R tmp_reg0) :: (* save rcx *) + copy(x_reg, tmp_reg1, + y_C( + copy(y_reg, rcx, + I.decq (R tmp_reg1) :: (* x - 1 *) + untag_y ( (* y >> 1 *) + I.sarl (R cl, R (I.doubleOfQuadReg tmp_reg1)) :: (* x >> *) + copy(tmp_reg0, rcx, (* restore rcx *) + I.orq (I "1", R tmp_reg1) :: (* 1 | *) + copy(tmp_reg1, d_reg, C'))))))) + else + x_C( + copy(rcx, tmp_reg0, (* save rcx *) + copy(x_reg, tmp_reg1, + y_C( + copy(y_reg, rcx, + I.sarl(R cl, R (I.doubleOfQuadReg tmp_reg1)) :: + copy(tmp_reg0, rcx, (* restore rcx *) + copy(tmp_reg1, d_reg, C'))))))) + end + + fun shift_right_unsigned_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = (*tmp_reg0 = %r10 *) + let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) + val (y_reg,y_C) = resolve_arg_aty(y,rcx,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + (* y is represented tagged only when BI.tag_values() is true *) + fun untag_y C = if BI.tag_values() then I.sarq (I "1", R rcx) :: C (* y >> 1 *) + else C + in + if tag then (* 1 | ((unsigned long)(x) >> (y >> 1)) *) + x_C( + copy(rcx, tmp_reg0, (* save rcx *) + copy(x_reg, tmp_reg1, + y_C( + copy(y_reg, rcx, + untag_y ( (* y >> 1 *) + I.shrl (R cl, R (I.doubleOfQuadReg tmp_reg1)) :: (* (unsigned long)x >> *) + I.orq (I "1", R tmp_reg1) :: (* 1 | *) + copy(tmp_reg0, rcx, + copy(tmp_reg1, d_reg, C')))))))) + else + x_C( + copy(rcx, tmp_reg0, (* save rcx *) + copy(x_reg, tmp_reg1, + y_C( + copy(y_reg, rcx, + I.shrl(R cl, R (I.doubleOfQuadReg tmp_reg1)) :: + copy(tmp_reg0, rcx, (* restore rcx *) + copy(tmp_reg1, d_reg, C'))))))) + end + + fun bytetable_sub(t,i,d,size_ff,C) = + let val (t_reg,t_C) = resolve_arg_aty(t,tmp_reg1,size_ff) + val (i_reg,i_C) = resolve_arg_aty(i,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + (* i is represented tagged only when BI.tag_values() is true *) + in if BI.tag_values() then + t_C(i_C( + copy(i_reg, rcx, (* tmp_reg0 = %rcx *) + I.sarq (I "1", R rcx) :: (* i >> 1 *) + I.movzbq(DD("8",t_reg,rcx,"1"), R d_reg) :: + I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: + C'))) + else + t_C(i_C( + I.movzbq(DD("8",t_reg,i_reg,"1"), R d_reg) :: + C')) + end + + fun resolve_args(atys,ts,size_ff) = + case atys + of nil => SOME (nil, fn C => C) + | SS.PHREG_ATY r :: atys => + (case resolve_args(atys,ts,size_ff) + of SOME (rs,F) => SOME (r::rs,F) + | NONE => NONE) + | aty :: atys => + (case ts + of nil => NONE + | t::ts => + (case resolve_args(atys,ts,size_ff) + of SOME (rs,F) => SOME (t::rs, fn C => F(move_aty_into_reg(aty,t,size_ff,C))) + | NONE => NONE)) + + fun bytetable_update(t,i,x,d,size_ff,C) = + if BI.tag_values() then + let + (* i, x are represented tagged only when BI.tag_values() is true *) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + in + move_aty_into_reg(t,tmp_reg0,size_ff, (* tmp_reg0 = t *) + move_aty_into_reg(i,tmp_reg1,size_ff, (* tmp_reg1 = i *) + I.sarq (I "1", R tmp_reg1) :: (* untag i: tmp_reg1 >> 1 *) + I.addq(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) + move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 (%r10) = x *) + I.sarq (I "1", R tmp_reg0) :: (* untag x: tmp_reg0 >> 1 *) + I.movb(R r10b, D("8", tmp_reg1)) :: (* *(tmp_reg1+8) = %r10b *) + move_immed(Int32.fromInt BI.ml_unit, R d_reg, (* d = () *) + C')))) + end + else + (case resolve_args([t,i],[tmp_reg1],size_ff) + of SOME ([t_reg,i_reg],F) => + F( + move_aty_into_reg(x,tmp_reg0,size_ff, + I.movb(R r10b, DD("8", t_reg, i_reg, "1")) :: (*tmp_reg0==%r10*) + C)) + | SOME _ => die "bytetable_update" + | NONE => + move_aty_into_reg(t,tmp_reg0,size_ff, (* tmp_reg0 = t *) + move_aty_into_reg(i,tmp_reg1,size_ff, (* tmp_reg1 = i *) + I.addq(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) + move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 (%rcx) = x *) + I.movb(R r10b, D("8", tmp_reg1)) :: (* *(tmp_reg1+8) = %r10b *) + C)))) + + fun bytetable_size(t,d,size_ff,C) = + let val (t_reg,t_C) = resolve_arg_aty(t,tmp_reg0,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + in if BI.tag_values() then + t_C( + I.movq(D("0",t_reg), R d_reg) :: + I.sarq (I "6", R d_reg) :: (* d >> 6: remove tag (Tagging.h) *) +(* + I.salq(I "1", R d_reg) :: (* d = tag d *) + I.addq(I "1", R d_reg) :: +*) I.leaq(DD("1", d_reg, d_reg, ""), R d_reg) :: + C') + else + t_C( + I.movq(D("0",t_reg), R d_reg) :: + I.sarq (I "6", R d_reg) :: (* d >> 6: remove tag (Tagging.h) *) + C') + end + + fun word_sub0(t,i,d,size_ff,C) = + let val (t_reg,t_C) = resolve_arg_aty(t,tmp_reg1,size_ff) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + (* i is represented tagged only when BI.tag_values() is true *) + in if BI.tag_values() then + t_C( + move_aty_into_reg(i,tmp_reg0,size_ff, + I.sarq (I "1", R tmp_reg0) :: (* i >> 1 *) + I.movq(DD("8",t_reg,tmp_reg0,"8"), R d_reg) :: + C')) + else + let val (i_reg,i_C) = resolve_arg_aty(i,tmp_reg0,size_ff) + in + t_C(i_C( + I.movq(DD("8",t_reg,i_reg,"8"), R d_reg) :: + C')) + end + end + + fun word_update0(t,i,x,d,size_ff,C) = + if BI.tag_values() then + let + (* i, x are represented tagged only when BI.tag_values() is true *) + val (d_reg,C') = resolve_aty_def(d,tmp_reg1,size_ff,C) + in + case resolve_args([t,x],[tmp_reg1], size_ff) + of SOME ([t_reg,x_reg], F) => + F(move_aty_into_reg(i,tmp_reg0,size_ff, + I.sarq (I "1", R tmp_reg0) :: + I.movq(R x_reg, DD("8", t_reg, tmp_reg0, "8")) :: + move_immed(Int32.fromInt BI.ml_unit, R d_reg, + C'))) + | SOME _ => die "word_update0_1" + | NONE => + (move_aty_into_reg(i,tmp_reg1,size_ff, (* tmp_reg1 = i *) + I.sarq(I "1", R tmp_reg1) :: (* untag i: tmp_reg1 >> 1 *) + I.salq(I "2", R tmp_reg1) :: (* i << 2 *) + move_aty_into_reg(t,tmp_reg0,size_ff, (* tmp_reg0 = t *) + I.addq(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) + move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 = x *) + I.movq(R tmp_reg0, D("8", tmp_reg1)) :: (* *(tmp_reg1+8) = tmp_reg0 *) + move_immed(Int32.fromInt BI.ml_unit, R d_reg, (* d = () *) + C'))))) + end + else + (case resolve_args([t,i,x],[tmp_reg0,tmp_reg1], size_ff) + of SOME ([t_reg,i_reg,x_reg], F) => + F(I.movq(R x_reg, DD("8", t_reg, i_reg, "8")) :: C) + | SOME _ => die "word_update0_2" + | NONE => + move_aty_into_reg(i,tmp_reg1,size_ff, (* tmp_reg1 = i *) + I.imulq(I "4", R tmp_reg1) :: (* i << 2 *) + move_aty_into_reg(t,tmp_reg0,size_ff, (* tmp_reg0 = t *) + I.addq(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) + move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 = x *) + I.movq(R tmp_reg0, D("8", tmp_reg1)) :: (* *(tmp_reg1+8) = tmp_reg0 *) + C)))) + + fun table_size a = bytetable_size a + + (*******************) + (* Code Generation *) + (*******************) + + (* printing an assignment *) + fun debug_assign(str,C) = C +(* if Flags.is_on "debug_codeGen" then + let + val string_lab = gen_string_lab (str ^ "\n") + in + COMMENT "Start of Debug Assignment" :: + load_label_addr_kill_gen1(string_lab,SS.PHREG_ATY arg0,0, + compile_c_call_prim("printString",[SS.PHREG_ATY arg0],NONE,0,tmp_reg0 (*not used*), + COMMENT "End of Debug Assignment" :: C)) + end + else C*) + + fun CG_lss(lss,size_ff,size_ccf,C) = + let + fun pr_ls ls = LS.pr_line_stmt SS.pr_sty SS.pr_offset SS.pr_aty true ls + fun CG_ls(ls,C) = + (case ls + of LS.ASSIGN{pat=SS.FLOW_VAR_ATY(lv,lab_t,lab_f), + bind=LS.CON0{con,con_kind,aux_regions=[],alloc=LS.IGNORE}} => + if Con.eq(con,Con.con_TRUE) then I.jmp(L(LocalLab lab_t)) :: rem_dead_code C + else + if Con.eq(con,Con.con_FALSE) then I.jmp(L(LocalLab lab_f)) :: rem_dead_code C + else die "CG_lss: unmatched assign on flow variable" + | LS.ASSIGN{pat,bind} => + debug_assign(""(*pr_ls ls*), + comment_fn (fn () => "ASSIGN: " ^ pr_ls ls, + (case bind + of LS.ATOM src_aty => move_aty_to_aty(src_aty,pat,size_ff,C) + | LS.LOAD label => load_from_label(DatLab label,pat,tmp_reg1,size_ff,C) + | LS.STORE(src_aty,label) => + (gen_data_lab label; + store_in_label(src_aty,DatLab label,tmp_reg1,size_ff,C)) + | LS.STRING str => + let val string_lab = gen_string_lab str + in load_label_addr(string_lab,pat,tmp_reg1,size_ff,C) + end + | LS.REAL str => + let val float_lab = new_float_lab() + val _ = + if BI.tag_values() then + add_static_data [I.dot_data, + I.lab float_lab, + I.dot_quad(BI.pr_tag_w(BI.tag_real(true))), + I.dot_double str] + else + add_static_data [I.dot_data, + I.lab float_lab, + I.dot_double str] + in load_label_addr(float_lab,pat,tmp_reg1,size_ff,C) + end + | LS.CLOS_RECORD{label,elems=elems as (lvs,excons,rhos),alloc} => + let val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + val num_elems = List.length (LS.smash_free elems) + val n_skip = length rhos + 1 (* We don't traverse region pointers, + * i.e. we skip rhos+1 fields *) + in + if BI.tag_values() then + alloc_ap_kill_tmp01(alloc,reg_for_result,num_elems+2,size_ff, + store_immed(BI.tag_clos(false,num_elems+1,n_skip), reg_for_result, WORDS 0, + + load_label_addr(MLFunLab label,SS.PHREG_ATY tmp_reg0,tmp_reg0,size_ff, + store_indexed(reg_for_result,WORDS 1,R tmp_reg0, + + (*store_indexed(reg_for_result,WORDS 1, LA (MLFunLab label),*) + #2(foldr (fn (aty,(offset,C)) => + (offset-1,store_aty_in_reg_record(aty,tmp_reg0,reg_for_result, + WORDS offset,size_ff, C))) + (num_elems+1,C') (LS.smash_free elems)))))) + else + alloc_ap_kill_tmp01(alloc,reg_for_result,num_elems+1,size_ff, + + load_label_addr(MLFunLab label,SS.PHREG_ATY tmp_reg0,tmp_reg0,size_ff, + store_indexed(reg_for_result,WORDS 0,R tmp_reg0, + + (*store_indexed(reg_for_result,WORDS 0, LA (MLFunLab label),*) + #2(foldr (fn (aty,(offset,C)) => + (offset-1,store_aty_in_reg_record(aty,tmp_reg0,reg_for_result, + WORDS offset,size_ff, C))) + (num_elems,C') (LS.smash_free elems))))) + end + | LS.REGVEC_RECORD{elems,alloc} => + let val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + val num_elems = List.length elems + in + if BI.tag_values() then + alloc_ap_kill_tmp01(alloc,reg_for_result,num_elems+1,size_ff, + store_immed(BI.tag_regvec(false,num_elems), reg_for_result, WORDS 0, + #2(foldr (fn (sma,(offset,C)) => + (offset-1,store_sm_in_record(sma,tmp_reg0,reg_for_result, + WORDS offset,size_ff, C))) + (num_elems,C') elems))) + else + alloc_ap_kill_tmp01(alloc,reg_for_result,num_elems,size_ff, + #2(foldr (fn (sma,(offset,C)) => + (offset-1,store_sm_in_record(sma,tmp_reg0,reg_for_result, + WORDS offset,size_ff, C))) + (num_elems-1,C') elems)) + end + | LS.SCLOS_RECORD{elems=elems as (lvs,excons,rhos),alloc} => + let val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + val num_elems = List.length (LS.smash_free elems) + val n_skip = length rhos (* We don't traverse region pointers *) + in + if BI.tag_values() then + alloc_ap_kill_tmp01(alloc,reg_for_result,num_elems+1,size_ff, + store_immed(BI.tag_sclos(false,num_elems,n_skip), reg_for_result, WORDS 0, + #2(foldr (fn (aty,(offset,C)) => + (offset-1,store_aty_in_reg_record(aty,tmp_reg0,reg_for_result, + WORDS offset,size_ff, C))) + (num_elems,C') (LS.smash_free elems)))) + else + alloc_ap_kill_tmp01(alloc,reg_for_result,num_elems,size_ff, + #2(foldr (fn (aty,(offset,C)) => + (offset-1,store_aty_in_reg_record(aty,tmp_reg0,reg_for_result, + WORDS offset,size_ff, C))) + (num_elems-1,C') (LS.smash_free elems))) + end + | LS.RECORD{elems=[],alloc,tag,maybeuntag} => + move_aty_to_aty(SS.UNIT_ATY,pat,size_ff,C) (* Unit is unboxed *) + | LS.RECORD{elems,alloc,tag,maybeuntag} => + + (* Explanation of how we deal with untagged pairs and triples in the presence + * of garbage collection and tagging of values in general + * - mael 2002-10-14: + * + * Only pairs and triples that are stored in infinite regions are untagged + * - that is, pairs and triples stored in finite regions on the stack + * are tagged. Thus, we must be careful to deal + * correctly with regions passed to functions at runtime; if a + * formal region variable has 'finite' multiplicity, the region + * passed at runtime can either be finite or infinite, thus in + * this case, the exact layout of the pair is not determined + * until runtime. + * + * When finite regions of type pair is allocated on the stack, a + * pair-tag is installed in the stack-slot for the region. The + * function alloc_untagged_value_ap_kill_tmp01 returns a pointer to the + * object, or a pointer to the word before the object in case the + * object represents an untagged pair in an infinite region. *) + let + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + val num_elems = List.length elems + fun store_elems last_offset = + #2(foldr (fn (aty,(offset,C)) => + (offset-1,store_aty_in_reg_record(aty,tmp_reg0,reg_for_result, + WORDS offset,size_ff, C))) + (last_offset,C') elems) + val _ = if maybeuntag andalso num_elems <> 2 andalso num_elems <> 3 then + die "cannot untag other tuples than pairs and triples" + else () + in + if BI.tag_values() andalso maybeuntag andalso not(tag_pairs_p()) then + alloc_untagged_value_ap_kill_tmp01 (alloc,reg_for_result,num_elems,size_ff, + store_elems num_elems) + else if BI.tag_values() then + alloc_ap_kill_tmp01(alloc,reg_for_result,num_elems+1,size_ff, + store_immed(tag, reg_for_result, WORDS 0, + store_elems num_elems)) + else + alloc_ap_kill_tmp01(alloc,reg_for_result,num_elems,size_ff, + store_elems (num_elems-1)) + end + | LS.SELECT(i,aty) => + if BI.tag_values() then + move_index_aty_to_aty(aty,pat,WORDS(i+1),tmp_reg1,size_ff,C) + else + move_index_aty_to_aty(aty,pat,WORDS i,tmp_reg1,size_ff,C) + | LS.CON0{con,con_kind,aux_regions,alloc} => + (case con_kind of + LS.ENUM i => + let + val tag = + if BI.tag_values() orelse (*hack to treat booleans tagged*) + Con.eq(con,Con.con_TRUE) orelse Con.eq(con,Con.con_FALSE) then + 2*i+1 + else i + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + in + move_immed(Int32.fromInt tag, R reg_for_result,C') + end + | LS.UNBOXED i => + let + val tag = 4*i+3 + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + fun reset_regions C = + foldr (fn (alloc,C) => + maybe_reset_aux_region_kill_tmp0(alloc,tmp_reg1,size_ff,C)) + C aux_regions + in + reset_regions(move_immed(Int32.fromInt tag, R reg_for_result,C')) + end + | LS.BOXED i => + let + val tag = i2s(Word32.toInt(BI.tag_con0(false,i))) + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + fun reset_regions C = + List.foldr (fn (alloc,C) => + maybe_reset_aux_region_kill_tmp0(alloc,tmp_reg1,size_ff,C)) + C aux_regions + in + reset_regions( + alloc_ap_kill_tmp01(alloc,reg_for_result,1,size_ff, + I.movq(I tag, D("0",reg_for_result)) :: C')) + end) + | LS.CON1{con,con_kind,alloc,arg} => + (case con_kind + of LS.UNBOXED 0 => move_aty_to_aty(arg,pat,size_ff,C) + | LS.UNBOXED i => + let val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + in case i + of 1 => move_aty_into_reg(arg,reg_for_result,size_ff, + I.orq(I "1", R reg_for_result) :: C') + | 2 => move_aty_into_reg(arg,reg_for_result,size_ff, + I.orq(I "2", R reg_for_result) :: C') + | _ => die "CG_ls: UNBOXED CON1 with i > 2" + end + | LS.BOXED i => + let val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + val tag = i2s(Word32.toInt(BI.tag_con1(false,i))) + in + if SS.eq_aty(pat,arg) then (* We must preserve arg. *) + alloc_ap_kill_tmp01(alloc,tmp_reg1,2,size_ff, + I.movq(I tag, D("0", tmp_reg1)) :: + store_aty_in_reg_record(arg,tmp_reg0,tmp_reg1,WORDS 1,size_ff, + copy(tmp_reg1,reg_for_result,C'))) + else + alloc_ap_kill_tmp01(alloc,reg_for_result,2,size_ff, + I.movq(I tag, D("0", reg_for_result)) :: + store_aty_in_reg_record(arg,tmp_reg0,reg_for_result,WORDS 1,size_ff,C')) + end + | _ => die "CON1.con not unary in env.") + | LS.DECON{con,con_kind,con_aty} => + (case con_kind + of LS.UNBOXED 0 => move_aty_to_aty(con_aty,pat,size_ff,C) + | LS.UNBOXED _ => + let + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + in + move_aty_into_reg(con_aty,reg_for_result,size_ff, + I.movq(I "3", R tmp_reg0) :: + I.notq(R tmp_reg0) :: + I.andq(R tmp_reg0, R reg_for_result) :: C') + end + | LS.BOXED _ => move_index_aty_to_aty(con_aty,pat,WORDS 1,tmp_reg1,size_ff,C) + | _ => die "CG_ls: DECON used with con_kind ENUM") + | LS.DEREF aty => + let val offset = if BI.tag_values() then 1 else 0 + in move_index_aty_to_aty(aty,pat,WORDS offset,tmp_reg1,size_ff,C) + end + | LS.REF(alloc,aty) => + let val offset = if BI.tag_values() then 1 else 0 + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + fun maybe_tag_value C = + (* tag_pairs_p is false if pairs, tripples, tables and refs are untagged *) + if BI.tag_values() andalso tag_pairs_p() then + I.movq(I (i2s(Word32.toInt(BI.tag_ref(false)))), + D("0", reg_for_result)) :: C + else C + fun allocate (reg_for_result,C) = + if BI.tag_values() andalso not (tag_pairs_p()) then + alloc_untagged_value_ap_kill_tmp01(alloc,reg_for_result,BI.size_of_ref()-1,size_ff,C) + else + alloc_ap_kill_tmp01(alloc,reg_for_result,BI.size_of_ref(),size_ff,C) +(* val size_of_ref = to be removed 2003-08-26, nh + if BI.tag_values() andalso not (tag_pairs_p()) then + BI.size_of_ref() - 1 + else + BI.size_of_ref()*) + in + if SS.eq_aty(pat,aty) then (* We must preserve aty *) + (*alloc_ap_kill_tmp01(alloc,tmp_reg1,size_of_ref,size_ff, to be removed 2003-08-26, nh*) + allocate (tmp_reg1, + store_aty_in_reg_record(aty,tmp_reg0,tmp_reg1,WORDS offset,size_ff, + copy(tmp_reg1,reg_for_result,maybe_tag_value C'))) + else + (*alloc_ap_kill_tmp01(alloc,reg_for_result,size_of_ref,size_ff,to be removed 2003-08-26, nh*) + allocate (reg_for_result, + store_aty_in_reg_record(aty,tmp_reg0,reg_for_result,WORDS offset,size_ff, + maybe_tag_value C')) + end + | LS.ASSIGNREF(alloc,aty1,aty2) => + let + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + val offset = if BI.tag_values() then 1 else 0 + in + store_aty_in_aty_record(aty2,aty1,WORDS offset,tmp_reg1,tmp_reg0,size_ff, + if BI.tag_values() then + move_immed(Int32.fromInt BI.ml_unit, R reg_for_result,C') + else C') + end + | LS.PASS_PTR_TO_MEM(alloc,i,untagged_value) => + let + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + in + (* HACK: When tagging is enabled, only pairs take up 3 words + * (of those type of objects that can be returned from a C function) *) + (* Hack eliminated: We now pass a boolean which is true for allocations + * of tag-free values. mael 2003-05-13 *) + if BI.tag_values() andalso not(tag_pairs_p()) andalso untagged_value then + alloc_untagged_value_ap_kill_tmp01 (alloc,reg_for_result,i-1,size_ff,C') + else + alloc_ap_kill_tmp01(alloc,reg_for_result,i,size_ff,C') + end + | LS.PASS_PTR_TO_RHO(alloc) => + let + val (reg_for_result,C') = resolve_aty_def(pat,tmp_reg1,size_ff,C) + in + prefix_sm(alloc,reg_for_result,size_ff,C') + end)) + ) (* END ASSIGN *) + + | LS.FLUSH(aty,offset) => comment_fn (fn () => "FLUSH: " ^ pr_ls ls, + store_aty_in_reg_record(aty,tmp_reg1,rsp,WORDS(size_ff-offset-1),size_ff,C)) + | LS.FETCH(aty,offset) => comment_fn (fn () => "FETCH: " ^ pr_ls ls, + load_aty_from_reg_record(aty,tmp_reg1,rsp,WORDS(size_ff-offset-1),size_ff,C)) + | LS.FNJMP(cc as {opr,args,clos,res,bv}) => + comment_fn (fn () => "FNJMP: " ^ pr_ls ls, + let + val (spilled_args,_,_) = CallConv.resolve_act_cc RI.args_phreg RI.res_phreg {args=args,clos=clos, + reg_args=[],reg_vec=NONE,res=res} + val offset_codeptr = if BI.tag_values() then "8" else "0" + in + if List.length spilled_args > 0 then + CG_ls(LS.FNCALL cc,C) + else + case opr (* We fetch the addr from the closure and opr points at the closure *) + of SS.PHREG_ATY opr_reg => + I.movq(D(offset_codeptr,opr_reg), R tmp_reg1) :: (* Fetch code label from closure *) + base_plus_offset(rsp,WORDS(size_ff+size_ccf),rsp, (* return label is now at top of stack *) + I.jmp(R tmp_reg1) :: rem_dead_code C) + | _ => + move_aty_into_reg(opr,tmp_reg1,size_ff, + I.movq(D(offset_codeptr,tmp_reg1), R tmp_reg1) :: (* Fetch code label from closure *) + base_plus_offset(rsp,WORDS(size_ff+size_ccf),rsp, (* return label is now at top of stack *) + I.jmp(R tmp_reg1) :: rem_dead_code C)) + end) + | LS.FNCALL{opr,args,clos,res,bv} => + comment_fn (fn () => "FNCALL: " ^ pr_ls ls, + let + val offset_codeptr = if BI.tag_values() then "8" else "0" + val (spilled_args,spilled_res,_) = + CallConv.resolve_act_cc RI.args_phreg RI.res_phreg {args=args,clos=clos,reg_args=[],reg_vec=NONE,res=res} + val size_rcf = length spilled_res + val size_ccf = length spilled_args + val size_cc = size_rcf+size_ccf+1 +(*val _ = if size_cc > 1 then die ("\nfncall: size_ccf: " ^ (Int.toString size_ccf) ^ " and size_rcf: " ^ + (Int.toString size_rcf) ^ ".") else () (* debug 2001-01-08, Niels *)*) + + val return_lab = new_local_lab "return_from_app" + fun flush_args C = + foldr (fn ((aty,offset),C) => push_aty(aty,tmp_reg1,size_ff+offset,C)) C spilled_args + (* We pop in reverse order such that size_ff+offset works *) + fun fetch_res C = + foldr (fn ((aty,offset),C) => + pop_aty(aty,tmp_reg1,size_ff+offset,C)) C (rev spilled_res) + fun jmp C = + case opr (* We fetch the add from the closure and opr points at the closure *) + of SS.PHREG_ATY opr_reg => + I.movq(D(offset_codeptr,opr_reg), R tmp_reg1) :: (* Fetch code pointer *) + I.jmp(R tmp_reg1) :: C + | _ => + move_aty_into_reg(opr,tmp_reg1,size_ff+size_cc, (* rsp is now pointing after the call *) + I.movq(D(offset_codeptr,tmp_reg1), R tmp_reg1) :: (* convention, i.e., size_ff+size_cc *) + I.jmp(R tmp_reg1) :: C) + in + base_plus_offset(rsp,WORDS(~size_rcf),rsp, (* Move rsp after rcf *) + I.push(LA return_lab) :: (* Push Return Label *) + flush_args(jmp(gen_bv(bv, I.lab return_lab :: fetch_res C)))) + end) + | LS.JMP(cc as {opr,args,reg_vec,reg_args,clos,res,bv}) => + comment_fn (fn () => "JMP: " ^ pr_ls ls, + let + (* The stack looks as follows - growing downwards to the right: + * + * ... | ff | rcf | retlab | ccf | ff | + * ^sp + * To perform a tail call, the arguments that need be passed on the stack + * should overwrite the ``| ccf | ff |'' part and the stack pointer + * should be adjusted accordingly. However, to compute the new arguments, some of + * the values in ``| ccf | ff |'' may be needed. On the other hand, some of the + * arguments may be positioned on the stack correctly already. + *) + val (spilled_args, (* those arguments that need be passed on the stack *) + spilled_res, (* those return values that are returned on the stack *) + _) = CallConv.resolve_act_cc RI.args_phreg RI.res_phreg + {args=args,clos=clos,reg_args=reg_args,reg_vec=reg_vec,res=res} + + val size_rcf = length spilled_res + val size_ccf_new = length spilled_args +(* + val _ = if size_ccf_new > 0 then + print ("** JMP to " ^ Labels.pr_label opr ^ " with\n" ^ + "** size_ccf_new = " ^ Int.toString size_ccf_new ^ "\n" ^ + "** size_ccf = " ^ Int.toString size_ccf ^ "\n" ^ + "** size_ff = " ^ Int.toString size_ff ^ "\n") + else () +*) + fun flush_args C = + foldr (fn ((aty,offset),C) => + push_aty(aty,tmp_reg1, size_ff + offset - 1 - size_rcf, C)) C spilled_args + (* We pop in reverse order such that size_ff+offset works, but we must adjust for the + * return label and the return convention frame that we didn't push onto the stack + * because we're dealing with a tail call. *) + + (* After the arguments are pushed onto the stack, we copy them down to + * the current ``| ccf | ff |'', which is now dead. *) + fun copy_down 0 C = C + | copy_down n C = load_indexed(R tmp_reg1, rsp, WORDS (n-1), + store_indexed(rsp, WORDS (size_ff+size_ccf+n-1), R tmp_reg1, + copy_down (n-1) C)) + fun jmp C = I.jmp(L(MLFunLab opr)) :: rem_dead_code C + in + flush_args + (copy_down size_ccf_new + (base_plus_offset(rsp,WORDS(size_ff+size_ccf),rsp, + jmp C))) + end) + | LS.FUNCALL{opr,args,reg_vec,reg_args,clos,res,bv} => + comment_fn (fn () => "FUNCALL: " ^ pr_ls ls, + let + val (spilled_args,spilled_res,_) = + CallConv.resolve_act_cc RI.args_phreg RI.res_phreg {args=args,clos=clos,reg_args=reg_args, + reg_vec=reg_vec,res=res} + val size_rcf = List.length spilled_res + val return_lab = new_local_lab "return_from_app" + fun flush_args C = + foldr (fn ((aty,offset),C) => push_aty(aty,tmp_reg1,size_ff+offset,C)) C (spilled_args) + (* We pop in reverse order such that size_ff+offset works *) + fun fetch_res C = + foldr (fn ((aty,offset),C) => pop_aty(aty,tmp_reg1,size_ff+offset,C)) C (rev spilled_res) + fun jmp C = I.jmp(L(MLFunLab opr)) :: C + in + base_plus_offset(rsp,WORDS(~size_rcf),rsp, (* Move rsp after rcf *) + I.push(LA return_lab) :: (* Push Return Label *) + flush_args(jmp(gen_bv(bv, I.lab return_lab :: fetch_res C)))) + end) + | LS.LETREGION{rhos,body} => + comment ("LETREGION", + let + fun key place = mkIntAty (Effect.key_of_eps_or_rho place) + + fun maybe_store_tag (place,offset,C) = + if values_in_region_untagged place then + let val tag = + case Effect.get_place_ty place of + SOME Effect.PAIR_RT => BI.tag_record (false,2) + | SOME Effect.REF_RT => BI.tag_ref(false) + | SOME Effect.TRIPLE_RT => BI.tag_record (false,3) + | _ => die "maybe_store_tag" + in store_immed(tag, rsp, WORDS(size_ff-offset-1), C) + end + else C + + fun alloc_region_prim(((place,phsize),offset),C) = + if region_profiling() then + case phsize + of LineStmt.WORDS 0 => C (* zero-sized finite region *) + | LineStmt.WORDS i => (* finite region *) + let (* The offset points at the object - not the region descriptor, + * nor the object descriptor; allocRegionFiniteProfiling expects + * a pointer to the region descriptor. See CalcOffset.sml for a + * picture. The size i of the region does not include the sizes + * of the object descriptor and the region descriptor. *) + val reg_offset = offset + BI.objectDescSizeP + BI.finiteRegionDescSizeP + in + base_plus_offset(rsp,WORDS(size_ff-reg_offset-1),tmp_reg1, + compile_c_call_prim("allocRegionFiniteProfilingMaybeUnTag", + [SS.PHREG_ATY tmp_reg1, + key place, + mkIntAty i], NONE, + size_ff,tmp_reg0(*not used*), + maybe_store_tag (place,offset,C))) + end + | LineStmt.INF => + let val name = + if regions_holding_values_of_the_same_type_only place then + case Effect.get_place_ty place of + SOME Effect.PAIR_RT => "allocPairRegionInfiniteProfilingMaybeUnTag" + | SOME Effect.REF_RT => "allocRefRegionInfiniteProfilingMaybeUnTag" + | SOME Effect.TRIPLE_RT => "allocTripleRegionInfiniteProfilingMaybeUnTag" + | SOME Effect.ARRAY_RT => "allocArrayRegionInfiniteProfilingMaybeUnTag" + | _ => die "alloc_region_prim.name" + else "allocRegionInfiniteProfilingMaybeUnTag" + in + base_plus_offset(rsp,WORDS(size_ff-offset-1),tmp_reg1, + compile_c_call_prim(name, + [SS.PHREG_ATY tmp_reg1, + key place], NONE, + size_ff,tmp_reg0(*not used*),C)) + end + else + case phsize + of LineStmt.WORDS 0 => C + | LineStmt.WORDS i => + maybe_store_tag (place,offset,C) (* finite region; no code generated *) + | LineStmt.INF => + let val name = + if regions_holding_values_of_the_same_type_only place then + case Effect.get_place_ty place of + SOME Effect.PAIR_RT => "allocatePairRegion" + | SOME Effect.REF_RT => "allocateRefRegion" + | SOME Effect.TRIPLE_RT => "allocateTripleRegion" + | SOME Effect.ARRAY_RT => "allocateArrayRegion" + | _ => die "alloc_region_prim.name2" + else "allocateRegion" + in + base_plus_offset(rsp,WORDS(size_ff-offset-1),tmp_reg1, + compile_c_call_prim(name,[SS.PHREG_ATY tmp_reg1],NONE, + size_ff,tmp_reg0(*not used*),C)) + end + fun dealloc_region_prim (((place,phsize),offset),C) = + if region_profiling() then + case phsize + of LineStmt.WORDS 0 => C + | LineStmt.WORDS i => + compile_c_call_prim("deallocRegionFiniteProfiling",[],NONE, + size_ff,tmp_reg0(*not used*),C) + | LineStmt.INF => + compile_c_call_prim("deallocateRegion",[],NONE,size_ff,tmp_reg0(*not used*),C) + else + case phsize + of LineStmt.WORDS i => C + | LineStmt.INF => + compile_c_call_prim("deallocateRegion",[],NONE,size_ff,tmp_reg0(*not used*),C) + in + foldr alloc_region_prim + (CG_lss(body,size_ff,size_ccf, + foldl dealloc_region_prim C rhos)) rhos + end ) + | LS.SCOPE{pat,scope} => CG_lss(scope,size_ff,size_ccf,C) + | LS.HANDLE{default,handl=(handl,handl_lv),handl_return=(handl_return,handl_return_aty,bv),offset} => + (* An exception handler in an activation record starting at address offset contains the following fields: *) + (* sp[offset] = label for handl_return code. *) + (* sp[offset+1] = pointer to handle closure. *) + (* sp[offset+2] = pointer to previous exception handler used when updating exnPtr. *) + (* sp[offset+3] = address of the first cell after the activation record used when resetting sp. *) + (* Note that we call deallocate_regions_until to the address above the exception handler, (i.e., some of *) + (* the infinite regions inside the activation record are also deallocated)! *) + let + val handl_return_lab = new_local_lab "handl_return" + val handl_join_lab = new_local_lab "handl_join" + fun handl_code C = comment ("HANDL_CODE", CG_lss(handl,size_ff,size_ccf,C)) + fun store_handl_lv C = + comment ("STORE HANDLE_LV: sp[offset+1] = handl_lv", + store_aty_in_reg_record(handl_lv,tmp_reg1,rsp,WORDS(size_ff-offset-1+1),size_ff,C)) + fun store_handl_return_lab C = + comment ("STORE HANDL RETURN LAB: sp[offset] = handl_return_lab", + I.movq(LA handl_return_lab, R tmp_reg1) :: + store_indexed(rsp,WORDS(size_ff-offset-1), R tmp_reg1,C)) + fun store_exn_ptr C = + comment ("STORE EXN PTR: sp[offset+2] = exnPtr", + I.movq(L exn_ptr_lab, R tmp_reg1) :: + store_indexed(rsp,WORDS(size_ff-offset-1+2), R tmp_reg1, + comment ("CALC NEW exnPtr: exnPtr = sp-size_ff+offset+size_of_handle", + base_plus_offset(rsp,WORDS(size_ff-offset-1(*-BI.size_of_handle()*)),tmp_reg1, (*hmmm *) + I.movq(R tmp_reg1, L exn_ptr_lab) :: C)))) + fun store_sp C = + comment ("STORE SP: sp[offset+3] = sp", + store_indexed(rsp,WORDS(size_ff-offset-1+3), R rsp,C)) + fun default_code C = comment ("HANDLER DEFAULT CODE", + CG_lss(default,size_ff,size_ccf,C)) + fun restore_exp_ptr C = + comment ("RESTORE EXN PTR: exnPtr = sp[offset+2]", + load_indexed(R tmp_reg1,rsp,WORDS(size_ff-offset-1+2), + I.movq(R tmp_reg1, L exn_ptr_lab) :: + I.jmp(L handl_join_lab) ::C)) + fun handl_return_code C = + let val res_reg = RI.lv_to_reg(CallConv.handl_return_phreg RI.res_phreg) + in comment ("HANDL RETURN CODE: handl_return_aty = res_phreg", + gen_bv(bv, + I.lab handl_return_lab :: + move_aty_to_aty(SS.PHREG_ATY res_reg,handl_return_aty,size_ff, + CG_lss(handl_return,size_ff,size_ccf, + I.lab handl_join_lab :: C)))) + end + in + comment ("START OF EXCEPTION HANDLER", + handl_code( + store_handl_lv( + store_handl_return_lab( + store_exn_ptr( + store_sp( + default_code( + restore_exp_ptr( + handl_return_code(comment ("END OF EXCEPTION HANDLER", C)))))))))) + end + | LS.RAISE{arg=arg_aty,defined_atys} => + move_aty_into_reg(arg_aty,rdi,size_ff, (* function never returns *) + maybe_align 0 (fn C => I.call (NameLab "raise_exn") :: rem_dead_code C) C) + | LS.SWITCH_I{switch=LS.SWITCH(SS.FLOW_VAR_ATY(lv,lab_t,lab_f),[(sel_val,lss)],default), + precision} => + let + val (t_lab,f_lab) = if sel_val = Int32.fromInt BI.ml_true then (lab_t,lab_f) else (lab_f,lab_t) + val lab_exit = new_local_lab "lab_exit" + in + I.lab(LocalLab t_lab) :: + CG_lss(lss,size_ff,size_ccf, + I.jmp(L lab_exit) :: + I.lab(LocalLab f_lab) :: + CG_lss(default,size_ff,size_ccf, + I.lab(lab_exit) :: C)) + end + | LS.SWITCH_I {switch=LS.SWITCH(opr_aty,sels,default), precision} => + compileNumSwitch {size_ff=size_ff, + size_ccf=size_ccf, + CG_lss=CG_lss, + toInt=fn i => maybeTagInt{value=i, precision=precision}, + opr_aty=opr_aty, + oprBoxed=boxedNum precision, + sels=sels, + default=default, + C=C} + | LS.SWITCH_W {switch=LS.SWITCH(opr_aty,sels,default), precision} => + compileNumSwitch {size_ff=size_ff, + size_ccf=size_ccf, + CG_lss=CG_lss, + toInt=fn w => Int32.fromLarge(Word32.toLargeIntX (maybeTagWord{value=w, precision=precision})), + opr_aty=opr_aty, + oprBoxed=boxedNum precision, + sels=sels, + default=default, + C=C} + | LS.SWITCH_S sw => die "SWITCH_S is unfolded in ClosExp" + | LS.SWITCH_C(LS.SWITCH(SS.FLOW_VAR_ATY(lv,lab_t,lab_f),[((con,con_kind),lss)],default)) => + let + val (t_lab,f_lab) = if Con.eq(con,Con.con_TRUE) then (lab_t,lab_f) else (lab_f,lab_t) + val lab_exit = new_local_lab "lab_exit" + in + I.lab(LocalLab t_lab) :: + CG_lss(lss,size_ff,size_ccf, + I.jmp(L lab_exit) :: + I.lab(LocalLab f_lab) :: + CG_lss(default,size_ff,size_ccf, + I.lab lab_exit :: C)) + end + | LS.SWITCH_C(LS.SWITCH(opr_aty,[],default)) => CG_lss(default,size_ff,size_ccf,C) + | LS.SWITCH_C(LS.SWITCH(opr_aty,sels,default)) => + let (* NOTE: selectors in sels are tagged in ClosExp; values are + * tagged here in CodeGenX64! *) + val con_kind = case sels + of [] => die ("CG_ls: SWITCH_C sels is empty: " ^ (pr_ls ls)) + | ((con,con_kind),_)::rest => con_kind + val sels' = map (fn ((con,con_kind),sel_insts) => + case con_kind + of LS.ENUM i => (Int32.fromInt i,sel_insts) + | LS.UNBOXED i => (Int32.fromInt i,sel_insts) + | LS.BOXED i => (Int32.fromInt i,sel_insts)) sels + fun UbTagCon(src_aty,C) = + let val cont_lab = new_local_lab "cont" + in move_aty_into_reg(src_aty,tmp_reg0,size_ff, + copy(tmp_reg0, tmp_reg1, (* operand is in tmp_reg1, see SWITCH_I *) + I.andq(I "3", R tmp_reg1) :: + I.cmpq(I "3", R tmp_reg1) :: (* do copy if tr = 3; in that case we *) + I.jne cont_lab :: (* are dealing with a nullary constructor, *) + copy(tmp_reg0, tmp_reg1, (* and all bits are used. *) + I.lab cont_lab :: C))) + end + val (F, opr_aty) = + case con_kind + of LS.ENUM _ => (fn C => C, opr_aty) + | LS.UNBOXED _ => (fn C => UbTagCon(opr_aty,C), SS.PHREG_ATY tmp_reg1) + | LS.BOXED _ => + (fn C => move_index_aty_to_aty(opr_aty,SS.PHREG_ATY tmp_reg1, + WORDS 0,tmp_reg1,size_ff,C), + SS.PHREG_ATY tmp_reg1) + in + F (compileNumSwitch {size_ff=size_ff, + size_ccf=size_ccf, + CG_lss=CG_lss, + toInt=fn i => i, (* tagging already done in ClosExp *) + opr_aty=opr_aty, + oprBoxed=false, + sels=sels', + default=default, + C=C}) + end + | LS.SWITCH_E sw => die "SWITCH_E is unfolded in ClosExp" + | LS.RESET_REGIONS{force=false,regions_for_resetting} => + comment ("RESET_REGIONS(no force)", + foldr (fn (alloc,C) => maybe_reset_aux_region_kill_tmp0(alloc,tmp_reg1,size_ff,C)) C regions_for_resetting) + | LS.RESET_REGIONS{force=true,regions_for_resetting} => + comment ("RESET_REGIONS(force)", + foldr (fn (alloc,C) => force_reset_aux_region_kill_tmp0(alloc,tmp_reg1,size_ff,C)) C regions_for_resetting) + | LS.PRIM{name,args,res=[SS.FLOW_VAR_ATY(lv,lab_t,lab_f)]} => + comment_fn (fn () => "PRIM FLOW: " ^ pr_ls ls, + let val (lab_t,lab_f) = (LocalLab lab_t,LocalLab lab_f) + fun cmp(i,x,y) = cmpi_and_jmp_kill_tmp01(i,x,y,lab_t,lab_f,size_ff,C) + fun cmp_boxed(i,x,y) = cmpbi_and_jmp_kill_tmp01(i,x,y,lab_t,lab_f,size_ff,C) + in case (name,args) + of ("__equal_int32ub",[x,y]) => cmp(I.je,x,y) + | ("__equal_int32b",[x,y]) => cmp_boxed(I.je,x,y) + | ("__equal_int31",[x,y]) => cmp(I.je,x,y) + | ("__equal_word31",[x,y]) => cmp(I.je,x,y) + | ("__equal_word32ub",[x,y]) => cmp(I.je,x,y) + | ("__equal_word32b",[x,y]) => cmp_boxed(I.je,x,y) + | ("__less_int32ub",[x,y]) => cmp(I.jl,x,y) + | ("__less_int32b",[x,y]) => cmp_boxed(I.jl,x,y) + | ("__less_int31",[x,y]) => cmp(I.jl,x,y) + | ("__less_word31",[x,y]) => cmp(I.jb,x,y) + | ("__less_word32ub",[x,y]) => cmp(I.jb,x,y) + | ("__less_word32b",[x,y]) => cmp_boxed(I.jb,x,y) + | ("__lesseq_int32ub",[x,y]) => cmp(I.jle,x,y) + | ("__lesseq_int32b",[x,y]) => cmp_boxed(I.jle,x,y) + | ("__lesseq_int31",[x,y]) => cmp(I.jle,x,y) + | ("__lesseq_word31",[x,y]) => cmp(I.jbe,x,y) + | ("__lesseq_word32ub",[x,y]) => cmp(I.jbe,x,y) + | ("__lesseq_word32b",[x,y]) => cmp_boxed(I.jbe,x,y) + | ("__greater_int32ub",[x,y]) => cmp(I.jg,x,y) + | ("__greater_int32b",[x,y]) => cmp_boxed(I.jg,x,y) + | ("__greater_int31",[x,y]) => cmp(I.jg,x,y) + | ("__greater_word31",[x,y]) => cmp(I.ja,x,y) + | ("__greater_word32ub",[x,y]) => cmp(I.ja,x,y) + | ("__greater_word32b",[x,y]) => cmp_boxed(I.ja,x,y) + | ("__greatereq_int32ub",[x,y]) => cmp(I.jge,x,y) + | ("__greatereq_int32b",[x,y]) => cmp_boxed(I.jge,x,y) + | ("__greatereq_int31",[x,y]) => cmp(I.jge,x,y) + | ("__greatereq_word31",[x,y]) => cmp(I.jae,x,y) + | ("__greatereq_word32ub",[x,y]) => cmp(I.jae,x,y) + | ("__greatereq_word32b",[x,y]) => cmp_boxed(I.jae,x,y) + | _ => die "CG_ls: Unknown PRIM used on Flow Variable" + end) + | LS.PRIM{name,args,res} => + let + in + comment_fn (fn () => "PRIM: " ^ pr_ls ls, + (* Note that the prim names are defined in BackendInfo! *) + (case (name,args,case res of nil => [SS.UNIT_ATY] | _ => res) + of ("__equal_int32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.je,x,y,d,size_ff,C) + | ("__equal_int32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.je,x,y,d,size_ff,C) + | ("__equal_int31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.je,x,y,d,size_ff,C) + | ("__equal_word31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.je,x,y,d,size_ff,C) + | ("__equal_word32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.je,x,y,d,size_ff,C) + | ("__equal_word32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.je,x,y,d,size_ff,C) + + | ("__plus_int32ub",[x,y],[d]) => add_num_kill_tmp01 {ovf=true,tag=false} (x,y,d,size_ff,C) + | ("__plus_int32b",[b,x,y],[d]) => add_int32b (b,x,y,d,size_ff,C) + | ("__plus_int31",[x,y],[d]) => add_num_kill_tmp01 {ovf=true,tag=true} (x,y,d,size_ff,C) + | ("__plus_word31",[x,y],[d]) => add_num_kill_tmp01 {ovf=false,tag=true} (x,y,d,size_ff,C) + | ("__plus_word32ub",[x,y],[d]) => add_num_kill_tmp01 {ovf=false,tag=false} (x,y,d,size_ff,C) + | ("__plus_word32b",[b,x,y],[d]) => addw32boxed(b,x,y,d,size_ff,C) + | ("__plus_real",[b,x,y],[d]) => addf_kill_tmp01(x,y,b,d,size_ff,C) + + | ("__minus_int32ub",[x,y],[d]) => sub_num_kill_tmp01 {ovf=true,tag=false} (x,y,d,size_ff,C) + | ("__minus_int32b",[b,x,y],[d]) => sub_int32b (b,x,y,d,size_ff,C) + | ("__minus_int31",[x,y],[d]) => sub_num_kill_tmp01 {ovf=true,tag=true} (x,y,d,size_ff,C) + | ("__minus_word31",[x,y],[d]) => sub_num_kill_tmp01 {ovf=false,tag=true} (x,y,d,size_ff,C) + | ("__minus_word32ub",[x,y],[d]) => sub_num_kill_tmp01 {ovf=false,tag=false} (x,y,d,size_ff,C) + | ("__minus_word32b",[b,x,y],[d]) => subw32boxed(b,x,y,d,size_ff,C) + | ("__minus_real",[b,x,y],[d]) => subf_kill_tmp01(x,y,b,d,size_ff,C) + + | ("__mul_int32ub", [x,y], [d]) => mul_num_kill_tmp01 {ovf=true,tag=false} (x,y,d,size_ff,C) + | ("__mul_int32b", [b,x,y], [d]) => mul_int32b (b,x,y,d,size_ff,C) + | ("__mul_int31", [x,y], [d]) => mul_num_kill_tmp01 {ovf=true,tag=true} (x,y,d,size_ff,C) + | ("__mul_word31", [x,y], [d]) => mul_num_kill_tmp01 {ovf=false,tag=true} (x,y,d,size_ff,C) + | ("__mul_word32ub", [x,y], [d]) => mul_num_kill_tmp01 {ovf=false,tag=false} (x,y,d,size_ff,C) + | ("__mul_word32b", [b,x,y], [d]) => mulw32boxed(b,x,y,d,size_ff,C) + | ("__mul_real",[b,x,y],[d]) => mulf_kill_tmp01(x,y,b,d,size_ff,C) + + | ("__div_real", [b,x,y],[d]) => divf_kill_tmp01(x,y,b,d,size_ff,C) + + | ("__neg_int32ub",[x],[d]) => neg_int_kill_tmp0 {tag=false} (x,d,size_ff,C) + | ("__neg_int32b",[b,x],[d]) => neg_int32b_kill_tmp0 (b,x,d,size_ff,C) + | ("__neg_int31",[x],[d]) => neg_int_kill_tmp0 {tag=true} (x,d,size_ff,C) + | ("__neg_real",[b,x],[d]) => negf_kill_tmp01(b,x,d,size_ff,C) + + | ("__abs_int32ub",[x],[d]) => abs_int_kill_tmp0 {tag=false} (x,d,size_ff,C) + | ("__abs_int32b",[b,x],[d]) => abs_int32b_kill_tmp0 (b,x,d,size_ff,C) + | ("__abs_int31",[x],[d]) => abs_int_kill_tmp0 {tag=true} (x,d,size_ff,C) + | ("__abs_real",[b,x],[d]) => absf_kill_tmp01(b,x,d,size_ff,C) + + | ("__less_int32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jl,x,y,d,size_ff,C) + | ("__less_int32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.jl,x,y,d,size_ff,C) + | ("__less_int31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jl,x,y,d,size_ff,C) + | ("__less_word31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jb,x,y,d,size_ff,C) + | ("__less_word32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jb,x,y,d,size_ff,C) + | ("__less_word32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.jb,x,y,d,size_ff,C) + | ("__less_real",[x,y],[d]) => cmpf_kill_tmp01(LESSTHAN,x,y,d,size_ff,C) + + | ("__lesseq_int32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jle,x,y,d,size_ff,C) + | ("__lesseq_int32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.jle,x,y,d,size_ff,C) + | ("__lesseq_int31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jle,x,y,d,size_ff,C) + | ("__lesseq_word31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jbe,x,y,d,size_ff,C) + | ("__lesseq_word32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jbe,x,y,d,size_ff,C) + | ("__lesseq_word32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.jbe,x,y,d,size_ff,C) + | ("__lesseq_real",[x,y],[d]) => cmpf_kill_tmp01(LESSEQUAL,x,y,d,size_ff,C) + + | ("__greater_int32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jg,x,y,d,size_ff,C) + | ("__greater_int32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.jg,x,y,d,size_ff,C) + | ("__greater_int31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jg,x,y,d,size_ff,C) + | ("__greater_word31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.ja,x,y,d,size_ff,C) + | ("__greater_word32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.ja,x,y,d,size_ff,C) + | ("__greater_word32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.ja,x,y,d,size_ff,C) + | ("__greater_real",[x,y],[d]) => cmpf_kill_tmp01(GREATERTHAN,x,y,d,size_ff,C) + + | ("__greatereq_int32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jge,x,y,d,size_ff,C) + | ("__greatereq_int32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.jge,x,y,d,size_ff,C) + | ("__greatereq_int31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jge,x,y,d,size_ff,C) + | ("__greatereq_word31",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jae,x,y,d,size_ff,C) + | ("__greatereq_word32ub",[x,y],[d]) => cmpi_kill_tmp01 {box=false} (I.jae,x,y,d,size_ff,C) + | ("__greatereq_word32b",[x,y],[d]) => cmpi_kill_tmp01 {box=true} (I.jae,x,y,d,size_ff,C) + | ("__greatereq_real",[x,y],[d]) => cmpf_kill_tmp01(GREATEREQUAL,x,y,d,size_ff,C) + + | ("__andb_word31",[x,y],[d]) => andb_word_kill_tmp01(x,y,d,size_ff,C) + | ("__andb_word32ub",[x,y],[d]) => andb_word_kill_tmp01(x,y,d,size_ff,C) + | ("__andb_word32b",[b,x,y],[d]) => andw32boxed__(b,x,y,d,size_ff,C) + + | ("__orb_word31",[x,y],[d]) => orb_word_kill_tmp01(x,y,d,size_ff,C) + | ("__orb_word32ub",[x,y],[d]) => orb_word_kill_tmp01(x,y,d,size_ff,C) + | ("__orb_word32b",[b,x,y],[d]) => orw32boxed__(b,x,y,d,size_ff,C) + + | ("__xorb_word31",[x,y],[d]) => xorb_word_kill_tmp01 {tag=true} (x,y,d,size_ff,C) + | ("__xorb_word32ub",[x,y],[d]) => xorb_word_kill_tmp01 {tag=false} (x,y,d,size_ff,C) + | ("__xorb_word32b",[b,x,y],[d]) => xorw32boxed__(b,x,y,d,size_ff,C) + + | ("__shift_left_word31",[x,y],[d]) => shift_left_word_kill_tmp01 {tag=true} (x,y,d,size_ff,C) + | ("__shift_left_word32ub",[x,y],[d]) => shift_left_word_kill_tmp01 {tag=false} (x,y,d,size_ff,C) + | ("__shift_left_word32b",[b,x,y],[d]) => shift_leftw32boxed__(b,x,y,d,size_ff,C) + + | ("__shift_right_signed_word31",[x,y],[d]) => + shift_right_signed_word_kill_tmp01 {tag=true} (x,y,d,size_ff,C) + | ("__shift_right_signed_word32ub",[x,y],[d]) => + shift_right_signed_word_kill_tmp01 {tag=false} (x,y,d,size_ff,C) + | ("__shift_right_signed_word32b",[b,x,y],[d]) => + shift_right_signedw32boxed__(b,x,y,d,size_ff,C) + + | ("__shift_right_unsigned_word31",[x,y],[d]) => + shift_right_unsigned_word_kill_tmp01 {tag=true} (x,y,d,size_ff,C) + | ("__shift_right_unsigned_word32ub",[x,y],[d]) => + shift_right_unsigned_word_kill_tmp01 {tag=false} (x,y,d,size_ff,C) + | ("__shift_right_unsigned_word32b",[b,x,y],[d]) => + shift_right_unsignedw32boxed__(b,x,y,d,size_ff,C) + + | ("__int31_to_int32b",[b,x],[d]) => num31_to_num32b(b,x,d,size_ff,C) + | ("__int31_to_int32ub",[x],[d]) => num31_to_num32ub(x,d,size_ff,C) + | ("__int32b_to_int31",[x],[d]) => int32_to_int31 {boxedarg=true} (x,d,size_ff,C) + | ("__int32ub_to_int31",[x],[d]) => int32_to_int31 {boxedarg=false} (x,d,size_ff,C) + + | ("__word31_to_word32b",[b,x],[d]) => num31_to_num32b(b,x,d,size_ff,C) + | ("__word31_to_word32ub",[x],[d]) => num31_to_num32ub(x,d,size_ff,C) + | ("__word32b_to_word31",[x],[d]) => word32_to_word31 {boxedarg=true} (x,d,size_ff,C) + | ("__word32ub_to_word31",[x],[d]) => word32_to_word31 {boxedarg=false} (x,d,size_ff,C) + + | ("__word31_to_word32ub_X",[x],[d]) => num31_to_num32ub(x,d,size_ff,C) + | ("__word31_to_word32b_X",[b,x],[d]) => num31_to_num32b(b,x,d,size_ff,C) + + | ("__word32b_to_int32b",[b,x],[d]) => num32b_to_num32b {ovf=true} (b,x,d,size_ff,C) + | ("__word32b_to_int32b_X",[b,x],[d]) => num32b_to_num32b {ovf=false} (b,x,d,size_ff,C) + | ("__int32b_to_word32b",[b,x],[d]) => num32b_to_num32b {ovf=false} (b,x,d,size_ff,C) + | ("__word32ub_to_int32ub",[x],[d]) => word32ub_to_int32ub(x,d,size_ff,C) + | ("__word32b_to_int31",[x],[d]) => word32_to_int31 {boxedarg=true,ovf=true} (x,d,size_ff,C) + | ("__int32b_to_word31",[x],[d]) => word32_to_word31 {boxedarg=true} (x,d,size_ff,C) + | ("__word32b_to_int31_X", [x],[d]) => word32_to_int31 {boxedarg=true,ovf=false} (x,d,size_ff,C) + + | ("__fresh_exname",[],[aty]) => + I.movq(L exn_counter_lab, R tmp_reg0) :: + move_reg_into_aty(tmp_reg0,aty,size_ff, + I.addq(I "1", R tmp_reg0) :: + I.movq(R tmp_reg0, L exn_counter_lab) :: C) + + | ("__bytetable_sub", [t,i], [d]) => bytetable_sub(t,i,d,size_ff,C) + | ("__bytetable_size", [t], [d]) => bytetable_size(t,d,size_ff,C) + | ("__bytetable_update", [t,i,x], [d]) => bytetable_update(t,i,x,d,size_ff,C) + + | ("word_sub0", [t,i], [d]) => word_sub0(t,i,d,size_ff,C) + | ("table_size", [t], [d]) => table_size(t,d,size_ff,C) + | ("word_update0", [t,i,x], [d]) => word_update0(t,i,x,d,size_ff,C) + + | ("__is_null", [t], [d]) => + cmpi_kill_tmp01 {box=false} (I.je,t, SS.INTEGER_ATY{value=Int32.fromInt 0, + precision=32},d,size_ff,C) + | _ => die ("PRIM(" ^ name ^ ") not implemented"))) + end + | LS.CCALL{name,args,rhos_for_result,res} => + let + fun comp_c_call(all_args,res,C) = + compile_c_call_prim(name, all_args, res, size_ff, tmp_reg1, C) + val _ = + if BI.is_prim name then + die ("CCALL." ^ name ^ " is meant to be a primitive inlined by the compiler " ^ + "- but it is not dealt with!") + else () + val _ = + case (explode name, rhos_for_result) + of (_, nil) => () + | (#"@" :: _, _) => + die ("CCALL." ^ name ^ ": auto-convertion is supported only for\n" ^ + "functions returning integers and taking integers as arguments!\n" ^ + "The function " ^ name ^ " takes " ^ Int.toString (length rhos_for_result) ^ + "region arguments.") + | _ => () + in + + (* the first argument in a dynamic function call, is the name of the function, *) + (* that argument must be on the top of the stack, as it is poped just before *) + (* function invocation. *) + (* It is used to bind an address the first time the function is called *) + + comment_fn (fn () => "CCALL: " ^ pr_ls ls, + (case (case name of ":" => (let val (a1,ar) = valOf (List.getItem args) + in a1 ::(rhos_for_result@ar) + end + handle Option.Option => + die ("Dynamic liking requires a string as first argument.")) + | _ => (rhos_for_result@args), res) + of (all_args,[]) => comp_c_call(all_args, NONE, C) + | (all_args, [res_aty]) => comp_c_call(all_args, SOME res_aty, C) + | _ => die "CCall with more than one result variable")) + end + | LS.CCALL_AUTO{name, args, res} => + let + (*val () = print ("CCALL_AUTO: " ^ name ^ "\n")*) + val _ = + if BI.is_prim name then + die ("CCALL_AUTO." ^ name ^ " is meant to be a primitive inlined by the compiler " ^ + "- but it is not dealt with!") + else () + in + + (* With dynamicly linked functions the first argument must be the name of *) + (* the function. If we where to implement automatic conversion into regions *) + (* this must be taken care of, like in the non-automatic case *) + + comment_fn (fn () => "CCALL_AUTO: " ^ pr_ls ls, + compile_c_call_auto(name,args,res,size_ff,tmp_reg1,C)) + end + | LS.EXPORT{name, + clos_lab, + arg=(aty,ft1,ft2)} => + let val clos_lab = DatLab clos_lab + (*val clos_lab = NameLab (name ^ "_clos")*) + val return_lab = new_local_lab ("return_" ^ name) + val offset_codeptr = if BI.tag_values() then "8" else "0" + val lab = NameLab name (* lab is the C function to call after the hook has been setup *) + val stringlab = gen_string_lab name + val _ = + if ft1 <> LS.Int orelse ft2 <> LS.Int then + die "Export of ML function with type other than (int->int) not supported" + else () + + val _ = add_static_data + ([I.dot_data, + I.dot_align 8, + I.dot_globl clos_lab, + I.lab clos_lab, (* Slot for storing a pointer to the ML closure; the + * ML closure object may move due to GCs. *) + I.dot_quad (i2s BI.ml_unit), + I.dot_text, + I.dot_globl lab, (* The C function entry *) + I.lab lab] + @ (map (fn r => I.push (R r)) callee_save_regs_ccall) + @ [I.movq (L clos_lab, R rax), (* load closure into ML arg 1 *) + I.movq (R rdi, R rbx), (* move C arg into ML arg 2 *) + I.movq(D(offset_codeptr,rax), R r10), (* extract code pointer into %r10 *) + I.push (I "1"), (* push dummy *) + I.push (LA return_lab), (* push return address *) + I.jmp (R r10), (* call ML function *) + I.lab return_lab, + I.movq(R rdi, R rax), (* move result to %rax *) + I.addq(I "8", R rsp)] (* pop dummy *) + @ (map (fn r => I.pop (R r)) (List.rev callee_save_regs_ccall)) + @ [I.ret]) + + val saveregs = rdi :: rsi :: rdx :: rcx :: r8 :: r9 :: rax :: + caller_save_regs_ccall + fun push_callersave_regs C = + foldl (fn (r, C) => I.push(R r) :: C) C saveregs + fun pop_callersave_regs C = + foldr (fn (r, C) => I.pop(R r) :: C) C saveregs + + in comment_fn (fn () => "EXPORT: " ^ pr_ls ls, + store_in_label(aty,clos_lab,tmp_reg1,size_ff, + I.movq (LA lab, R tmp_reg0) :: + I.movq (LA stringlab, R tmp_reg1) :: + push_callersave_regs + (compile_c_call_prim("sml_regCfuns",[SS.PHREG_ATY tmp_reg1, + SS.PHREG_ATY tmp_reg0],NONE,0, tmp_reg1, + pop_callersave_regs C)))) + end + ) + in + foldr (fn (ls,C) => CG_ls(ls,C)) C lss + end + + fun do_simple_memprof C = + if simple_memprof_p() andalso gc_p() then + let val labCont = new_local_lab "cont" + in I.cmpq(R rsp, L stack_min) :: + I.jl labCont :: + I.movq(R rsp, L stack_min) :: + I.lab labCont :: + C + end + else C + + fun do_prof C = + if region_profiling() then + let val labStack = new_local_lab "profStack" + val labCont = new_local_lab "profCont" + val labCont2 = new_local_lab "profCont2-" + val maxStackLab = NameLab "maxStack" + val timeToProfLab = NameLab "timeToProfile" + in I.movq(L maxStackLab, R tmp_reg0) :: (* The stack grows downwards!! *) + I.cmpq(R rsp, R tmp_reg0) :: + I.jl labCont :: (* if ( rsp < *maxStack ) { *) + I.movq(R rsp, L maxStackLab) :: (* *maxStack = rsp ; *) + I.movq(L (NameLab "regionDescUseProfInf"), R tmp_reg0) :: (* maxProfStack = *) + I.addq(L (NameLab "regionDescUseProfFin"), R tmp_reg0) :: (* regionDescUseProfInf *) + I.addq(L (NameLab "allocProfNowFin"), R tmp_reg0) :: (* + regionDescUseProfFin *) + I.movq(R tmp_reg0, L (NameLab "maxProfStack")) :: (* + allocProfNowFin ; *) + I.lab labCont :: (* } *) + I.movq(L timeToProfLab, R tmp_reg0) :: (* if ( timeToProfile ) *) + I.cmpq(I "0", R tmp_reg0) :: (* call __proftick(rsp); *) + I.je labCont2 :: + I.movq (R rsp, R tmp_reg1) :: (* proftick assumes argument in tmp_reg1 *) + I.push (LA labCont2) :: (* push return address *) + I.jmp (L(NameLab "__proftick")) :: + I.lab labCont2 :: + C + end + else C + + fun CG_top_decl' gen_fn (lab,cc,lss) = + let + val w0 = Word32.fromInt 0 + fun pw w = print ("Word is " ^ (Word32.fmt StringCvt.BIN w) ^ "\n") + fun pws ws = app pw ws + fun set_bit(bit_no,w) = Word32.orb(w,Word32.<<(Word32.fromInt 1,Word.fromInt bit_no)) + + val size_ff = CallConv.get_frame_size cc + val size_ccf = CallConv.get_ccf_size cc + val size_rcf = CallConv.get_rcf_size cc +(*val _ = if size_ccf + size_rcf > 0 then die ("\ndo_gc: size_ccf: " ^ (Int.toString size_ccf) ^ " and size_rcf: " ^ + (Int.toString size_rcf) ^ ".") else () (* 2001-01-08, Niels debug *)*) + val C = base_plus_offset(rsp,WORDS(size_ff+size_ccf),rsp, + I.pop (R tmp_reg1) :: + I.jmp (R tmp_reg1) :: []) + val size_spilled_region_args = List.length (CallConv.get_spilled_region_args cc) + val reg_args = map lv_to_reg_no (CallConv.get_register_args_excluding_region_args cc) + val reg_map = foldl (fn (reg_no,w) => set_bit(reg_no,w)) w0 reg_args + (* + val _ = app (fn reg_no => print ("reg_no " ^ Int.toString reg_no ^ " is an argument\n")) reg_args + val _ = pw reg_map + *) + in + gen_fn(lab, + do_gc(reg_map,size_ccf,size_rcf,size_spilled_region_args, + base_plus_offset(rsp,WORDS(~size_ff),rsp, + do_simple_memprof( + do_prof( + CG_lss(lss,size_ff,size_ccf,C)))))) + end + + fun CG_top_decl(LS.FUN(lab,cc,lss)) = CG_top_decl' I.FUN (lab,cc,lss) + | CG_top_decl(LS.FN(lab,cc,lss)) = CG_top_decl' I.FN (lab,cc,lss) + + local + fun data_x_progunit_lab x l = NameLab(Labels.pr_label l ^ "_data_" ^ x) + fun data_x_lab x (l:label, C) = + if gc_p() then + let val lab = data_x_progunit_lab x l + in I.dot_globl lab :: + I.lab lab :: C + end + else C + in + fun data_begin_progunit_lab (MLFunLab l) = data_x_progunit_lab "begin" l + | data_begin_progunit_lab _ = die "data_begin_progunit_lab" + fun data_begin_lab a = data_x_lab "begin" a + fun data_end_progunit_lab (MLFunLab l) = data_x_progunit_lab "end" l + | data_end_progunit_lab _ = die "data_end_progunit_lab" + fun data_end_lab a = data_x_lab "end" a + end + + (***************************************************) + (* Init Code and Static Data for this program unit *) + (***************************************************) + fun static_data(l:label) = + I.dot_data :: + comment ("START OF STATIC DATA AREA", + data_begin_lab (l, + get_static_data (data_end_lab(l, + comment ("END OF STATIC DATA AREA",nil))))) + + fun init_x64_code() = [I.dot_text] + in + fun CG {main_lab:label, + code=ss_prg: (StoreTypeCO,offset,AtySS) LinePrg, + imports:label list * label list, + exports:label list * label list, + safe:bool} = + let + val _ = chat "[X64 Code Generation..." + val _ = reset_static_data() + val _ = reset_label_counter() + val _ = add_static_data (I.dot_data :: map (fn lab => I.dot_globl(MLFunLab lab)) (main_lab::(#1 exports))) + val _ = add_static_data (I.dot_data :: map (fn lab => I.dot_globl(DatLab lab)) (#2 exports)) + val x64_prg = {top_decls = foldr (fn (func,acc) => CG_top_decl func :: acc) [] ss_prg, + init_code = init_x64_code(), + static_data = static_data main_lab} + val _ = chat "]\n" + in + x64_prg + end + + (* ------------------------------------------------------------------------------ *) + (* Generate Link Code for Incremental Compilation *) + (* ------------------------------------------------------------------------------ *) + fun generate_link_code (linkinfos:label list, exports: label list * label list) : I.AsmPrg = + let + val _ = reset_static_data() + val _ = reset_label_counter() + + val lab_exit = NameLab "__lab_exit" + val next_prog_unit = Labels.new_named "next_prog_unit" + val progunit_labs = map MLFunLab linkinfos + val dat_labs = map DatLab (#2 exports) (* Also in the root set 2001-01-09, Niels *) +(* +val _ = print ("There are " ^ (Int.toString (List.length dat_labs)) ^ " data labels in the root set. ") +val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) +*) + + fun slot_for_datlab((_,l),C) = + let fun maybe_dotsize C = + if I.sysname() = "Darwin" then C + else I.dot_size(DatLab l, 8) :: C + in + I.dot_globl (DatLab l) :: + I.dot_data :: + I.dot_align 8 :: + maybe_dotsize (I.lab (DatLab l) :: + I.dot_quad "1" :: C) + end + + fun slots_for_datlabs(l,C) = foldr slot_for_datlab C l + + fun toplevel_handler C = + let + val (clos_lv,arg_lv) = CallConv.handl_arg_phreg RI.args_phreg + val (clos_reg,arg_reg) = (RI.lv_to_reg clos_lv, RI.lv_to_reg arg_lv) + val offset = if BI.tag_values() then 1 else 0 + in + I.lab (NameLab "TopLevelHandlerLab") :: + I.movq (R arg_reg, R tmp_reg0):: + load_indexed(R arg_reg,arg_reg,WORDS offset, + load_indexed(R tmp_reg1,arg_reg, WORDS offset, + load_indexed(R arg_reg,arg_reg,WORDS (offset+1), (* Fetch pointer to exception string *) + compile_c_call_prim("uncaught_exception",[SS.PHREG_ATY arg_reg,SS.PHREG_ATY tmp_reg1, + SS.PHREG_ATY tmp_reg0],NONE,0,tmp_reg1,C)))) + end + + fun store_exported_data_for_gc (labs,C) = + if gc_p() then + let (* Make sure to leave stack 16-byte aligned if required by os *) + val F = if needs_align () andalso length(labs) mod 2 = 0 then + fn C => I.push (I "1") :: C (* align *) + else fn C => C + in F(foldr (fn (l,acc) => I.push(LA l) :: acc) + (I.push (I (i2s (List.length labs))) :: + I.movq(R rsp, L data_lab_ptr_lab) :: C) labs) + end + else C + + + fun raise_insts C = (* expects exception value in register rdi!! *) + let + val (clos_lv,arg_lv) = CallConv.handl_arg_phreg RI.args_phreg + val (clos_reg,arg_reg) = (RI.lv_to_reg clos_lv, RI.lv_to_reg arg_lv) + val offset_codeptr = if BI.tag_values() then "8" else "0" + in + I.dot_globl(NameLab "raise_exn") :: + I.lab (NameLab "raise_exn") :: + I.movq (R rdi, R r15) :: (* move argument to callee-save register *) + comment ("DEALLOCATE REGIONS UNTIL", + I.movq(L exn_ptr_lab, R tmp_reg1) :: + compile_c_call_prim("deallocateRegionsUntil_X64",[SS.PHREG_ATY tmp_reg1],NONE,0,tmp_reg1, + + comment ("RESTORE EXN PTR", + I.movq(L exn_ptr_lab, R tmp_reg1) :: + I.movq(D("16",tmp_reg1), R tmp_reg0) :: (* was:8 *) + I.movq(R tmp_reg0, L exn_ptr_lab) :: + + comment ("INSTALL HANDLER EXN-ARGUMENT", + I.movq(R r15, R arg_reg) :: + + comment ("RESTORE RSP AND PUSH RETURN LAB", + I.movq(D("24", tmp_reg1), R rsp) :: (* Restore sp *) + I.push(D("0", tmp_reg1)) :: (* Push Return Lab *) + + comment ("JUMP TO HANDLE FUNCTION", + I.movq(D("8", tmp_reg1), R clos_reg) :: (* Fetch Closure into Closure Argument Register *) + I.movq(D(offset_codeptr,clos_reg), R tmp_reg0) :: + I.jmp (R tmp_reg0) :: C)))))) + end + + (* primitive exceptions *) + fun setup_primitive_exception((n,exn_string,exn_lab,exn_flush_lab),C) = + let + val string_lab = gen_string_lab exn_string + val _ = + if BI.tag_values() then (* Exception Name and Exception must be tagged. *) + add_static_data [I.dot_data, + I.dot_align 8, + I.dot_globl exn_lab, + I.lab exn_lab, + I.dot_quad(BI.pr_tag_w(BI.tag_exname(true))), + I.dot_quad "0", (*dummy for pointer to next word*) + I.dot_quad(BI.pr_tag_w(BI.tag_excon0(true))), + I.dot_quad(i2s n), + I.dot_quad "0" (*dummy for pointer to string*), + I.dot_data, + I.dot_align 8, + I.dot_globl exn_flush_lab, + I.lab exn_flush_lab, (* The Primitive Exception is Flushed at this Address *) + I.dot_quad "0"] + else + add_static_data [I.dot_data, + I.dot_align 8, + I.dot_globl exn_lab, + I.lab exn_lab, + I.dot_quad "0", (*dummy for pointer to next word*) + I.dot_quad(i2s n), + I.dot_quad "0", (*dummy for pointer to string*) + I.dot_data, + I.dot_align 8, + I.dot_globl exn_flush_lab, + I.lab exn_flush_lab, (* The Primitive Exception is Flushed at this Address *) + I.dot_quad "0"] + in + if BI.tag_values() then + comment ("SETUP PRIM EXN: " ^ exn_string, + load_label_addr(exn_lab,SS.PHREG_ATY tmp_reg0,tmp_reg0,0, + I.movq(R tmp_reg0, R tmp_reg1) :: + I.addq(I "16", R tmp_reg1) :: + I.movq(R tmp_reg1, D("8",tmp_reg0)) :: + load_label_addr(string_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, + I.movq(R tmp_reg1,D("32",tmp_reg0)) :: + load_label_addr(exn_flush_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, (* Now flush the exception *) + I.movq(R tmp_reg0, D("0",tmp_reg1)) :: C)))) + else + comment ("SETUP PRIM EXN: " ^ exn_string, + load_label_addr(exn_lab,SS.PHREG_ATY tmp_reg0,tmp_reg0,0, + I.movq(R tmp_reg0, R tmp_reg1) :: + I.addq(I "8", R tmp_reg1) :: + I.movq(R tmp_reg1,D("0",tmp_reg0)) :: + load_label_addr(string_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, + I.movq(R tmp_reg1,D("16",tmp_reg0)) :: + load_label_addr(exn_flush_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, (* Now flush the exception *) + I.movq(R tmp_reg0,D("0",tmp_reg1)) :: C)))) + end + + val primitive_exceptions = [(0, "Match", NameLab "exn_MATCH", DatLab BI.exn_MATCH_lab), + (1, "Bind", NameLab "exn_BIND", DatLab BI.exn_BIND_lab), + (2, "Overflow", NameLab "exn_OVERFLOW", DatLab BI.exn_OVERFLOW_lab), + (3, "Interrupt", NameLab "exn_INTERRUPT", DatLab BI.exn_INTERRUPT_lab), + (4, "Div", NameLab "exn_DIV", DatLab BI.exn_DIV_lab)] + val initial_exnname_counter = 5 + + fun init_primitive_exception_constructors_code C = + foldl (fn (t,C) => setup_primitive_exception(t,C)) C primitive_exceptions + + val static_data = + slots_for_datlabs(global_region_labs, + I.dot_data :: + I.dot_globl exn_counter_lab :: + I.lab exn_counter_lab :: (* The Global Exception Counter *) + I.dot_quad (i2s initial_exnname_counter) :: + + I.dot_globl exn_ptr_lab :: + I.lab exn_ptr_lab :: (* The Global Exception Pointer *) + I.dot_quad "0" :: nil) + val _ = add_static_data static_data + + (* args can only be tmp_reg0 and tmp_reg1; no arguments + * on the stack; only the return address! Destroys tmp_reg0! *) + fun ccall_stub(stubname, cfunction, args, ret, C) = (* result in tmp_reg1 if ret=true *) + let + val save_regs = rdi :: rsi :: rdx :: rcx :: r8 :: r9 :: rax :: + caller_save_regs_ccall (* maybe also save the other + * ccall argument registers and the + * ccall result register rax *) + + (* Notice that caller_save_regs_ccall is defined as the empty list! *) + + (* The following registers must be preserved as register + allocation may choose to map variables to these + registers: + + X = [rax,rbx,rdi,rdx,rsi] u [rbx,rbp,r12,r13,r14,r15] + = [rax,rbx,rdi,rdx,rsi,rbp,r12,r13,r14,r15] + + Here are the registers that are not saved: + + X \ save_regs = [rbx,rbp,r12,r13,r14,r15] + + These should exactly be the callee-save registers! + *) + + fun push_callersave_regs C = + foldl (fn (r, C) => I.push(R r) :: C) C save_regs + fun pop_callersave_regs C = + foldr (fn (r, C) => I.pop(R r) :: C) C save_regs + val size_ff = 0 (* dummy *) + val stublab = NameLab stubname + val res = if ret then SOME (SS.PHREG_ATY tmp_reg1) else NONE + in + I.dot_text :: + I.dot_globl stublab :: + I.lab stublab :: + push_callersave_regs + (compile_c_call_prim(cfunction, map SS.PHREG_ATY args, res, size_ff, tmp_reg0, + pop_callersave_regs + (I.pop(R tmp_reg0) :: + I.jmp(R tmp_reg0) :: C))) + end + + fun allocate C = (* args in tmp_reg1 and tmp_reg0; result in tmp_reg1. *) + ccall_stub("__allocate", "alloc", [tmp_reg1, tmp_reg0], true, C) + + fun resetregion C = + ccall_stub("__reset_region", "resetRegion", [tmp_reg1], true, C) + + fun proftick C = + if region_profiling() then + ccall_stub("__proftick", "profileTick", [tmp_reg1], false, C) + else C + + fun overflow_stub C = + let val stublab = [(NameLab "__raise_overflow",BI.exn_OVERFLOW_lab), + (NameLab "__raise_div",BI.exn_DIV_lab), + (NameLab "__raise_match",BI.exn_MATCH_lab), + (NameLab "__raise_bind",BI.exn_BIND_lab), + (NameLab "__raise_interrupt", BI.exn_INTERRUPT_lab)] + in I.dot_text ::(List.foldr (fn ((nl,dl),C') => + I.dot_globl nl :: + I.lab nl:: + I.movq(L(DatLab dl),R rdi):: + I.call(NameLab "raise_exn")::C') C stublab) + end + + fun gc_stub C = (* tmp_reg1 must contain the register map and tmp_reg0 the return address. *) + if gc_p() then + let + fun push_all_regs C = + foldr (fn (r, C) => I.push(R r) :: C) C all_regs + fun pop_all_regs C = + foldl (fn (r, C) => I.pop(R r) :: C) C all_regs + fun pop_size_ccf_rcf_reg_args C = base_plus_offset(rsp,WORDS 3,rsp,C) (* they are pushed in do_gc *) + val size_ff = 0 (*dummy*) + in + I.dot_text :: + I.dot_globl gc_stub_lab :: + I.lab gc_stub_lab :: + push_all_regs (* The return lab and rcx are also preserved *) + (copy(rsp,tmp_reg0, + compile_c_call_prim("gc",[SS.PHREG_ATY tmp_reg0,SS.PHREG_ATY tmp_reg1],NONE,size_ff,rax, + pop_all_regs( (* The return lab and tmp_reg0 are also popped again *) + pop_size_ccf_rcf_reg_args( + (I.jmp(R tmp_reg0) :: C)))))) + end + else C + + val data_begin_init_lab = NameLab "data_begin_init_lab" + val data_end_init_lab = NameLab "data_end_init_lab" + val data_begin_addr = NameLab "data_begin_addr" + val data_end_addr = NameLab "data_end_addr" + fun generate_data_begin_end (progunit_labs,C) = + if gc_p() then + let + fun comp (l,C) = + let val begin_punit_lab = data_begin_progunit_lab l + val end_punit_lab = data_end_progunit_lab l + val lbelow = new_local_lab "lbelow" + val labove = new_local_lab "labove" + in + I.cmpq(LA begin_punit_lab, R tmp_reg0) :: + I.jb lbelow :: + I.movq(LA begin_punit_lab, R tmp_reg0) :: + I.lab lbelow :: + I.cmpq(LA end_punit_lab, R tmp_reg1) :: + I.ja labove :: + I.movq(LA end_punit_lab, R tmp_reg1) :: + I.lab labove :: + C + end + in + I.movq (LA data_begin_init_lab, R tmp_reg0) :: + I.movq (LA data_end_init_lab, R tmp_reg1) :: + foldl comp (I.movq (R tmp_reg0, L data_begin_addr) :: + I.movq (R tmp_reg1, L data_end_addr) :: C) + progunit_labs + end + else C + + fun generate_jump_code_progunits(progunit_labs,C) = + foldr (fn (l,C) => + let val next_lab = new_local_lab "next_progunit_lab" + in + comment ("PUSH NEXT LOCAL LABEL", + I.push(LA next_lab) :: + comment ("JUMP TO NEXT PROGRAM UNIT", + I.jmp(L l) :: + I.dot_quad "0xFFFFFFFFFFFFFFFF" :: (* Marks no more frames on stack. For calculating rootset. *) + I.dot_quad "0xFFFFFFFFFFFFFFFF" :: (* An arbitrary offsetToReturn *) + I.dot_quad "0xFFFFFFFFFFFFFFFF" :: (* An arbitrary function number. *) + I.lab next_lab :: C)) + end) C progunit_labs + + fun allocate_global_regions(region_labs,C) = + let + fun maybe_pass_region_id (region_id,C) = + if region_profiling() then I.movq(I (i2s region_id), R rsi) :: C + else C + (* Notice, that regionId is not tagged because compile_c_call is not used *) + (* Therefore, we do not use the MaybeUnTag-version. 2001-05-11, Niels *) + fun c_name rho = + if regions_holding_values_of_the_same_type_only rho then + case Effect.get_place_ty rho of + SOME Effect.PAIR_RT => + if region_profiling() then "allocPairRegionInfiniteProfiling" + else "allocatePairRegion" + | SOME Effect.REF_RT => + if region_profiling() then "allocRefRegionInfiniteProfiling" + else "allocateRefRegion" + | SOME Effect.TRIPLE_RT => + if region_profiling() then "allocTripleRegionInfiniteProfiling" + else "allocateTripleRegion" + | SOME Effect.ARRAY_RT => + if region_profiling() then "allocArrayRegionInfiniteProfiling" + else "allocateArrayRegion" + | _ => die "allocate_global_regions.c_name" + else + if region_profiling() then "allocRegionInfiniteProfiling" + else "allocateRegion" + fun maybe_align16 i = + if i mod 16 = 0 then i + 8 + else i + (16 - i mod 16) + 8 + in + foldl (fn ((rho,lab),C) => + let val region_id = Effect.key_of_eps_or_rho rho + val name = c_name rho + val C = I.movq(R rax, L (DatLab lab)) :: C + val sz_regdesc_bytes = 8*BI.size_of_reg_desc() + val sz_regdesc_bytes = maybe_align16 sz_regdesc_bytes + in + I.subq(I(i2s sz_regdesc_bytes), R rsp) :: (* MAEL: maybe align *) + I.movq(R rsp, R rdi) :: + maybe_pass_region_id (region_id, + I.call(NameLab name) :: + C) + end) C region_labs + end + + fun push_top_level_handler C = + let + fun gen_clos C = + if BI.tag_values() then + copy(rsp, tmp_reg1, + I.addq(I "-8", R tmp_reg1) :: + I.movq(R tmp_reg1, D("8", rsp)) :: C) + else + I.movq(R rsp, D("8", rsp)) :: C + in + comment ("PUSH TOP-LEVEL HANDLER ON STACK", + I.subq(I "32", R rsp) :: + I.movq(LA (NameLab "TopLevelHandlerLab"), R tmp_reg1) :: + I.movq(R tmp_reg1, D("0", rsp)) :: + gen_clos ( + I.movq(L exn_ptr_lab, R tmp_reg1) :: + I.movq(R tmp_reg1, D("16", rsp)) :: + I.movq(R rsp, D("24", rsp)) :: + I.movq(R rsp, L exn_ptr_lab) :: C)) + end + + fun init_stack_bot_gc C = + if gc_p() then (* stack_bot_gc[0] = rsp *) + let val C = if simple_memprof_p() then I.movq(R rsp, L stack_min) :: C + else C + in + I.movq(R rsp, L stack_bot_gc_lab) :: C + end + else C + + fun init_prof C = + if region_profiling() then (* stack_bot_gc[0] = rsp *) + I.movq(R rsp, L (NameLab "stackBot")) :: + I.movq(R rsp, L (NameLab "maxStack")) :: + I.movq(R rsp, L (NameLab "maxStackP")) :: + C + else C + + fun main_insts C = + (I.dot_text :: + I.dot_align 8 :: + I.dot_globl (NameLab "code") :: + I.lab (NameLab "code") :: + + (* Compute range of data space *) + generate_data_begin_end(progunit_labs, + + (* Initialize profiling *) + init_prof( + + (* Initialize stack_bot_gc. *) + init_stack_bot_gc( + + (* Put data labels on the stack; they are part of the root-set. *) + store_exported_data_for_gc (dat_labs, + + (* Allocate global regions and push them on stack *) + comment ("Allocate global regions and push them on the stack", + allocate_global_regions(global_region_labs, + + (* Initialize primitive exceptions *) + init_primitive_exception_constructors_code( + + (* Push top-level handler on stack *) + push_top_level_handler( + + (* Code that jump to progunits. *) + comment ("JUMP CODE TO PROGRAM UNITS", + generate_jump_code_progunits(progunit_labs, + + (* Exit instructions *) + compile_c_call_prim("terminateML", [mkIntAty 0], + NONE,0,rax, (* instead of res we return the result from + * the last function call *) + I.ret :: C)))))))))))) + + val init_link_code = (main_insts o raise_insts o + toplevel_handler o allocate o resetregion o + overflow_stub o gc_stub o proftick) nil + fun data_begin C = + if gc_p() then + (I.lab (data_begin_init_lab) :: C) + else C + fun data_end C = + if gc_p() then + (I.dot_align 8 :: + I.dot_globl data_begin_addr :: + I.lab data_begin_addr :: + I.dot_quad "0" :: + I.dot_globl data_end_addr :: + I.lab data_end_addr :: + I.dot_quad "0" :: + I.lab (data_end_init_lab) :: C) + else C + in + {top_decls = [], + init_code = init_link_code, + static_data = (I.dot_data :: + comment ("START OF STATIC DATA AREA", + data_begin ( + get_static_data ( + data_end ( + comment ("END OF STATIC DATA AREA",nil))))))} + end + end + + + (* ------------------------------------------------------------ *) + (* Emitting Target Code *) + (* ------------------------------------------------------------ *) + fun emit(prg: AsmPrg,filename: string) : unit = + (I.emit(prg,filename); + print ("[wrote X64 code file:\t" ^ filename ^ "]\n")) + handle IO.Io {name,...} => Crash.impossible ("CodeGenX64.emit:\nI cannot open \"" + ^ filename ^ "\":\n" ^ name) + +end diff --git a/src/Compiler/Backend/X64/ExecutionX64.sml b/src/Compiler/Backend/X64/ExecutionX64.sml new file mode 100644 index 000000000..e9d203d8d --- /dev/null +++ b/src/Compiler/Backend/X64/ExecutionX64.sml @@ -0,0 +1,324 @@ + +structure ExecutionX64: EXECUTION = + struct + structure TopdecGrammar = PostElabTopdecGrammar + structure Labels = AddressLabels + structure PP = PrettyPrint + + structure BackendInfo = + BackendInfo(val down_growing_stack : bool = true) (* true for x64 code generation *) + + structure NativeCompile = NativeCompile(structure BackendInfo = BackendInfo + structure RegisterInfo = InstsX64.RI) + + structure CompileBasis = CompileBasis(structure ClosExp = NativeCompile.ClosExp) + + structure JumpTables = JumpTables(BackendInfo) + + structure CodeGen = CodeGenX64(structure BackendInfo = BackendInfo + structure JumpTables = JumpTables + structure CallConv = NativeCompile.CallConv + structure LineStmt = NativeCompile.LineStmt + structure SubstAndSimplify = NativeCompile.SubstAndSimplify) + + fun die s = Crash.impossible("ExecutionX64." ^ s) + + fun onmac_p () = InstsX64.sysname() = "Darwin" + + val be_rigid = false + + local + fun convertList option s = + let val l = String.tokens(fn c => c = #",")s + in map (fn s => option ^ s) l + end + in + fun libConvertList s = concat(convertList " -l" s) + fun libdirsConvertList s = concat(convertList " -L" s) + end + + local val default = "m,c,dl" + in + val _ = Flags.add_string_entry + {long="libs", short=NONE, item=ref default, + menu=["Control", "foreign libraries (archives)"], + desc="For accessing a foreign function residing in\n\ + \an archive named libNAME.a from Standard ML code\n\ + \(using prim), you need to add 'NAME' to this\n\ + \comma-separated list. Notice that an object file\n\ + \(with extension '.o') is an archive if it is\n\ + \renamed to have extension '.a'. You may need to\n\ + \use the -libdirs option for specifying\n\ + \directories for which ld should look for library\n\ + \archives. The libraries are passed to 'ld' using\n\ + \the -l option."} + end + + val _ = Flags.add_string_entry + {long="libdirs", short=NONE, item=ref "", + menu=["Control", "library directories (paths to archives)"], + desc="This option controls where ld looks for\n\ + \archives. The format is a comma-separated list\n\ + \of directories; see the -libs entry. The default\n\ + \is the empty list; thus 'ld' will look for\n\ + \libraries in only the system specific default\n\ + \directores. The directories are passed to 'ld'\n\ + \using the -L option."} + + val _ = Flags.add_string_entry + let val macgcc = "gcc -Wl,-no_pie,-stack_size,0x10000000,-stack_addr,0xc0000000" + val gcc = if onmac_p() then macgcc + else "gcc" + in + {long="c_compiler", short=SOME "cc", item=ref gcc, + menu=["Control", "C compiler (used for linking)"], + desc="This option specifies which C compiler is\n\ + \used for linking. When linking with c++\n\ + \libraries, 'g++' is the linker you want.\n\ + \On Linux the default is 'gcc', whereas on\n\ + \Mac OS X, the default is '" ^ macgcc ^ "'."} + end + + val _ = Flags.add_string_entry + let val mac_as = "gcc -c -no-integrated-as" + val linux_as = "as --64" + val ass = if onmac_p() then mac_as else linux_as + in + {long="assembler", short=SOME "as", item=ref ass, + menu=["Control", "Assembler command"], + desc="This option specifies the assembler used.\n\ + \On Linux the default is '" ^ linux_as ^ "'. On Mac OS X,\n\ + \the default is '" ^ mac_as ^ "'."} + end + + val strip_p = ref false + val _ = Flags.add_bool_entry + {long="strip", short=NONE, neg=false, item=strip_p, + menu=["Control", "strip executable"], + desc="If enabled, the Kit strips the generated executable."} + + val _ = Flags.add_bool_entry + {long="delete_target_files", short=NONE, neg=true, item=ref true, + menu=["Debug", "delete target files"], + desc="Delete assembler files produced by the compiler. If you\n\ + \disable this flag, you can inspect the assembler code\n\ + \produced by the compiler."} + + local + val desc = + "When enabled, the compiler passes the option --gstabs\n\ + \to `as' (The GNU Assembler) and preserves the generated\n\ + \assembler files (.s files). Passing the --gstabs\n\ + \option to `as' makes it possible to step through\n\ + \the generated program using gdb (The GNU Debugger)." + val desc_darwin = + "When enabled, the compiler passes the option --g\n\ + \to `as' (The GNU Assembler) and preserves the generated\n\ + \assembler files (.s files). Passing the --g\n\ + \option to `as' makes it possible to step through\n\ + \the generated program using gdb (The GNU Debugger)." + in + val _ = Flags.add_bool_entry + {long="gdb_support", short=SOME "g", neg=false, + menu=["Debug","gdb support"], item=ref false, + desc=if onmac_p() then desc_darwin else desc} + end + + val dangle_stat_p = ref false + val _ = Flags.add_bool_entry + {long="dangling_pointers_statistics", short=NONE, neg=false, + menu=["Debug","dangling pointers statistics"], item=dangle_stat_p, + desc="When enabled, the compiler prints statistics about\n\ + \the number of times strengthening of the region typing\n\ + \rules (to avoid dangling pointers during evaluation)\n\ + \effects the target program. This flag is useful only\n\ + \when the flag -gc or -no_dangle is enabled."} + + fun report_dangle_stat() = + if !dangle_stat_p then + let val n = !Flags.Statistics.no_dangling_pointers_changes + val total = !Flags.Statistics.no_dangling_pointers_changes_total + in + print ("Dangling pointers statistics: \n\ + \ * Number of changes due to strengthening of typing \n\ + \ rules to avoid dangling pointers: " ^ Int.toString n ^ + "\n * Total number of changes: " ^ Int.toString total ^ "\n") + end + else () + + val backend_name = "X64" + + type CompileBasis = CompileBasis.CompileBasis + type CEnv = CompilerEnv.CEnv + type Env = CompilerEnv.ElabEnv + type strdec = TopdecGrammar.strdec + type strexp = TopdecGrammar.strexp + type funid = TopdecGrammar.funid + type strid = TopdecGrammar.strid + type target = CodeGen.AsmPrg + type lab = NativeCompile.label + + val pr_lab = Labels.pr_label + + type linkinfo = {code_label:lab, imports: lab list * lab list, + exports : lab list * lab list, unsafe:bool} + fun code_label_of_linkinfo (li:linkinfo) = #code_label li + fun exports_of_linkinfo (li:linkinfo) = #exports li + fun imports_of_linkinfo (li:linkinfo) = #imports li + fun unsafe_linkinfo (li:linkinfo) = #unsafe li + fun mk_linkinfo a : linkinfo = a + + val debug_linking = Flags.is_on0 "debug_linking" + + (* Hook to be run before any compilation *) + val preHook : unit -> unit = Compile.preHook + + (* Hook to be run after all compilations (for one compilation unit) *) + val postHook : {unitname:string} -> unit = Compile.postHook + + datatype res = CodeRes of CEnv * CompileBasis * target * linkinfo + | CEnvOnlyRes of CEnv + + fun compile fe (ce, CB, strdecs, vcg_file) = + let val (cb,closenv) = CompileBasis.de_CompileBasis CB + in + case Compile.compile fe (ce, cb, strdecs) + of Compile.CEnvOnlyRes ce => CEnvOnlyRes ce + | Compile.CodeRes(ce,cb,target,safe) => + let + val (closenv, target_new) = NativeCompile.compile(closenv,target,safe,vcg_file) + val {main_lab, code, imports, exports, safe} = target_new + val asm_prg = Timing.timing "CG" CodeGen.CG target_new + val linkinfo = mk_linkinfo {code_label=main_lab, + imports=imports, (* (MLFunLab, DatLab) *) + exports=exports, (* (MLFunLab, DatLab) *) + unsafe=not(safe)} + val CB = CompileBasis.mk_CompileBasis(cb,closenv) + in + CodeRes(ce,CB,asm_prg,linkinfo) + end + end + val generate_link_code = SOME (fn (labs,exports) => CodeGen.generate_link_code (labs,exports)) + + fun delete_file f = OS.FileSys.remove f handle _ => () + + fun execute_command cmd : unit = + let val () = if debug_linking() then print ("[Executing: " ^ cmd ^ "]\n") + else () + in (OS.Process.system cmd; ()) + handle (X as OS.SysErr(s,_)) => + ( print ("\nCommand " ^ cmd ^ "\nfailed (" ^ s ^ ")\n") + ; raise X) + end + + val gdb_support = Flags.is_on0 "gdb_support" + val delete_target_files = Flags.is_on0 "delete_target_files" + val libs = Flags.lookup_string_entry "libs" + + fun gas0() = + !(Flags.lookup_string_entry "assembler") +(* + if onmac_p() then "as -arch x64" else "as --64" +*) + + fun gas() = if gdb_support() then + if onmac_p() then gas0() ^ " -g" + else gas0() ^ " --gstabs" + else gas0() + + fun assemble (file_s, file_o) = + (execute_command (gas() ^ " -o " ^ file_o ^ " " ^ file_s); + if delete_target_files() andalso not(gdb_support()) then delete_file file_s + else ()) + + fun emit {target, filename:string} : string = + let val filename_o = filename ^ ".o" + val filename_s = filename ^ ".s" + in CodeGen.emit (target, filename_s); + assemble(filename_s, filename_o); + filename_o + end + + fun strip run = + if !strip_p then (execute_command ("strip " ^ run) + handle _ => ()) + else () + + fun link_files_with_runtime_system0 path_to_runtime files run = + let val files = map (fn s => s ^ " ") files + val libdirs = + case !(Flags.lookup_string_entry "libdirs") of + "" => "" + | libdirs => " " ^ libdirsConvertList libdirs + val shell_cmd = !(Flags.lookup_string_entry "c_compiler") ^ " -o " ^ run ^ " " ^ + concat files ^ path_to_runtime() ^ libdirs ^ libConvertList(!libs) + in + execute_command shell_cmd; + strip run; + print("[wrote executable file:\t" ^ run ^ "]\n"); + report_dangle_stat() + end + + val op ## = OS.Path.concat infix ## + + local + val region_profiling = Flags.lookup_flag_entry "region_profiling" + val tag_values = Flags.is_on0 "tag_values" + val tag_pairs_p = Flags.is_on0 "tag_pairs" + val gc_p = Flags.is_on0 "garbage_collection" + val gengc_p = Flags.is_on0 "generational_garbage_collection" + + fun path_to_runtime () = + let fun file () = + if !region_profiling andalso gc_p() andalso tag_pairs_p() then "runtimeSystemGCTPProf.a" else + if !region_profiling andalso gc_p() andalso gengc_p() then "runtimeSystemGenGCProf.a" else + if !region_profiling andalso gc_p() then "runtimeSystemGCProf.a" else + if !region_profiling then "runtimeSystemProf.a" else + if gc_p() andalso tag_pairs_p() then "runtimeSystemGCTP.a" else + if gc_p() andalso gengc_p() then "runtimeSystemGenGC.a" else + if gc_p() then "runtimeSystemGC.a" else + if tag_values() andalso tag_pairs_p() then + die "no runtime system supports tagging of values with tagging of pairs" else + if tag_values() then "runtimeSystemTag.a" else + "runtimeSystem.a" + in !Flags.install_dir ## "lib" ## file() + end + in + val link_files_with_runtime_system = link_files_with_runtime_system0 path_to_runtime + end + + + local + val region_profiling = Flags.is_on0 "region_profiling" + val recompile_basislib = Flags.is_on0 "recompile_basislib" + val tag_pairs_p = Flags.is_on0 "tag_pairs" + val gc_p = Flags.is_on0 "garbage_collection" + val gengc_p = Flags.is_on0 "generational_garbage_collection" + in + (* Remember also to update RepositoryFinMap in Common/Elaboration.sml *) + fun mlbdir() = + let val subdir = + if recompile_basislib() then "Scratch" (* avoid overwriting other files *) + else + case (gengc_p(),gc_p(), region_profiling(), tag_pairs_p()) of + (false, true, true, false) => "RI_GC_PROF" + | (false, true, false, false) => "RI_GC" + | (false, true, true, true) => "RI_GC_TP_PROF" + | (false, true, false, true) => "RI_GC_TP" + | (true, true, true, false) => "RI_GEN_GC_PROF" + | (true, true, false, false) => "RI_GEN_GC" + | (true, _, _, _) => die "Illegal combination of generational garbage collection and tagged pairs" + | (false, false, true, _) => "RI_PROF" + | (false, false, false, _) => "RI" + in "MLB" ## subdir + end + end + + val pu_linkinfo = + let val pu_labels = Pickle.listGen Labels.pu + val pu_pair = Pickle.pairGen(pu_labels,pu_labels) + in Pickle.convert (fn (c,i,e,u) => {code_label=c,imports=i,exports=e,unsafe=u}, + fn {code_label=c,imports=i,exports=e,unsafe=u} => (c,i,e,u)) + (Pickle.tup4Gen(Labels.pu,pu_pair,pu_pair,Pickle.bool)) + end + end diff --git a/src/Compiler/Backend/X64/INSTS_X64.sml b/src/Compiler/Backend/X64/INSTS_X64.sml new file mode 100644 index 000000000..bd061f2dd --- /dev/null +++ b/src/Compiler/Backend/X64/INSTS_X64.sml @@ -0,0 +1,166 @@ +signature INSTS_X64 = + sig + + type lvar + + datatype reg = rax | rbx | rcx | rdx | rsi | rdi | rbp | rsp + | r8 | r9 | r10 | r11 | r12 | r13 | r14 | r15 + | eax | ebx | ecx | edx | esi | edi | ebp | esp + | r8d | r9d | r10d | r11d | r12d | r13d | r14d | r15d + | ah (* for float conditionals *) + | al (* for byte operations *) + | cl (* for shift operations *) + | r10b (* for bytetable_update, e.g. *) + | xmm0 | xmm1 + + val pr_reg : reg -> string + + val tmp_reg0 : reg (*=r10*) + val tmp_reg1 : reg (*=r11*) + + val doubleOfQuadReg : reg -> reg (* fails if given a non-quad register *) + + type freg + + type label + datatype lab = + DatLab of label (* For data to propagate across program units *) + | LocalLab of label (* Local label inside a block *) + | NameLab of string (* For ml strings, jumps to runtime system, + jumps to millicode, code label, finish + label, etc. *) + | MLFunLab of label (* Labels on ML Functions *) + + val eq_lab : lab * lab -> bool + + datatype ea = R of reg (* register *) + | L of lab (* label *) + | LA of lab (* label address *) + | I of string (* immediate *) + | D of string * reg (* displaced *) + | DD of string * reg * reg * string (* double displaced *) + val pr_ea : ea -> string + val eq_ea : ea * ea -> bool + + datatype inst = (* general instructions *) + movq of ea * ea + | movb of ea * ea + | movzbq of ea * ea + | push of ea + | leaq of ea * ea + | pop of ea + | andb of ea * ea + + | addl of ea * ea (* LONG OPERATIONS (32 bit) *) + | subl of ea * ea + | negl of ea + | decl of ea + | incl of ea + | imull of ea * ea + | notl of ea + | orl of ea * ea + | xorl of ea * ea + | andl of ea * ea + | sarl of ea * ea + | shrl of ea * ea (* unsigned *) + | sall of ea * ea + | cmpl of ea * ea + | btl of ea * ea (* bit test; sets carry flag *) + | btrl of ea * ea (* bit test and reset; sets carry flag *) + + | addq of ea * ea (* QUAD OPERATIONS (64 bit) *) + | subq of ea * ea + | negq of ea + | decq of ea + | incq of ea + | imulq of ea * ea + | notq of ea + | orq of ea * ea + | xorq of ea * ea + | andq of ea * ea + | sarq of ea * ea + | shrq of ea * ea (* unsigned *) + | salq of ea * ea + | cmpq of ea * ea + | btq of ea * ea (* bit test; sets carry flag *) + | btrq of ea * ea (* bit test and reset; sets carry flag *) + + | movsd of ea * ea (* FLOAT OPERATIONS *) + | mulsd of ea * ea + | divsd of ea * ea + | addsd of ea * ea + | subsd of ea * ea + | maxsd of ea * ea + | ucomisd of ea * ea + | xorps of ea * ea + + | fstpq of ea (* store float and pop float stack *) + | fldq of ea (* push float onto the float stack *) + | fldz (* push 0.0 onto the float stack *) + | faddp (* add st(0) to st(1) and pop *) + | fsubp (* subtract st(0) from st(1) and pop *) + | fmulp (* multiply st(0) to st(1) and pop *) + | fdivp (* divide st(1) with st(0) and pop *) + | fcompp (* compare st(0) and st(1) and pop twice *) + | fabs (* st(0) = abs(st(0)) *) + | fchs (* st(0) = neg(st(0)) *) + | fnstsw (* store float status word *) + + | jmp of ea (* jump instructions *) + | jl of lab + | jg of lab + | jle of lab + | jge of lab + | je of lab (* = jz *) + | jne of lab (* = jnz *) + | jc of lab (* jump on carry *) + | jnc of lab (* jump on non-carry *) + | ja of lab (* jump if above---unsigned *) + | jb of lab (* jump if below---unsigned *) + | jae of lab (* jump if above or equal---unsigned *) + | jbe of lab (* jump if below or equal---unsigned *) + | jo of lab (* jump on overflow *) + + | call of lab (* C function calls and returns *) + | call' of ea (* C function calls and returns *) + | ret + | leave + + | dot_align of int (* pseudo instructions *) + | dot_globl of lab + | dot_text + | dot_data + | dot_section of string + | dot_byte of string + | dot_long of string + | dot_quad of string + | dot_double of string + | dot_string of string + | dot_size of lab * int + | lab of lab + | comment of string + + datatype top_decl = + FUN of label * inst list + | FN of label * inst list + + type AsmPrg = {top_decls: top_decl list, + init_code: inst list, + static_data: inst list} + + (* General purpose registers *) + + val emit : AsmPrg * string -> unit (* may raise IO *) + + val pr_lab : lab -> string + + structure RI : REGISTER_INFO + where type reg = reg + where type lvar = lvar + + val sysname : unit -> string + + type StringTree + val layout : AsmPrg -> StringTree + + end diff --git a/src/Compiler/Backend/X64/InstsX64.sml b/src/Compiler/Backend/X64/InstsX64.sml new file mode 100644 index 000000000..4237ed935 --- /dev/null +++ b/src/Compiler/Backend/X64/InstsX64.sml @@ -0,0 +1,468 @@ +structure InstsX64: INSTS_X64 = + struct + structure PP = PrettyPrint + structure Labels = AddressLabels + + fun die s = Crash.impossible("InstX64." ^ s) + + fun memoize f = + let val r = ref NONE + in fn () => case !r of SOME v => v + | NONE => let val v = f() + in r:=SOME v; v + end + end + + val sysname = + memoize (fn () => + case List.find (fn (f,_) => f = "sysname") (Posix.ProcEnv.uname()) of + SOME (_, name) => name + | NONE => "unknown" + ) + + type lvar = Lvars.lvar + datatype reg = rax | rbx | rcx | rdx | rsi | rdi | rbp | rsp + | r8 | r9 | r10 | r11 | r12 | r13 | r14 | r15 + | eax | ebx | ecx | edx | esi | edi | ebp | esp + | r8d | r9d | r10d | r11d | r12d | r13d | r14d | r15d + | ah (* for float conditionals *) + | al (* for byte operations *) + | cl (* for shift operations *) + | r10b (* for bytetable_update, e.g. *) + | xmm0 | xmm1 + + type freg = int + + type label = Labels.label + datatype lab = + DatLab of label (* For data to propagate across program units *) + | LocalLab of label (* Local label inside a block *) + | NameLab of string (* For ml strings, jumps to runtime system, + jumps to millicode, code label, finish + label, etc. *) + | MLFunLab of label (* Labels on ML Functions *) + + fun eq_lab (DatLab label1, DatLab label2) = Labels.eq(label1,label2) + | eq_lab (LocalLab label1, LocalLab label2) = Labels.eq(label1,label2) + | eq_lab (NameLab s1, NameLab s2) = s1 = s2 + | eq_lab (MLFunLab label1, MLFunLab label2) = Labels.eq(label1,label2) + | eq_lab _ = false + + datatype ea = + R of reg (* register *) + | L of lab (* label *) + | LA of lab (* label address *) + | I of string (* immediate *) + | D of string * reg (* displaced *) + | DD of string * reg * reg * string (* double displaced *) + + fun eq_ea (R r, R r') = r=r' + | eq_ea (I i, I i') = i=i' + | eq_ea (L l, L l') = eq_lab(l,l') + | eq_ea (LA l, LA l') = eq_lab(l,l') + | eq_ea (D p,D p') = p=p' + | eq_ea (DD p,DD p') = p=p' + | eq_ea _ = false + + datatype inst = (* general instructions *) + movq of ea * ea + | movb of ea * ea + | movzbq of ea * ea + | push of ea + | leaq of ea * ea + | pop of ea + | andb of ea * ea + + | addl of ea * ea (* LONG OPERATIONS (32 bit) *) + | subl of ea * ea + | negl of ea + | decl of ea + | incl of ea + | imull of ea * ea + | notl of ea + | orl of ea * ea + | xorl of ea * ea + | andl of ea * ea + | sarl of ea * ea + | shrl of ea * ea (* unsigned *) + | sall of ea * ea + | cmpl of ea * ea + | btl of ea * ea (* bit test; sets carry flag *) + | btrl of ea * ea (* bit test and reset; sets carry flag *) + + | addq of ea * ea (* QUAD OPERATIONS (64 bit) *) + | subq of ea * ea + | negq of ea + | decq of ea + | incq of ea + | imulq of ea * ea + | notq of ea + | orq of ea * ea + | xorq of ea * ea + | andq of ea * ea + | sarq of ea * ea + | shrq of ea * ea (* unsigned *) + | salq of ea * ea + | cmpq of ea * ea + | btq of ea * ea (* bit test; sets carry flag *) + | btrq of ea * ea (* bit test and reset; sets carry flag *) + + | movsd of ea * ea + | mulsd of ea * ea + | divsd of ea * ea + | addsd of ea * ea + | subsd of ea * ea + | maxsd of ea * ea + | ucomisd of ea * ea + | xorps of ea * ea + + | fstpq of ea (* store float and pop float stack *) + | fldq of ea (* push float onto the float stack *) + | fldz (* push 0.0 onto the float stack *) + | faddp (* add st(0) to st(1) and pop *) + | fsubp (* subtract st(0) from st(1) and pop *) + | fmulp (* multiply st(0) to st(1) and pop *) + | fdivp (* divide st(1) with st(0) and pop *) + | fcompp (* compare st(0) and st(1) and pop twice *) + | fabs (* st(0) = abs(st(0)) *) + | fchs (* st(0) = neg(st(0)) *) + | fnstsw (* store float status word *) + + | jmp of ea (* jump instructions *) + | jl of lab + | jg of lab + | jle of lab + | jge of lab + | je of lab (* = jz *) + | jne of lab (* = jnz *) + | jc of lab (* jump on carry *) + | jnc of lab (* jump on non-carry *) + | ja of lab (* jump if above---unsigned *) + | jb of lab (* jump if below---unsigned *) + | jae of lab (* jump if above or equal---unsigned *) + | jbe of lab (* jump if below or equal---unsigned *) + | jo of lab (* jump on overflow *) + + | call of lab (* C function calls and returns *) + | call' of ea (* C function calls and returns *) + | ret + | leave + + | dot_align of int (* pseudo instructions *) + | dot_globl of lab + | dot_text + | dot_data + | dot_section of string + | dot_byte of string + | dot_long of string + | dot_quad of string + | dot_double of string + | dot_string of string + | dot_size of lab * int + | lab of lab + | comment of string + + datatype top_decl = + FUN of label * inst list + | FN of label * inst list + + type AsmPrg = {top_decls: top_decl list, + init_code: inst list, + static_data: inst list} + + fun pr_reg rax = "%rax" + | pr_reg rbx = "%rbx" + | pr_reg rcx = "%rcx" + | pr_reg rdx = "%rdx" + | pr_reg rsi = "%rsi" + | pr_reg rdi = "%rdi" + | pr_reg rbp = "%rbp" + | pr_reg rsp = "%rsp" + | pr_reg r8 = "%r8" + | pr_reg r9 = "%r9" + | pr_reg r10 = "%r10" + | pr_reg r11 = "%r11" + | pr_reg r12 = "%r12" + | pr_reg r13 = "%r13" + | pr_reg r14 = "%r14" + | pr_reg r15 = "%r15" + | pr_reg eax = "%eax" + | pr_reg ebx = "%ebx" + | pr_reg ecx = "%ecx" + | pr_reg edx = "%edx" + | pr_reg esi = "%esi" + | pr_reg edi = "%edi" + | pr_reg ebp = "%ebp" + | pr_reg esp = "%esp" + | pr_reg r8d = "%r8d" + | pr_reg r9d = "%r9d" + | pr_reg r10d = "%r10d" + | pr_reg r11d = "%r11d" + | pr_reg r12d = "%r12d" + | pr_reg r13d = "%r13d" + | pr_reg r14d = "%r14d" + | pr_reg r15d = "%r15d" + | pr_reg ah = "%ah" + | pr_reg al = "%al" + | pr_reg cl = "%cl" + | pr_reg r10b = "%r10b" + | pr_reg xmm0 = "%xmm0" + | pr_reg xmm1 = "%xmm1" + + fun remove_ctrl s = + String.implode (List.filter (fn c => + Char.isAlphaNum c orelse + c = #"_" orelse c = #".") (String.explode s)) + + fun pr_namelab s = + if sysname() = "Darwin" then "_" ^ s + else s + + fun pr_lab (DatLab l) = "DLab." ^ remove_ctrl(Labels.pr_label l) + | pr_lab (LocalLab l) = ".LLab." ^ remove_ctrl(Labels.pr_label l) + | pr_lab (NameLab s) = pr_namelab(remove_ctrl s) + | pr_lab (MLFunLab l) = "FLab." ^ remove_ctrl(Labels.pr_label l) + + (* Convert ~n to -n *) + fun int_to_string i = if i >= 0 then Int.toString i + else "-" ^ Int.toString (~i) + + fun pr_ea (R r) = pr_reg r + | pr_ea (L l) = pr_lab l ^ "(%rip)" + | pr_ea (LA l) = + if sysname() = "Darwin" then + pr_lab l ^ "@GOTPCREL(%rip)" + else "$" ^ pr_lab l + | pr_ea (I s) = "$" ^ s + | pr_ea (D(d,r)) = if d="0" then "(" ^ pr_reg r ^ ")" + else d ^ "(" ^ pr_reg r ^ ")" + | pr_ea (DD(d,r1,r2,m)) = + let val m = if m = "1" orelse m = "" then "" else "," ^ m + val d = if d = "0" orelse d = "" then "" else d + in d ^ "(" ^ pr_reg r1 ^ "," ^ pr_reg r2 ^ m ^ ")" + end + + fun emit_insts (os, insts: inst list): unit = + let + fun emit s = TextIO.output(os, s) + fun emit_n i = emit(Int.toString i) + fun emit_nl() = emit "\n" + fun emit_bin (s, (ea1, ea2)) = (emit "\t"; emit s; emit " "; + emit(pr_ea ea1); emit ","; + emit(pr_ea ea2); emit_nl()) + fun emit_unary(s, ea) = (emit "\t"; emit s; emit " "; emit(pr_ea ea); emit_nl()) + fun emit_nullary s = (emit "\t"; emit s; emit_nl()) + fun emit_nullary0 s = (emit s; emit_nl()) + fun emit_jump(s,l) = (emit "\t"; emit s; emit " "; emit(pr_lab l); emit_nl()) + fun emit_inst i = + case i + of movq a => emit_bin ("movq", a) + | movb a => emit_bin ("movb", a) + | movzbq a => emit_bin ("movzbq", a) + | leaq a => emit_bin ("leaq", a) + | push ea => emit_unary ("push", ea) + | pop ea => emit_unary ("pop", ea) + | andb a => emit_bin("andb", a) + + | addl a => emit_bin("addl", a) + | subl a => emit_bin("subl", a) + | negl ea => emit_unary("negl", ea) + | decl ea => emit_unary("decl", ea) + | incl ea => emit_unary("incl", ea) + | imull a => emit_bin("imull", a) + | notl ea => emit_unary("notl", ea) + | orl a => emit_bin("orl", a) + | xorl a => emit_bin("xorl", a) + | andl a => emit_bin("andl", a) + | sarl a => emit_bin("sarl", a) + | shrl a => emit_bin("shrl", a) + | sall a => emit_bin("sall", a) + | cmpl a => emit_bin("cmpl", a) + | btl a => emit_bin("btl", a) + | btrl a => emit_bin("btrl", a) + + | addq a => emit_bin("addq", a) + | subq a => emit_bin("subq", a) + | negq ea => emit_unary("negq", ea) + | decq ea => emit_unary("decq", ea) + | incq ea => emit_unary("incq", ea) + | imulq a => emit_bin("imulq", a) + | notq ea => emit_unary("notq", ea) + | orq a => emit_bin("orq", a) + | xorq a => emit_bin("xorq", a) + | andq a => emit_bin("andq", a) + | sarq a => emit_bin("sarq", a) + | shrq a => emit_bin("shrq", a) + | salq a => emit_bin("salq", a) + | cmpq a => emit_bin("cmpq", a) + | btq a => emit_bin("btq", a) + | btrq a => emit_bin("btrq", a) + + | movsd a => emit_bin("movsd", a) + | mulsd a => emit_bin("mulsd", a) + | divsd a => emit_bin("divsd", a) + | addsd a => emit_bin("addsd", a) + | subsd a => emit_bin("subsd", a) + | maxsd a => emit_bin("maxsd", a) + | ucomisd a => emit_bin("ucomisd", a) + | xorps a => emit_bin("xorps", a) + + | fstpq ea => emit_unary("fstpq", ea) + | fldq ea => emit_unary("fldq", ea) + | fldz => emit_nullary "fldz" + | faddp => emit_nullary "faddp" + | fsubp => emit_nullary "fsubp" + | fmulp => emit_nullary "fmulp" + | fdivp => emit_nullary "fdivp" + | fcompp=> emit_nullary "fcompp" + | fabs => emit_nullary "fabs" + | fchs => emit_nullary "fchs" + | fnstsw => emit_nullary "fnstsw" + + | jmp (L l) => emit_jump("jmp", l) + | jmp ea => (emit "\tjmp *"; emit(pr_ea ea); emit_nl()) + | jl l => emit_jump("jl", l) + | jg l => emit_jump("jg", l) + | jle l => emit_jump("jle", l) + | jge l => emit_jump("jge", l) + | je l => emit_jump("je", l) + | jne l => emit_jump("jne", l) + | jc l => emit_jump("jc", l) + | jnc l => emit_jump("jnc", l) + | ja l => emit_jump("ja", l) + | jb l => emit_jump("jb", l) + | jae l => emit_jump("jae", l) + | jbe l => emit_jump("jbe", l) + | jo l => emit_jump("jo", l) + + | call l => emit_jump("call", l) + | call' ea => (emit "\tcall *"; emit(pr_ea ea); emit_nl()) + | ret => emit_nullary "ret" + | leave => emit_nullary "leave" + + | dot_align i => (emit "\t.align "; emit_n i; emit_nl()) + | dot_globl l => (emit ".globl "; emit(pr_lab l); emit_nl()) + | dot_text => emit_nullary0 ".text" + | dot_data => emit_nullary0 ".data" + | dot_byte s => (emit "\t.byte "; emit s; emit_nl()) + | dot_long s => (emit "\t.long "; emit s; emit_nl()) + | dot_quad s => (emit "\t.quad "; emit s; emit_nl()) + | dot_double s => (emit "\t.double "; emit s; emit_nl()) + | dot_string s => (emit "\t.string \""; emit s; emit "\""; emit_nl()) + | dot_section s => (emit ".section \t"; emit s; emit_nl()) + | dot_size (l, i) => (emit "\t.size "; emit(pr_lab l); emit ","; + emit_n i; emit_nl()) + | lab l => (emit(pr_lab l); emit":"; emit_nl()) + | comment s => (emit " # "; emit s; emit_nl()) + in app emit_inst insts + end + + fun emit_topdecl os t = + case t + of FUN (l, insts) => emit_insts(os, lab (MLFunLab l)::insts) + | FN (l, insts) => emit_insts(os, lab (MLFunLab l)::insts) + + fun emit ({top_decls: top_decl list, + init_code: inst list, + static_data: inst list}, filename) = + let + val os : TextIO.outstream = TextIO.openOut filename + val section = + if sysname() = "Darwin" then ".note.GNU-stack,\"\"" + else ".note.GNU-stack,\"\",@progbits" + val static_data = dot_section section :: static_data + in (emit_insts (os, init_code); + app (emit_topdecl os) top_decls; + emit_insts (os, static_data); + TextIO.closeOut os) handle E => (TextIO.closeOut os; raise E) + end + + (*-----------------------------------------------------------*) + (* Converting Between General Registers and Precolored Lvars *) + (* As Used In The Phases Preceeding Code Generation *) + (*-----------------------------------------------------------*) + + structure RI : REGISTER_INFO = + struct + type lvar = lvar + type lvarset = Lvarset.lvarset + type reg = reg + + val pr_reg = pr_reg + + structure LvarFinMap = Lvars.Map + + val regs = [rax,rbx,rcx,rdx,rsi,rdi,rbp,rsp,r8,r9,r10,r11,r12,r13,r14,r15] + val reg_lvs = map (fn r => Lvars.new_named_lvar (pr_reg r)) regs + val (rax_lv,rbx_lv,rcx_lv,rdx_lv,rsi_lv,rdi_lv,rbp_lv,rsp_lv, + r8_lv,r9_lv,r10_lv,r11_lv,r12_lv,r13_lv,r14_lv,r15_lv) = + case reg_lvs of + [rax_lv,rbx_lv,rcx_lv,rdx_lv,rsi_lv,rdi_lv,rbp_lv,rsp_lv, + r8_lv,r9_lv,r10_lv,r11_lv,r12_lv,r13_lv,r14_lv,r15_lv] => + (rax_lv,rbx_lv,rcx_lv,rdx_lv,rsi_lv,rdi_lv,rbp_lv,rsp_lv, + r8_lv,r9_lv,r10_lv,r11_lv,r12_lv,r13_lv,r14_lv,r15_lv) + | _ => die "RI.reg_lvs mismatch" + val map_lvs_to_reg = LvarFinMap.fromList(ListPair.zip(reg_lvs,regs)) + + val all_regs = reg_lvs + + fun is_reg lv = + (case LvarFinMap.lookup map_lvs_to_reg lv of + SOME reg => true + | NONE => false) + + fun lv_to_reg lv = + (case LvarFinMap.lookup map_lvs_to_reg lv of + NONE => die "lv_to_reg: lv not a register" + | SOME i => i) + + fun reg_to_lv r = + case r of + rax => rax_lv | rbx => rbx_lv | rcx => rcx_lv | rdx => rdx_lv + | rsi => rsi_lv | rdi => rdi_lv | rbp => rbp_lv | rsp => rsp_lv + | r8 => r8_lv | r9 => r9_lv | r10 => r10_lv | r11 => r11_lv + | r12 => r12_lv | r13 => r13_lv | r14 => r14_lv | r15 => r15_lv + | _ => die ("reg_to_lv: " ^ pr_reg r ^ " not available for register allocation") + + val reg_args = [rax,rbx,rdi] + val args_phreg = map reg_to_lv reg_args + val reg_res = [rdi,rbx,rax] + val res_phreg = map reg_to_lv reg_res + + val args_reg_ccall = [rdi,rsi,rdx,rcx,r8,r9] + val args_phreg_ccall = map reg_to_lv args_reg_ccall + val args_ccall_phregset = Lvarset.lvarsetof args_phreg_ccall + val res_reg_ccall = [rax] + val res_phreg_ccall = map reg_to_lv res_reg_ccall + + fun reg_eq(reg1,reg2) = reg1 = reg2 + val callee_save_regs_ccall = [rbx,rbp,r12,r13,r14,r15] + val callee_save_ccall_phregs = map reg_to_lv callee_save_regs_ccall + val callee_save_ccall_phregset = Lvarset.lvarsetof callee_save_ccall_phregs + fun is_callee_save_ccall phreg = false + + val caller_save_regs_mlkit = [rax,rbx,rdi,rdx,rsi] + val caller_save_phregs = map reg_to_lv caller_save_regs_mlkit + val caller_save_phregset = Lvarset.lvarsetof caller_save_phregs + fun is_caller_save phreg = Lvarset.member(phreg,caller_save_phregset) + + val caller_save_regs_ccall = [] (*[r10,r11]*) + val caller_save_ccall_phregs = map reg_to_lv caller_save_regs_ccall + val caller_save_ccall_phregset = Lvarset.lvarsetof caller_save_ccall_phregs + fun is_caller_save_ccall phreg = Lvarset.member(phreg,caller_save_ccall_phregset) + end + + val tmp_reg0 = r10 (* CALLER saves scratch registers *) + val tmp_reg1 = r11 + + fun doubleOfQuadReg r = + case r of + rax => eax | rbx => ebx | rcx => ecx | rdx => edx + | rsi => esi | rdi => edi | rbp => ebp | rsp => esp + | r8 => r8d | r9 => r9d | r10 => r10d | r11 => r11d + | r12 => r12d | r13 => r13d | r14 => r14d | r15 => r15d + | _ => die ("doubleOfQuadReg: " ^ pr_reg r ^ " is not a quad register") + + type StringTree = PP.StringTree + fun layout _ = PP.LEAF "not implemented" + end diff --git a/src/Compiler/native64.mlb b/src/Compiler/native64.mlb new file mode 100644 index 000000000..d8205e102 --- /dev/null +++ b/src/Compiler/native64.mlb @@ -0,0 +1,44 @@ +local + prebackend.mlb + basis Regions = bas regions.mlb end + open BasLib (* Compiler *) Regions +in + (* Native Backend *) + + Backend/LINE_STMT.sml + Backend/REG_ALLOC.sml + Backend/FETCH_AND_FLUSH.sml + Backend/CALC_OFFSET.sml + Backend/SUBST_AND_SIMPLIFY.sml + local open Tools + in + local open CompilerObjects + in Backend/LineStmt.sml + Backend/RegAlloc.sml + Backend/FetchAndFlush.sml + local open Edlib in Backend/CalcOffset.sml end + Backend/SubstAndSimplify.sml + Backend/NativeCompile.sml + end + end + + (* X86 Backend *) + Backend/CODE_GEN.sml + Backend/X64/INSTS_X64.sml + ../Kitlib/kitlib.mlb + local open Tools + in + local open CompilerObjects + in Backend/X64/InstsX64.sml + Backend/X64/CodeGenX64.sml + local open Pickle Basics Manager + in Backend/X64/ExecutionX64.sml + end + end + + local open Compiler + in ../Common/KitX64.sml + end + + end +end diff --git a/src/Makefile.in b/src/Makefile.in index b67c3545a..f6cc7e412 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -25,7 +25,7 @@ GENOPCODES_SOURCES=Compiler/Backend/KAM/BuiltInCFunctions.spec \ Compiler/Backend/KAM/BuiltInCFunctionsApSml.spec \ Compiler/Backend/KAM/KamInsts.spec -# Whether request profiling is enabled +# Whether request profiling is enabled REQUEST_PROFILING= #REQUEST_PROFILING=true @@ -49,7 +49,7 @@ mlkit_runtime: basics .PHONY: mlkit_kit mlkit_kit: - $(MLCOMP) -output mlkit Compiler/native.mlb + $(MLCOMP) -output mlkit Compiler/native64.mlb $(INSTALL) -p mlkit $(BINDIR) .PHONY: smltojs @@ -154,6 +154,7 @@ clean: cd Compiler/Backend/Dummy && $(CLEAN) cd Compiler/Backend/HpPaRisc && $(CLEAN) cd Compiler/Backend/X86 && $(CLEAN) + cd Compiler/Backend/X64 && $(CLEAN) cd Compiler/Backend/KAM && $(CLEAN) cd Compiler/Backend/Barry && $(CLEAN) cd Compiler/Backend/JS && $(CLEAN) @@ -175,31 +176,31 @@ LINES = /home/mael/kit/src/lines.mael.sml .PHONY: bdys bdys: (cd Common/PM/RI && wc -l *.bdy > $(FILE)) - (cd Common/EfficientElab/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Parsing/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Compiler/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Compiler/Lambda/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Compiler/Regions/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Compiler/Kam/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Compiler/Cfg/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Compiler/C/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Compiler/Backend/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Compiler/Backend/HpPaRisc/PM/RI && wc -l *.bdy >> $(FILE)) - (cd Manager/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Common/EfficientElab/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Parsing/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Compiler/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Compiler/Lambda/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Compiler/Regions/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Compiler/Kam/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Compiler/Cfg/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Compiler/C/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Compiler/Backend/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Compiler/Backend/HpPaRisc/PM/RI && wc -l *.bdy >> $(FILE)) + (cd Manager/PM/RI && wc -l *.bdy >> $(FILE)) .PHONY: lines lines: (cd Common && cat *.sml > $(LINES)) - (cd Common/EfficientElab && cat *.sml >> $(LINES)) - (cd Parsing && cat *.sml >> $(LINES)) - (cd Compiler && cat *.sml >> $(LINES)) - (cd Compiler/Lambda && cat *.sml >> $(LINES)) - (cd Compiler/Regions && cat *.sml >> $(LINES)) - (cd Compiler/Kam && cat *.sml >> $(LINES)) - (cd Compiler/Cfg && cat *.sml >> $(LINES)) - (cd Compiler/C && cat *.sml >> $(LINES)) - (cd Compiler/Backend && cat *.sml >> $(LINES)) - (cd Compiler/Backend/HpPaRisc && cat *.sml >> $(LINES)) + (cd Common/EfficientElab && cat *.sml >> $(LINES)) + (cd Parsing && cat *.sml >> $(LINES)) + (cd Compiler && cat *.sml >> $(LINES)) + (cd Compiler/Lambda && cat *.sml >> $(LINES)) + (cd Compiler/Regions && cat *.sml >> $(LINES)) + (cd Compiler/Kam && cat *.sml >> $(LINES)) + (cd Compiler/Cfg && cat *.sml >> $(LINES)) + (cd Compiler/C && cat *.sml >> $(LINES)) + (cd Compiler/Backend && cat *.sml >> $(LINES)) + (cd Compiler/Backend/HpPaRisc && cat *.sml >> $(LINES)) (cd Manager && cat *.sml >> $(LINES)) wc -l $(LINES) rm -f $(LINES) diff --git a/src/Manager/Manager.sml b/src/Manager/Manager.sml index be0c9c9c9..2263c71aa 100644 --- a/src/Manager/Manager.sml +++ b/src/Manager/Manager.sml @@ -2,7 +2,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS structure IntModules : INT_MODULES sharing type ManagerObjects.IntBasis = IntModules.IntBasis - sharing type ManagerObjects.modcode = IntModules.modcode) + sharing type ManagerObjects.modcode = IntModules.modcode) : MANAGER = struct structure PP = PrettyPrint @@ -13,10 +13,10 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS structure ElabBasis = ModuleEnvironments.B structure ErrorCode = ParseElab.ErrorCode structure H = Polyhash - + (* This should definitely go somewhere else! Copy of function in ExpToJs.sml *) fun toJSString s = - let + let fun digit n = chr(48 + n); fun toJSescape (c:char) : string = case c of @@ -35,11 +35,11 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS | _ => let val n = ord c in implode[#"\\", digit(n div 64), digit(n div 8 mod 8), digit(n mod 8)] - end) - + end) + in "\"" ^ String.translate toJSescape s ^ "\"" end - + fun testout(s: string):unit = TextIO.output(TextIO.stdOut, s) fun testouttree(t:PP.StringTree) = PP.outputTree(testout,t,80) @@ -55,19 +55,19 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS val region_profiling = Flags.is_on0 "region_profiling" - val export_basis_js = - (Flags.add_bool_entry - {long="export_basis_js", short=SOME "ebjs", neg=false, + val export_basis_js = + (Flags.add_bool_entry + {long="export_basis_js", short=SOME "ebjs", neg=false, item=ref false, menu=["Control", "export basis in js file (SmlToJs)"], desc="When this flag is enabled, SmlToJs writes\n\ \pickled bases to file.eb.js files to be read by\n\ \js-client."} - ; Flags.is_on0 "export_basis_js") + ; Flags.is_on0 "export_basis_js") - val extendedtyping = - (Flags.add_bool_entry - {long="extended_typing", short=SOME "xt", neg=false, + val extendedtyping = + (Flags.add_bool_entry + {long="extended_typing", short=SOME "xt", neg=false, item=ref false, menu=["Control", "extended typing (SMLserver)"], desc="When this flag is enabled, SMLserver requires\n\ @@ -80,64 +80,64 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS \constructed and written to the file scripts.gen.sml\n\ \prior to the actual type checking and compilation\n\ \of the project."} - ; Flags.is_on0 "extended_typing") + ; Flags.is_on0 "extended_typing") - val print_export_bases = - (Flags.add_bool_entry - {long="print_export_bases", short=SOME "Peb", neg=false, + val print_export_bases = + (Flags.add_bool_entry + {long="print_export_bases", short=SOME "Peb", neg=false, item=ref false, menu=["Debug", "print export bases"], desc="Controls printing of export bases."} - ; Flags.is_on0 "print_export_bases") + ; Flags.is_on0 "print_export_bases") - val print_closed_export_bases = - (Flags.add_bool_entry - {long="print_closed_export_bases", short=SOME "Pceb", neg=false, + val print_closed_export_bases = + (Flags.add_bool_entry + {long="print_closed_export_bases", short=SOME "Pceb", neg=false, item=ref false, menu=["Debug", "print closed export bases"], desc="Controls printing of closed export bases."} - ; Flags.is_on0 "print_closed_export_bases") - + ; Flags.is_on0 "print_closed_export_bases") + val run_file = ref "run" - val _ = Flags.add_string_entry + val _ = Flags.add_string_entry {long="output", short=SOME "o", item=run_file, menu=["File", "output file name"], desc="The name of the executable file generated by\n\ \the Kit."} - val _ = Flags.add_stringlist_entry + val _ = Flags.add_stringlist_entry {long="link_code", short=SOME "link", item=ref nil, menu=["File", "link files"], desc="Link-files to be linked together to form an\n\ \executable."} - val _ = Flags.add_stringlist_entry + val _ = Flags.add_stringlist_entry {long="link_code_scripts", short=SOME "link_scripts", item=ref nil, menu=["File", "link files scripts"], desc="Link-files for SMLserver scripts; link-files\n\ \specified with -link represent libraries when\n\ \mlkit is used with SMLserver."} - val _ = Flags.add_stringlist_entry + val _ = Flags.add_stringlist_entry {long="load_basis_files", short=SOME "load", item=ref nil, menu=["File", "Basis files to load before compilation"], desc="Basis files to be loaded before compilation\n\ \proper."} - val _ = Flags.add_stringlist_entry + val _ = Flags.add_stringlist_entry {long="mlb_path_maps", short=SOME"mlb-path-map", item=ref nil, menu=["File", "ML Basis path map files to use"], desc="ML Basis path map files to be used."} - val _ = Flags.add_string_entry + val _ = Flags.add_string_entry {long="namebase", short=NONE, item=ref "dummyBase", menu=["File", "Name base"], desc="Name base to enforce unique names when compiling\n\ \mlb-files."} - val print_post_elab_ast = - Flags.add_bool_entry - {long="print_post_elab_ast", short=SOME "Ppeast", neg=false, + val print_post_elab_ast = + Flags.add_bool_entry + {long="print_post_elab_ast", short=SOME "Ppeast", neg=false, item=ref false, menu=["Debug", "print ast after elaboation"], desc="Print ast after elaboration."} @@ -177,7 +177,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS val source_file = unitname_to_sourcefile unitname in if !log_to_file then let val log_stream = TextIO.openOut log_file - handle IO.Io {name=msg,...} => + handle IO.Io {name=msg,...} => die ("Cannot open log file\n\ \(non-exsisting directory or write-\ \protected existing log file?)\n" ^ msg) @@ -189,7 +189,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS in log_init(); log_cleanup end - else + else let val log_stream = TextIO.stdOut fun log_init() = Flags.log := log_stream fun log_cleanup() = Flags.log := old_log_stream @@ -203,8 +203,8 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun pr_st (st) : unit = PP.outputTree (print, st, 120) fun chat s = if !Flags.chat then log (s ^ "\n") else () fun chatf f = if !Flags.chat then log (f() ^ "\n") else () - - (* ------------------------------------------- + + (* ------------------------------------------- * Debugging and reporting * ------------------------------------------- *) @@ -217,7 +217,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS local (* Pickling *) - fun readFile f : string = + fun readFile f : string = let val is = BinIO.openIn f in let val v = BinIO.inputAll is val s = Byte.bytesToString v @@ -225,25 +225,25 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS end handle ? => (BinIO.closeIn is; raise ?) end - fun sizeToStr sz = + fun sizeToStr sz = if sz < 10000 then Int.toString sz ^ " bytes" - else if sz < 10000000 then Int.toString (sz div 1024) ^ "Kb (" ^ Int.toString sz ^ " bytes)" + else if sz < 10000000 then Int.toString (sz div 1024) ^ "Kb (" ^ Int.toString sz ^ " bytes)" else Int.toString ((sz div 1024) div 1024) ^ "Mb (" ^ Int.toString sz ^ " bytes)" - + type timer = (string * Timer.cpu_timer * Timer.real_timer) - + fun timerStart (s:string) : timer = (s,Timer.startCPUTimer(),Timer.startRealTimer()) - - fun timerReport ((s,cputimer,realtimer):timer) : unit = + + fun timerReport ((s,cputimer,realtimer):timer) : unit = let fun showTimerResult (s,{usr,sys},real) = - print ("\nTiming " ^ s ^ ":" - ^ "\n usr = " ^ Time.toString usr + print ("\nTiming " ^ s ^ ":" + ^ "\n usr = " ^ Time.toString usr ^ "\n sys = " ^ Time.toString sys ^ "\n real = " ^ Time.toString real ^ "\n") - in showTimerResult (s, Timer.checkCPUTimer cputimer, - Timer.checkRealTimer realtimer) + in showTimerResult (s, Timer.checkCPUTimer cputimer, + Timer.checkRealTimer realtimer) end handle _ => print "\ntimerReport.Uncaught exception\n" in fun targetFromSmlFile smlfile ext = @@ -262,13 +262,13 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun writeBasisJs punit B = let val s = Pickle.pickle Basis.pu B val punit = String.translate (fn #"." => "_" | c => String.str c) punit - val s = String.concat [punit, "_eb = ", + val s = String.concat [punit, "_eb = ", toJSString s, ";"] val file = targetFromSmlFile punit "eb.js" in writeTextFile file s end - + fun isFileContentStringBIN f s = let val is = BinIO.openIn f in ((Byte.bytesToString (BinIO.inputAll is) = s) @@ -295,7 +295,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun 'a doPickleGen (punit:string) (pu_obj: 'a Pickle.pu) (ext: string) (obj:'a) = let val res = doPickleGen0 punit pu_obj ext obj - val file = targetFromSmlFile punit ext + val file = targetFromSmlFile punit ext in writePickle file res end @@ -312,7 +312,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS case H.peek H i of SOME _ => nextAvailableKey(H,i+1) | NONE => i - in foldl (fn (n,i) => + in foldl (fn (n,i) => let val i = nextAvailableKey(H,i) in Name.assignKey(n,i) ; i + 1 @@ -321,7 +321,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS type name = Name.name - fun app2 f l1 l2 = (List.app f l1 ; List.app f l2) + fun app2 f l1 l2 = (List.app f l1 ; List.app f l2) fun 'a matchGen (match:'a*'a->'a) ((N,B:'a),(N0,B0:'a)) : name list * 'a = let val _ = app2 Name.mark_gen N N0 val B = match(B,B0) @@ -332,7 +332,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS val pu_names = Pickle.listGen Name.pu val pu_NB0 = Pickle.pairGen(pu_names,Basis.pu_Basis0) val pu_NB1 = Pickle.pairGen(pu_names,Basis.pu_Basis1) - + (* Before we determine not to write to disk, we need to check * that *both* NB0's and NB1's are identical. *) @@ -341,24 +341,24 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun rename (N,N') (N0,N1) = let (* How do we make sure that (N of NB0) U (N of NB1) are disjoint from - * (N U N') ? We do this by an explicit renaming of - * (N of NB0) to N0' and (N of NB1) to N1 such that (N0 U N1)(B0,B1,m) = (N0' U N1')(B0',B1',m') and - * N0 \cap N1 = \emptyset and (N0 U N1) \cap (N U N') = \emptyset. - * Idea: insert keys of members of N and N' in a hashSet; - * for each member n in (N of NB0 U N of NB1), starting with 1, - * pick a new key k not in hashSet and reset key(n) - * to k. This implements a capture free renaming of - * (N)(B,m) because basenames((N)(B,m)) \cap basenames(N) + * (N U N') ? We do this by an explicit renaming of + * (N of NB0) to N0' and (N of NB1) to N1 such that (N0 U N1)(B0,B1,m) = (N0' U N1')(B0',B1',m') and + * N0 \cap N1 = \emptyset and (N0 U N1) \cap (N U N') = \emptyset. + * Idea: insert keys of members of N and N' in a hashSet; + * for each member n in (N of NB0 U N of NB1), starting with 1, + * pick a new key k not in hashSet and reset key(n) + * to k. This implements a capture free renaming of + * (N)(B,m) because basenames((N)(B,m)) \cap basenames(N) * = \emptyset. This last assumption holds only because - * different basenames are used for eb and eb1 export + * different basenames are used for eb and eb1 export * bases. *) - val H : (int,unit) H.hash_table = + val H : (int,unit) H.hash_table = H.mkTable (fn x => x, op =) (31, Hexn) val _ = app2 (fn n => H.insert H (#1(Name.key n),())) N N' - val _ = renameN H N1 + val _ = renameN H N1 (renameN H N0 1) in () - end + end fun eqNB eqB ((N,B),(N',B')) = length N = length N' andalso eqB (B,B') @@ -366,36 +366,36 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS datatype when_to_pickle = NOT_STRING_EQUAL | NOT_ALPHA_EQUAL | ALWAYS val whenToPickle : when_to_pickle = NOT_STRING_EQUAL - fun doPickleNB smlfile (NB0,NB1) : unit = - let val (ext0,ext1) = ("eb","eb1") + fun doPickleNB smlfile (NB0,NB1) : unit = + let val (ext0,ext1) = ("eb","eb1") fun pickleBoth(NB0,NB1) = (doPickleGen smlfile pu_NB0 ext0 NB0; doPickleGen smlfile pu_NB1 ext1 NB1) - in case whenToPickle of + in case whenToPickle of ALWAYS => pickleBoth(NB0,NB1) - | NOT_STRING_EQUAL => + | NOT_STRING_EQUAL => let val f0 = targetFromSmlFile smlfile ext0 val f1 = targetFromSmlFile smlfile ext1 val p0 = doPickleGen0 smlfile pu_NB0 ext0 NB0 val p1 = doPickleGen0 smlfile pu_NB1 ext1 NB1 - in if (isFileContentStringBIN f0 p0 - andalso isFileContentStringBIN f1 p1) then + in if (isFileContentStringBIN f0 p0 + andalso isFileContentStringBIN f1 p1) then (chat "[No writing: valid pickle strings already in eb-files.]") else (writePickle f0 p0 ; writePickle f1 p1) end - | NOT_ALPHA_EQUAL => + | NOT_ALPHA_EQUAL => case (unpickleGen smlfile pu_NB0 ext0, unpickleGen smlfile pu_NB1 ext1) of (SOME NB0_0, SOME NB1_0) => - let val (NB0,NB1) = - let val () = rename (#1 NB0_0,#1 NB1_0) (#1 NB0,#1 NB1) + let val (NB0,NB1) = + let val () = rename (#1 NB0_0,#1 NB1_0) (#1 NB0,#1 NB1) val NB0 = matchGen Basis.matchBasis0 (NB0,NB0_0) val _ = List.app Name.mk_rigid (#1 NB0) val NB1 = matchGen Basis.matchBasis1 (NB1,NB1_0) val _ = List.app Name.mk_rigid (#1 NB1) in (NB0,NB1) end - in if eqNB Basis.eqBasis0 (NB0,NB0_0) andalso + in if eqNB Basis.eqBasis0 (NB0,NB0_0) andalso eqNB Basis.eqBasis1 (NB1,NB1_0) then () else pickleBoth(NB0,NB1) end @@ -403,22 +403,22 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS end fun doPickleLnkFile punit (modc: modcode) : unit = - doPickleGen punit ModCode.pu "lnk" modc + doPickleGen punit ModCode.pu "lnk" modc fun readLinkFiles lnkFiles = let fun process (nil,hce,modc) = modc | process (lf::lfs,hce,modc) = let val s = readFile lf handle _ => die ("readLinkFiles.error reading file " ^ lf) - val (modc',hce) = Pickle.unpickle' ModCode.pu hce s + val (modc',hce) = Pickle.unpickle' ModCode.pu hce s handle _ => die ("readLinkFiles.error deserializing link code for " ^ lf) val modc' = ModCode.dirMod (OS.Path.dir lf) modc' handle _ => die ("readLinkFiles.error during dirMod modc'") in process(lfs,hce,ModCode.seq(modc,modc')) end - in case lnkFiles of + in case lnkFiles of nil => ModCode.empty - | lf::lfs => + | lf::lfs => let val s = readFile lf handle _ => die ("readLinkFiles.error reading file " ^ lf) val hce = Pickle.empty_hce() @@ -426,11 +426,11 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS handle _ => die ("readLinkFiles.error deserializing link code for " ^ lf) val modc = ModCode.dirMod (OS.Path.dir lf) modc handle _ => die ("readLinkFiles.error during dirMod modc") - in process(lfs,hce,modc) - end + in process(lfs,hce,modc) + end end (* - fun doUnpickleBases ebfiles : Basis = + fun doUnpickleBases ebfiles : Basis = let val _ = chat "\n [Begin unpickling...]\n" fun process (nil,is,B) = B | process (ebfile::ebfiles,is,B) = @@ -440,18 +440,18 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS in process(ebfiles,is,Basis.plus(B,B')) end val B0 = Basis.initial() - val B = - case ebfiles of + val B = + case ebfiles of nil => B0 - | ebfile::ebfiles => + | ebfile::ebfiles => let val s = readFile ebfile val ((_,B),is) = Pickle.unpickler pu_NB (Pickle.fromString s) in process(ebfiles,is,Basis.plus(B0,B)) end handle _ => die ("doUnpickleBases. error \n") in B - end + end *) - fun doUnpickleBases0 ebfiles + fun doUnpickleBases0 ebfiles : Pickle.hce * {ebfile:string,infixElabBasis:InfixBasis*ElabBasis,used:bool ref}list = let val _ = chat "\n [Begin unpickling elaboration bases...]\n" fun process (nil,hce,acc) = (hce, rev acc) @@ -464,28 +464,28 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS in process(ebfiles,hce,entry::acc) end in - case ebfiles of + case ebfiles of nil => (Pickle.empty_hce(),nil) - | ebfile::ebfiles => - let val s = readFile ebfile handle _ => + | ebfile::ebfiles => + let val s = readFile ebfile handle _ => die("doUnpickleBases0.error reading file " ^ ebfile) val hce = Pickle.empty_hce() val ((_,infixElabBasis),hce) = Pickle.unpickle' pu_NB0 hce s - handle Fail st => - die("doUnpickleBases0.error unpickling infixElabBasis from file " + handle Fail st => + die("doUnpickleBases0.error unpickling infixElabBasis from file " ^ ebfile ^ ": Fail(" ^ st ^ "); sz(s) = " ^ Int.toString (size s)) - | e => - die("doUnpickleBases0.error unpickling infixElabBasis from file " + | e => + die("doUnpickleBases0.error unpickling infixElabBasis from file " ^ ebfile ^ ": " ^ General.exnMessage e) - val (hce, entries) = + val (hce, entries) = process(ebfiles,hce,[{ebfile=ebfile, infixElabBasis=infixElabBasis, used=ref false}]) in (hce, entries) end handle _ => die ("doUnpickleBases. error \n") - end + end - fun doUnpickleBases1 (hce: Pickle.hce) ebfiles : opaq_env * IntBasis = + fun doUnpickleBases1 (hce: Pickle.hce) ebfiles : opaq_env * IntBasis = let val _ = chat "\n [Begin unpickling compiler bases...]\n" fun process (nil,hce,basisPair) = basisPair | process (ebfile::ebfiles,hce,basisPair) = @@ -495,14 +495,14 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS end val basisPair0 = Basis.initialBasis1() in - case ebfiles of + case ebfiles of nil => basisPair0 - | ebfile::ebfiles => + | ebfile::ebfiles => let val s = readFile ebfile val ((_,basisPair),hce) = Pickle.unpickle' pu_NB1 hce s in process(ebfiles,hce,Basis.plusBasis1(basisPair0,basisPair)) end handle _ => die ("doUnpickleBases1. error \n") - end + end fun lnkFileConsistent {lnkFile} = let val s = readFile lnkFile @@ -526,11 +526,11 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS else () (* ------------------------------- - * Compute actual dependencies + * Compute actual dependencies * ------------------------------- *) fun lookup (look: ElabBasis -> 'a -> bool) elabBasesInfo (eb0:ElabBasis) (id:'a) = - let fun loop nil = + let fun loop nil = if look eb0 id then () else die "computing actual dependencies.lookup failed" | loop ({ebfile,infixElabBasis=(_,eb),used}::xs) = @@ -541,42 +541,42 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun collapse (longstrids,longtycons,longvids) = let fun exists e l = List.exists (fn x => x = e) l - fun ins e l = if exists e l then l else e::l - val strids = - foldl (fn (longstrid,acc) => + fun ins e l = if exists e l then l else e::l + val strids = + foldl (fn (longstrid,acc) => case StrId.explode_longstrid longstrid of (s::_,_) => ins s acc | (nil,s) => ins s acc) - nil longstrids - val (strids,tycons) = - foldl (fn (longtycon,(strids,tycons)) => + nil longstrids + val (strids,tycons) = + foldl (fn (longtycon,(strids,tycons)) => case TyCon.explode_LongTyCon longtycon of (s::_,_) => (ins s strids,tycons) - | (nil,tycon) => (strids,ins tycon tycons)) - (strids,nil) longtycons - val (strids,vids) = - foldl (fn (longvid,(strids,vids)) => + | (nil,tycon) => (strids,ins tycon tycons)) + (strids,nil) longtycons + val (strids,vids) = + foldl (fn (longvid,(strids,vids)) => case Ident.decompose longvid of (s::_,_) => (ins s strids,vids) - | (nil,vid) => (strids,ins vid vids)) - (strids,nil) longvids + | (nil,vid) => (strids,ins vid vids)) + (strids,nil) longvids in (vids,tycons,strids) end - - fun compute_actual_deps + + fun compute_actual_deps (eb0:ElabBasis) (elabBasesInfo:{ebfile:string,infixElabBasis:InfixBasis*ElabBasis,used:bool ref}list) {funids,sigids,longstrids,longtycons,longvids} = let val (vids,tycons,strids) = collapse (longstrids,longtycons,longvids) - fun look_vid B vid = Option.isSome + fun look_vid B vid = Option.isSome (Environments.VE.lookup(Environments.E.to_VE(ElabBasis.to_E B)) vid) - fun look_tycon B tycon = Option.isSome + fun look_tycon B tycon = Option.isSome (Environments.TE.lookup(Environments.E.to_TE(ElabBasis.to_E B)) tycon) - fun look_sigid B sigid = Option.isSome + fun look_sigid B sigid = Option.isSome (ModuleEnvironments.G.lookup(ElabBasis.to_G B) sigid) - fun look_funid B funid = Option.isSome + fun look_funid B funid = Option.isSome (ModuleEnvironments.F.lookup(ElabBasis.to_F B) funid) - fun look_strid B strid = Option.isSome + fun look_strid B strid = Option.isSome (Environments.SE.lookup(Environments.E.to_SE(ElabBasis.to_E B)) strid) (* look into newest basis first *) val rev_elabBasesInfo = rev elabBasesInfo @@ -590,14 +590,14 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun add_longstrid longstrid {funids, sigids, longstrids, longtycons, longvids} = let val longstrids = longstrid::longstrids - in {funids=funids, sigids=sigids, longstrids=longstrids, + in {funids=funids, sigids=sigids, longstrids=longstrids, longtycons=longtycons, longvids=longvids} end - + val intinfrep = StrId.mk_LongStrId ["IntInfRep"] (* ------------------------------------------------------------------- - * Build SML source file for mlb-project ; flag compile_only enabled + * Build SML source file for mlb-project ; flag compile_only enabled * ------------------------------------------------------------------- *) fun build_mlb_one (mlbfile, ebfiles, smlfile) : unit = @@ -605,7 +605,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS val _ = print("[reading source file:\t" ^ smlfile) val (unpickleStream, elabBasesInfo) = doUnpickleBases0 ebfiles val initialBasis0 = Basis.initialBasis0() - val (infB,elabB) = + val (infB,elabB) = List.foldl (fn ({infixElabBasis,...}, acc) => Basis.plusBasis0(acc,infixElabBasis)) initialBasis0 @@ -623,27 +623,27 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS val _ = Name.baseSet base val res = ParseElab.parse_elab {absprjid = abs_mlbfile, src = ParseElab.SrcFile smlfile, - infB = infB, elabB = elabB} - in (case res of - ParseElab.FAILURE (report, error_codes) => + infB = infB, elabB = elabB} + in (case res of + ParseElab.FAILURE (report, error_codes) => ( print "\n" ; print_error_report report ; raise PARSE_ELAB_ERROR error_codes) | ParseElab.SUCCESS {report,infB=infB',elabB=elabB',topdec} => - let + let val _ = maybe_print_topdec "AST after elaboration" topdec val _ = chat "[finding free identifiers begin...]" val freelongids = add_longstrid intinfrep (fid_topdec topdec) val _ = chat "[finding free identifiers end...]" val _ = chat "[computing actual dependencies begin...]" - val ebfiles_actual = compute_actual_deps + val ebfiles_actual = compute_actual_deps (#2 initialBasis0) elabBasesInfo freelongids val ebfiles_actual = map (fn x => x ^ "1") ebfiles_actual val _ = chat "[computing actual dependencies end...]" - val (B_im,_) = - let val (opaq_env,intB) = + val (B_im,_) = + let val (opaq_env,intB) = doUnpickleBases1 unpickleStream ebfiles_actual val B = Basis.mk(infB,elabB,opaq_env,intB) in Basis.restrict(B,freelongids) @@ -662,11 +662,11 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS val _ = chat "[opacity elimination end...]" val _ = maybe_print_topdec "AST after opacity elimination" topdec - + val _ = chat "[interpretation begin...]" val functor_inline = false - val (intB', modc) = - IntModules.interp(functor_inline, abs_mlbfile, + val (intB', modc) = + IntModules.interp(functor_inline, abs_mlbfile, intB_im, topdec', smlfile) val names_int = !Name.bucket val _ = List.app Name.mk_rigid names_int @@ -677,16 +677,16 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS val B' = Basis.mk(infB',elabB',opaq_env',intB') (* Construct export bases *) - val _ = + val _ = if print_export_bases() then ( print ("[Export basis for " ^ smlfile ^ " before closure:]\n") ; pr_st (MO.Basis.layout B') ; print "\n") else () - + val B'Closed = Basis.closure (B_im,B') - val _ = + val _ = if print_closed_export_bases() then ( print ("[Closed export basis for " ^ smlfile ^ ":]\n") ; pr_st (MO.Basis.layout B'Closed) @@ -699,14 +699,14 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS (names_int, (b3,b4))) end - (* Write export bases to disk if there are not + (* Write export bases to disk if there are not * already identical export bases on disk *) val _ = doPickleNB smlfile (NB0',NB1') val modc = ModCode.emit (abs_mlbfile,modc) val _ = doPickleLnkFile smlfile modc - (* Maybe write smlfile.eb.js to disk with export basis binding + (* Maybe write smlfile.eb.js to disk with export basis binding * for JavaScript loading *) val () = if export_basis_js() then writeBasisJs smlfile B'Closed else () @@ -715,29 +715,29 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS log_cleanup() end handle ? => (print_result_report report; raise ?) ) handle XX => (log_cleanup(); raise XX) - end + end -(* - fun smlserver_preprocess prj = +(* + fun smlserver_preprocess prj = if not(extendedtyping()) then prj else case Project.getParbody prj of NONE => prj - | SOME unitids => + | SOME unitids => let (* Parse scriptlets *) fun valspecToField (n,t) = {name=n,typ=t} val formIfaceFile = "scripts.gen.sml" val _ = print "[parsing arguments of scriptlet functors]\n" val formIfaces = map Scriptlet.parseArgsFile unitids - val formIfaces = - map (fn {funid,valspecs} => + val formIfaces = + map (fn {funid,valspecs} => {name=funid,fields=map valspecToField valspecs}) formIfaces val prj = Project.prependUnit (formIfaceFile,prj) val prj = Project.appendFunctorInstances prj in Scriptlet.genScriptletInstantiations formIfaces ; Scriptlet.genFormInterface formIfaceFile formIfaces - ; prj + ; prj end *) @@ -746,13 +746,13 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS in (TextIO.output(os,s); TextIO.closeOut os) handle X => (TextIO.closeOut os; raise X) - end + end (* ------------------------------------------------ * Link together lnk-files and generate executable * ------------------------------------------------ *) - fun objFileExt() = if MO.backend_name = "KAM" then ".uo" else ".o" + fun objFileExt() = if MO.backend_name = "KAM" then ".uo" else ".o" local fun fileFromSmlFile smlfile ext = let val {dir,file} = OS.Path.splitDirFile smlfile @@ -762,8 +762,8 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS end handle OS.Path.Path => die "fileFromSmlFile. Path" fun objFileFromSmlFile smlfile = fileFromSmlFile smlfile (objFileExt()) - - fun lnkFileFromSmlFile smlfile = + + fun lnkFileFromSmlFile smlfile = objFileFromSmlFile smlfile ^ ".lnk" in fun getUoFiles (smlfile:string) : string list = @@ -775,13 +775,13 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS structure MlbProject = MlbProject(ManagerObjects.Environment) structure UlFile = UlFile(MlbProject) - fun mlb_to_ulfile (f:string->string list) + fun mlb_to_ulfile (f:string->string list) {mlbfile:string} : string = let val ul = UlFile.from_mlbfile f mlbfile in UlFile.pp_ul ul end - fun link_lnk_files (mlbfile_opt:string option) : unit = + fun link_lnk_files (mlbfile_opt:string option) : unit = let val _ = chat "reading link files" val lnkFiles = Flags.get_stringlist_entry "link" val modc = readLinkFiles lnkFiles @@ -791,15 +791,15 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS let val _ = chat "creating ul file" val s = mlb_to_ulfile getUoFiles {mlbfile=mlbfile} val ulfile = !run_file - in writeAll(ulfile,s) + in writeAll(ulfile,s) ; print("[wrote file " ^ ulfile ^ "]\n") end - | NONE => + | NONE => let val lnkFilesScripts = Flags.get_stringlist_entry "link_scripts" - val modc_scripts = readLinkFiles lnkFilesScripts + val modc_scripts = readLinkFiles lnkFilesScripts in ModCode.makeUlfile (!run_file,modc,ModCode.seq(modc,modc_scripts)) end) - else + else (chat "making executable"; ModCode.mk_exe_all_emitted(modc, nil, !run_file)) end @@ -810,7 +810,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS exception IsolateFunExn of int - structure MlbPlugIn : MLB_PLUGIN = + structure MlbPlugIn : MLB_PLUGIN = struct local local @@ -820,11 +820,22 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun remove pid = pids := (List.mapPartial (fn p => if p = pid then NONE else SOME p) (!pids)) fun killrest () = (List.app (fn p => Posix.Process.kill (Posix.Process.K_PROC p, Posix.Signal.term)) (!pids) ; List.app (fn p => ignore (Posix.Process.waitpid (Posix.Process.W_CHILD p,[]))) (!pids) ; - pids := []) + pids := []) end + fun ppSignal s = + let open Posix.Signal + val ss = [(abrt,"abrt"),(alrm,"alrm"),(bus,"bus"),(fpe,"fpe"),(hup,"hup"),(ill,"ill"), + (int,"int"),(kill,"kill"),(pipe,"pipe"),(quit,"quit"),(segv,"segv"),(term,"term"), + (usr1,"usr1"),(usr2,"usr2"),(chld,"chld"),(cont,"cont"),(stop,"stop"),(tstp,"tstp"), + (ttin,"ttin"),(ttou,"ttou")] + in case List.find (fn (s',_) => s=s') ss of + SOME (_,str) => str + | NONE => "unknown" + end fun failSig s signal = - raise Fail ("isolate error: " ^ s ^ "(" ^ - SysWord.toString (Posix.Signal.toWord signal) ^ ")") + raise Fail ("isolate error: " ^ s ^ "(HEX:" ^ + SysWord.toString (Posix.Signal.toWord signal) ^ ", " ^ + ppSignal signal ^ ")") fun errSubProcess e = (print "[[ERR in sub process:\n "; print (General.exnMessage e ^ "]]\n")) @@ -835,13 +846,13 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS | NONE => ((f a ; Posix.Process.exit 0w0) handle e => (errSubProcess e; Posix.Process.exit 0w1)) - fun wait p = + fun wait p = let val (pid,st) = case p of NONE => Posix.Process.wait() | SOME p => Posix.Process.waitpid (Posix.Process.W_CHILD p,[]) in - case st + case st of Posix.Process.W_EXITED => (remove pid ; pid) | Posix.Process.W_EXITSTATUS n => (remove pid ; killrest (); raise IsolateFunExn (Word8.toInt n)) | Posix.Process.W_STOPPED s => (remove pid ; killrest (); failSig "W_STOPPED" s) @@ -852,7 +863,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS case Posix.Process.fork() of SOME pid => (* parent *) let val (pid2,status) = Posix.Process.waitpid (Posix.Process.W_CHILD pid,[]) - in if pid2 = pid then + in if pid2 = pid then (case status of Posix.Process.W_EXITED => () | Posix.Process.W_EXITSTATUS n => raise IsolateFunExn (Word8.toInt n) @@ -861,7 +872,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS else raise Fail "isolate error 2" end | NONE => (f a before Posix.Process.exit 0w0 (* child *) - handle e => + handle e => (errSubProcess e; Posix.Process.exit 0w1)) @@ -869,12 +880,12 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS local fun unlock lockfile = (Posix.FileSys.unlink lockfile) handle _ => () - fun lock unique lockfile = + fun lock unique lockfile = let - val fu = - (Posix.IO.close (Posix.FileSys.creat (lockfile ^ unique,Posix.FileSys.S.iwusr)) ; true) + val fu = + (Posix.IO.close (Posix.FileSys.creat (lockfile ^ unique,Posix.FileSys.S.iwusr)) ; true) handle OS.SysErr _ => false - val f = if fu then + val f = if fu then (Posix.FileSys.link{old=lockfile ^ unique, new=lockfile}; true) handle OS.SysErr _ => Posix.FileSys.ST.nlink (Posix.FileSys.stat (lockfile ^ unique)) = 2 else false @@ -902,11 +913,11 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS (fn () => (isolate2 (compile0 target flags lockfile (Int.toString unique)) (namebase, basisFiles, source))) end - val getParallelN = + val getParallelN = Flags.add_int_entry {long="parallel_compilation", short = SOME "j", menu=["Control", "number of parallel compilation processes"], - item=ref 1, + item=ref 1, desc="The maximum number of parallel processes used\n\ \for compilation." } @@ -924,15 +935,15 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun mlbdir() = MO.mlbdir() val objFileExt = objFileExt - + fun maybeSetRegionEffectVarCounter n = - let + let val b = region_profiling() val _ = if b then Flags.lookup_int_entry "regionvar" := n else () - in b + in b end - + val lnkFileConsistent = lnkFileConsistent end (* struct *) @@ -940,20 +951,20 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS structure MlbMake = MlbMake(structure MlbProject = MlbProject structure MlbPlugIn = MlbPlugIn val verbose = Flags.is_on0 "chat" - val oneSrcFile : string option ref = ref NONE) + val oneSrcFile : string option ref = ref NONE) - datatype source = SML of string | MLB of string | WRONG_FILETYPE of string + datatype source = SML of string | MLB of string | WRONG_FILETYPE of string - fun determine_source (s:string) : source = + fun determine_source (s:string) : source = let fun wrong s = WRONG_FILETYPE ("File name must have extension '.mlb', '.sml', or '.sig'.\n" ^ "*** The file name you gave me has " ^ s) - in case OS.Path.ext s of + in case OS.Path.ext s of SOME "mlb" => MLB s | SOME ext => if Flags.has_sml_source_ext ext then SML s else wrong ("extension " ^ quot ext ^ ".") | NONE => wrong ("no extension.") end - + val import_basislib = Flags.is_on0 "import_basislib" fun gen_wrap_mlb smlfilepath = let val mlb_filepath = OS.Path.base smlfilepath ^ ".auto.mlb" @@ -962,11 +973,11 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS val basislib = !Flags.install_dir ## "basis/basis.mlb" val _ = chatf (fn() => "Using basis library " ^ quot basislib) val smlfile = OS.Path.file smlfilepath - val body = + val body = if import_basislib() then "local " ^ basislib ^ " in " ^ smlfile ^ " end" else smlfile - in + in let val _ = TextIO.output(os, body) val _ = TextIO.closeOut os in mlb_filepath @@ -974,23 +985,23 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS end fun comp0 file : unit = - if Flags.get_stringlist_entry "link" <> nil then + if Flags.get_stringlist_entry "link" <> nil then link_lnk_files NONE else - case determine_source file of - SML s => + case determine_source file of + SML s => if Flags.is_on "compile_only" then let val ebfiles = Flags.get_stringlist_entry "load_basis_files" val namebase = Flags.get_string_entry "namebase" in build_mlb_one (namebase, ebfiles, s) end - else + else let val mlb_file = gen_wrap_mlb s val _ = comp0 mlb_file handle X => (OS.FileSys.remove mlb_file; raise X) in OS.FileSys.remove mlb_file end - | MLB s => + | MLB s => let val target = if !Flags.SMLserver then let val {dir,file} = OS.Path.splitDirFile s @@ -998,15 +1009,15 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS in dir ## MO.mlbdir() ## (OS.Path.base file ^ ".ul") end else Flags.get_string_entry "output" - in - (MlbMake.build{flags="",mlbfile=s,target=target} + in + (MlbMake.build{flags="",mlbfile=s,target=target} handle Fail s => raise Fail s | OS.SysErr (s,_) => (print "Stopping compilation due to system error:\n"; print ("SysErr(" ^ s ^ ")\n"); raise PARSE_ELAB_ERROR nil) | IsolateFunExn n => - (print ("Stopping compilation of MLB-file due to error (code " + (print ("Stopping compilation of MLB-file due to error (code " ^ Int.toString n ^ ").\n"); raise PARSE_ELAB_ERROR nil) | ? => (print "Stopping compilation due to errors.\n"; @@ -1014,14 +1025,14 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS raise PARSE_ELAB_ERROR nil)) end | WRONG_FILETYPE s => raise Fail s - + val timingfile = "KITtimings" fun comp file : unit = if Flags.is_on "compiler_timings" then let val os = (TextIO.openOut (timingfile) handle _ => (print ("Error: I could not open file `" ^ timingfile ^ "' for writing"); raise PARSE_ELAB_ERROR nil)) - fun close () = (TextIO.closeOut os; + fun close () = (TextIO.closeOut os; Flags.timings_stream := NONE; print ("[wrote compiler timings file: " ^ timingfile ^ "]\n")) in Flags.timings_stream := SOME os; diff --git a/src/Runtime/Export.c b/src/Runtime/Export.c index bae673513..35b13bdf1 100644 --- a/src/Runtime/Export.c +++ b/src/Runtime/Export.c @@ -5,7 +5,7 @@ #include "../CUtils/polyhashmap.h" #include "../CUtils/hashfun.h" #include "Export.h" - +#include "CommandLine.h" static int charEqual(const char *a, const char *b) @@ -27,10 +27,10 @@ sml_regCfuns(String name,void *f) // printf("sml_regCfuns %s\n", &(name->data)); if (!exportmap) { - exportmap = (exportmap_hashtable_t *) malloc(sizeof (exportmap_hashtable_t)); + exportmap = exportmap_new(); if (!exportmap) return; - exportmap_init(exportmap); } + e = &(name->data); if (exportmap_find(exportmap, e, &f1) == hash_DNE) { @@ -42,20 +42,24 @@ sml_regCfuns(String name,void *f) return; } -int -callExportFun(const char *fun, int i) +long +callExportFun(const char *fun, long i) { - // printf("callExportFun %s\n", fun); - if (!exportmap) return -1; + long res = -1; +#ifdef ENABLE_GC + long disable_gc_save = disable_gc; + disable_gc = 0; +#endif + //printf("callExportFun %s\n", fun); + if (!exportmap) return res; const void *f1; - int (*f2)(int); - if (exportmap_find(exportmap, fun, &f1) == hash_OK) - { + long (*f2)(long); + if (exportmap_find(exportmap, fun, &f1) == hash_OK) { f2 = f1; - return ((*f2)(i)); - } - else - { - return -1; + res = ((*f2)(i)); } +#ifdef ENABLE_GC + disable_gc = disable_gc_save; +#endif + return res; } diff --git a/src/Runtime/Export.h b/src/Runtime/Export.h index 15284949e..fd71ac634 100644 --- a/src/Runtime/Export.h +++ b/src/Runtime/Export.h @@ -1,3 +1,3 @@ -int callExportFun(const char *fun, int i); +long callExportFun(const char *fun, long i); diff --git a/src/Runtime/Flags.h b/src/Runtime/Flags.h index 8b6eec3aa..016ea2e90 100644 --- a/src/Runtime/Flags.h +++ b/src/Runtime/Flags.h @@ -41,4 +41,3 @@ #endif #endif /*FLAGS*/ - diff --git a/src/Runtime/GC.c b/src/Runtime/GC.c index ebfcc3f48..77c7729b5 100644 --- a/src/Runtime/GC.c +++ b/src/Runtime/GC.c @@ -2,8 +2,7 @@ * Garbage Collection * *----------------------------------------------------------------*/ -#define CHECK_GC 1 -#ifdef ENABLE_GC +#ifdef ENABLE_GC #include #include @@ -26,7 +25,7 @@ #include "GC.h" size_t time_to_gc = 0; // set to 1 by alloc if GC should occur at next - // function invocation + // function invocation size_t *stack_bot_gc = NULL; // bottom and top of stack -- used during GC to size_t *stack_top_gc; // determine if a value is stack-allocated size_t to_space_old = 0; // size of to-space (live) at previous GC @@ -68,8 +67,13 @@ ssize_t major_p = 0; // flag to specify whether gc should b #define is_minor_p (major_p == 0) #endif // ENABLE_GEN_GC -// This implementation assumes a down growing stack (e.g., X86) +// This implementation assumes a down growing stack (e.g., X64) + +#if defined(__LP64__) || (__WORDSIZE == 64) +#define NUM_REGS 16 +#else #define NUM_REGS 8 +#endif /* Layout of stack: @@ -86,7 +90,7 @@ ssize_t major_p = 0; // flag to specify whether gc should b FD end | FD begin - Return Address pointing at value HEX: FFFFFFFF (no more FDs*) */ + Return Address pointing at value HEX: FFFF_FFFF_FFFF_FFFF (no more FDs*) */ /* Layout of FD in the code: @@ -109,11 +113,12 @@ Rp *from_space_begin, *from_space_end; /*******************/ /* PRETTY PRINTING */ /*******************/ -static void -pw(char *s,unsigned int tag) +static void +pw(char *s,unsigned long int tag0) { int idx; - + unsigned int tag = (unsigned int)tag0; // discharge highest bits... + printf("%s(%x) is ",s,tag); for (idx=0;idx<32;idx++) { if (tag & 0x80000000) @@ -126,8 +131,8 @@ pw(char *s,unsigned int tag) return; } -static void -print(uintptr_t *value) +static void +print(uintptr_t *value) { char str[50]; size_t val; @@ -161,13 +166,13 @@ print(uintptr_t *value) return; } -// #define copy_words(from,to,w) (memcpy((to),(from),4*(w))) +// #define copy_words(from,to,w) (memcpy((to),(from),sizeof(void *)*(w))) -inline static void -copy_words(uintptr_t *from,uintptr_t *to,size_t num) +inline static void +copy_words(uintptr_t *from,uintptr_t *to,size_t num) { size_t i; - for ( i = 0 ; i < num ; i++ ) + for ( i = 0 ; i < num ; i++ ) *(to + i) = *(from + i); return; } @@ -180,10 +185,10 @@ uintptr_t **scan_stack = NULL; long size_scan_stack; long scan_sp; -inline static void -init_scan_stack() +inline static void +init_scan_stack() { - if (scan_stack == NULL) + if (scan_stack == NULL) { scan_stack = (uintptr_t **) realloc((void *)scan_stack, INIT_STACK_SIZE_W*(sizeof(void *))); if (scan_stack == NULL) @@ -198,12 +203,12 @@ init_scan_stack() #define is_scan_stack_empty() (scan_sp == 0) -inline static void -push_scan_stack(uintptr_t *ptr) +inline static void +push_scan_stack(uintptr_t *ptr) { scan_stack[scan_sp] = ptr; scan_sp++; - if ( scan_sp >= size_scan_stack ) + if ( scan_sp >= size_scan_stack ) { size_scan_stack *= 2; scan_stack = (uintptr_t **) realloc((void *)scan_stack, size_scan_stack*(sizeof(void *))); @@ -216,9 +221,9 @@ push_scan_stack(uintptr_t *ptr) } inline static uintptr_t * -pop_scan_stack() +pop_scan_stack() { - if ( scan_sp < 1 ) + if ( scan_sp < 1 ) { die("GC.pop_scan_stack: scan_sp below stack bot."); } @@ -235,10 +240,10 @@ long size_scan_container; long container_alloc; long container_scan; -inline static void -init_scan_container() +inline static void +init_scan_container() { - if (scan_container == NULL) + if (scan_container == NULL) { scan_container = (uintptr_t **) realloc((void *)scan_container, INIT_CONTAINER_SIZE_W*(sizeof(void *))); if (scan_container == NULL) @@ -254,19 +259,19 @@ init_scan_container() #define is_scan_container_empty() (container_scan == container_alloc) -inline static void -push_scan_container(uintptr_t *ptr) +inline static void +push_scan_container(uintptr_t *ptr) { - // printf("push_scan_container(%p) - size_scan_container=%d; container_alloc=%d; container_scan=%d\n", + // printf("push_scan_container(%p) - size_scan_container=%d; container_alloc=%d; container_scan=%d\n", // ptr, size_scan_container, container_alloc, container_scan); //print(ptr); //printf("\n"); scan_container[container_alloc] = ptr; container_alloc++; - if (container_alloc >= size_scan_container) + if (container_alloc >= size_scan_container) { size_scan_container *= 2; - scan_container = (uintptr_t **) realloc((void *)scan_container, size_scan_container*4); + scan_container = (uintptr_t **) realloc((void *)scan_container, size_scan_container*sizeof(void *)); if (scan_container == NULL) { die("GC.push_scan_container: Unable to increase scan_container"); @@ -276,7 +281,7 @@ push_scan_container(uintptr_t *ptr) } inline static uintptr_t * -pop_scan_container() +pop_scan_container() { uintptr_t *v; v = scan_container[container_scan]; @@ -284,8 +289,8 @@ pop_scan_container() return v; } -inline static void -clear_scan_container() +inline static void +clear_scan_container() { long i; for ( i = 0 ; i < container_alloc ; i ++ ) @@ -294,7 +299,7 @@ clear_scan_container() } } -void pp_from_space() +void pp_from_space() { Rp *rp; @@ -314,7 +319,7 @@ void pp_from_space() // We mark all region pages such that we can distinguish them from // to-space region pages by setting a bit in the next n pointer. static inline void -mk_from_space_gen(Gen *gen) +mk_from_space_gen(Gen *gen) { // Move region pages to from-space (((Rp *)gen->b)-1)->n = from_space_begin; @@ -334,7 +339,7 @@ mk_from_space_gen(Gen *gen) alloc_new_block(gen); } -static void mk_from_space() +static void mk_from_space() { Ro *r; @@ -345,12 +350,12 @@ static void mk_from_space() from_space_begin = NULL; from_space_end = (((Rp *)TOP_REGION->g0.b)-1); // Points at last region page - for( r = TOP_REGION ; r ; r = r->p ) + for( r = TOP_REGION ; r ; r = r->p ) { #ifdef PROFILING // Similar to resetRegion in Region.c #ifdef ENABLE_GEN_GC - if ( is_major_p ) + if ( is_major_p ) { #endif // ENABLE_GEN_GC j = NoOfPagesInRegion(r); @@ -381,34 +386,29 @@ static void mk_from_space() mk_from_space_gen(&(r->g0)); #ifdef ENABLE_GEN_GC - if ( is_major_p ) + if ( is_major_p ) mk_from_space_gen(&(r->g1)); #endif // ENABLE_GEN_GC } return; } -inline static int -points_into_dataspace (uintptr_t *p) { - return (p >= data_begin_addr) && (p <= data_end_addr); -} - #define is_stack_allocated(obj_ptr) (((obj_ptr) <= stack_bot_gc) && (((obj_ptr) >= stack_top_gc))) #define is_integer(obj_ptr) ((obj_ptr) & 1) -#define is_forward_ptr(x) (((x) & 0x03) == 0) /* Bit 0 and 1 must be zero */ +#define is_forward_ptr(x) (((x) & 0x3) == 0) /* Bit 0 and 1 must be zero */ #define clear_forward_ptr(x) (x) #define tag_forward_ptr(x) ((unsigned long)(x)) // Region pages are of size 1Kb and aligned -#define get_rp_header(x) ((Rp *)(((unsigned long)(x)) & 0xFFFFFC00)) +#define get_rp_header(x) ((Rp *)(((unsigned long)(x)) & 0xFFFFFFFFFFFFFC00)) -size_t +size_t size_lobj (size_t tag) { switch ( tag_kind(tag) ) { case TAG_STRING: { size_t sz_bytes; - sz_bytes = get_string_size(tag) + 1 + (sizeof(void *)); // 1 for zero-termination, 4 for size field + sz_bytes = get_string_size(tag) + 1 + (sizeof(void *)); // 1 for zero-termination, sizeof(void *) for size field return sz_bytes%(sizeof(void *)) ? (sizeof(void *))+(sizeof(void *))*(sz_bytes/(sizeof(void *))) : sz_bytes; // alignment } case TAG_TABLE: @@ -424,9 +424,9 @@ size_lobj (size_t tag) static inline long end_of_region_page_or_full(uintptr_t* s, uintptr_t* a, Rp* rp) { - return (s != a) - && ((s == ((uintptr_t *)rp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE) - || (*s == notPP)); + return (s != a) + && ((s == ((uintptr_t *)rp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE) + || (*s == notPP)); } inline static uintptr_t* @@ -459,8 +459,8 @@ next_untagged_value(uintptr_t* s, uintptr_t* a) { * Find allocated bytes in generations/regions; for measurements * -------------------------------------------------------------- */ -static int -allocated_bytes_in_gen(Gen *gen) +static long +allocated_bytes_in_gen(Gen *gen) { uintptr_t *s; // scan pointer Rp *rp; @@ -502,10 +502,10 @@ allocated_bytes_in_gen(Gen *gen) allocated_bytes += (sizeof(void *)); break; } - case TAG_CON1: + case TAG_CON1: case TAG_REF: { s += 2; - allocated_bytes += 8; + allocated_bytes += ((sizeof(void *))*2); break; } default: { @@ -528,10 +528,10 @@ allocated_bytes_in_gen(Gen *gen) return allocated_bytes; } -// Assumes that region does not contain untagged pairs or +// Assumes that region does not contain untagged pairs or // untagged refs -static int -allocated_bytes_in_region(Region r) +static long +allocated_bytes_in_region(Region r) { return allocated_bytes_in_gen(&(r->g0)) #ifdef ENABLE_GEN_GC @@ -540,24 +540,24 @@ allocated_bytes_in_region(Region r) ; } -static inline int +static inline long allocated_bytes_in_gen_untagged(Gen *gen, int obj_sz) // obj_sz is in words { Rp* rp; - int n = 0; + long n = 0; for ( rp = clear_fp(gen->fp) ; rp ; rp = clear_tospace_bit(rp->n) ) { if ( clear_tospace_bit(rp->n) ) // Take care of alignment - n += 4 * obj_sz * (ALLOCATABLE_WORDS_IN_REGION_PAGE / obj_sz); // not last page + n += sizeof(void *) * obj_sz * (ALLOCATABLE_WORDS_IN_REGION_PAGE / obj_sz); // not last page else - n += 4 * ((gen->a) - (rp->i)); // last page + n += sizeof(void *) * ((gen->a) - (rp->i)); // last page } return n; } -static int -allocated_bytes_in_region_untagged(Ro* r, int obj_sz) // obj_sz is in words +static long +allocated_bytes_in_region_untagged(Ro* r, long obj_sz) // obj_sz is in words { return allocated_bytes_in_gen_untagged(&(r->g0),obj_sz) #ifdef ENABLE_GEN_GC @@ -566,10 +566,10 @@ allocated_bytes_in_region_untagged(Ro* r, int obj_sz) // obj_sz is in words ; } -static int -allocated_bytes_in_regions(void) +static long +allocated_bytes_in_regions(void) { - int n = 0; + long n = 0; Ro* r; for ( r = TOP_REGION ; r ; r = r->p ) { @@ -582,7 +582,7 @@ allocated_bytes_in_regions(void) break; case RTYPE_TRIPLE: n += allocated_bytes_in_region_untagged(r,3); - break; + break; default: n += allocated_bytes_in_region(r); } @@ -590,17 +590,17 @@ allocated_bytes_in_regions(void) return n; } -static int -allocated_bytes_in_lobjs(void) +static long +allocated_bytes_in_lobjs(void) { - int n = 0; + long n = 0; Ro* r; Lobjs *lobjs; for ( r = TOP_REGION ; r ; r = r->p ) - for ( lobjs = r->lobjs ; lobjs ; lobjs = clear_lobj_bit(lobjs->next) ) + for ( lobjs = r->lobjs ; lobjs ; lobjs = clear_lobj_bit(lobjs->next) ) { - unsigned int tag; + unsigned long tag; #ifdef PROFILING tag = *(&(lobjs->value) + sizeObjectDesc); #else @@ -614,20 +614,20 @@ allocated_bytes_in_lobjs(void) // Find the number of allocated pages in a region/generation -static int -allocated_pages_in_gen(Gen *gen) +static long +allocated_pages_in_gen(Gen *gen) { - int n = 0; + long n = 0; Rp *rp; - + // Maybe the generation-bit is set for ( rp = clear_fp(gen->fp) ; rp ; rp = clear_tospace_bit(rp->n) ) n++; return n; } -static int -allocated_pages_in_region(Region r) +static long +allocated_pages_in_region(Region r) { return allocated_pages_in_gen(&(r->g0)) #ifdef ENABLE_GEN_GC @@ -636,10 +636,10 @@ allocated_pages_in_region(Region r) ; } -static int -allocated_pages_in_regions(void) +static long +allocated_pages_in_regions(void) { - int n = 0; + long n = 0; Ro* r; for ( r = TOP_REGION ; r ; r = r->p ) { @@ -651,8 +651,8 @@ allocated_pages_in_regions(void) #ifdef CHECK_GC #ifdef ENABLE_GEN_GC // Check for no tospace-bits -static void -chk_no_tospacebits_gen(Gen *gen) +static void +chk_no_tospacebits_gen(Gen *gen) { Rp *rp; for ( rp = clear_fp(gen->fp) ; rp ; rp = clear_tospace_bit(rp->n) ) @@ -665,7 +665,7 @@ chk_no_tospacebits_gen(Gen *gen) } static void -chk_no_tospacebits_region(Region r) +chk_no_tospacebits_region(Region r) { chk_no_tospacebits_gen(&(r->g0)); #ifdef ENABLE_GEN_GC @@ -678,7 +678,7 @@ chk_no_tospacebits_region(Region r) } static void -chk_no_tospacebits_regions(void) +chk_no_tospacebits_regions(void) { Ro* r; for ( r = TOP_REGION ; r ; r = r->p ) @@ -696,8 +696,8 @@ chk_no_tospacebits_regions(void) // a descriptor at offset 0. This function is never used to determine // the size of an untagged pair, an untagged triple, or an untagged // ref. -inline static ssize_t -get_size_obj(uintptr_t *obj_ptr) +inline static ssize_t +get_size_obj(uintptr_t *obj_ptr) { switch (val_tag_kind_const(obj_ptr)) { case TAG_RECORD: return get_record_size(*obj_ptr) + 1; @@ -705,12 +705,12 @@ get_size_obj(uintptr_t *obj_ptr) case TAG_CON1: case TAG_REF: return 2; case TAG_TABLE: return get_table_size(*obj_ptr) + 1; - case TAG_STRING: + case TAG_STRING: { - ssize_t size = get_string_size(*obj_ptr) + 1 + (sizeof(void *)); // 1 for zero-termination, 4 for tag + ssize_t size = get_string_size(*obj_ptr) + 1 + (sizeof(void *)); // 1 for zero-termination, sizeof(void *) for tag return size%(sizeof(void *)) ? 1 + (size/(sizeof(void *))) : size/(sizeof(void *)); // alignment } - default: + default: { pw("Tag: ", *obj_ptr); print(obj_ptr); @@ -722,16 +722,16 @@ get_size_obj(uintptr_t *obj_ptr) // ToDo: GenGC remove print_tagged_rp_content /* -void +void print_tagged_rp_content(Rp *rp) -{ +{ unsigned int *obj_ptr; fprintf(stderr,"[tagged rp content...\n"); - for (obj_ptr = (unsigned int*)(&(rp->i)) + for (obj_ptr = (unsigned int*)(&(rp->i)) ; obj_ptr < (unsigned int*)(rp+1) && obj_ptr != notPP ; obj_ptr = obj_ptr + get_size_obj(obj_ptr)) - { + { fprintf(stderr,"Addr: %p - ",obj_ptr); print(obj_ptr); } @@ -742,12 +742,12 @@ print_tagged_rp_content(Rp *rp) /* ToDo: GenGC (1) allok skal tage højde for colorPtr - (2) allok skal tage højde for om g1 indeholder en klump. + (2) allok skal tage højde for om g1 indeholder en klump. gælder for alle acopy-funktioner MEMO: What does this comment mean? */ inline static uintptr_t * -acopy(Gen *gen, uintptr_t *obj_ptr) +acopy(Gen *gen, uintptr_t *obj_ptr) { ssize_t size; uintptr_t *new_obj_ptr; @@ -774,7 +774,7 @@ acopy(Gen *gen, uintptr_t *obj_ptr) } inline static uintptr_t * -acopy_pair(Gen *gen, uintptr_t *obj_ptr) +acopy_pair(Gen *gen, uintptr_t *obj_ptr) { uintptr_t *new_obj_ptr; @@ -791,7 +791,7 @@ acopy_pair(Gen *gen, uintptr_t *obj_ptr) } inline static uintptr_t * -acopy_ref(Gen *gen, uintptr_t *obj_ptr) +acopy_ref(Gen *gen, uintptr_t *obj_ptr) { uintptr_t *new_obj_ptr; @@ -807,7 +807,7 @@ acopy_ref(Gen *gen, uintptr_t *obj_ptr) } inline static uintptr_t * -acopy_triple(Gen *gen, uintptr_t *obj_ptr) +acopy_triple(Gen *gen, uintptr_t *obj_ptr) { uintptr_t *new_obj_ptr; @@ -825,7 +825,7 @@ acopy_triple(Gen *gen, uintptr_t *obj_ptr) } static int -points_into_tospace (uintptr_t x) +points_into_tospace (uintptr_t x) { uintptr_t *p; @@ -833,9 +833,14 @@ points_into_tospace (uintptr_t x) if ( is_integer(x) ) return 0; p = (uintptr_t *)x; - if ( is_stack_allocated(p) ) + if ( points_into_dataspace(p) ) { + #ifdef CHECK_GC + if ( is_stack_allocated(p) ) + die ("GC: p is both on stack and in dataspace!"); + #endif // CHECK_GC return 0; - if ( points_into_dataspace(p) ) + } + if ( is_stack_allocated(p) ) return 0; // now either large object or in region rp = get_rp_header(p); @@ -859,8 +864,8 @@ points_into_tospace (uintptr_t x) // colorPtr's in old generations are updated after each gc - the // reason is that the mutator never allocates values in old // generations. - - if ( is_minor_p && is_gen_1(*(rp->gen)) ) + + if ( is_minor_p && is_gen_1(*(rp->gen)) ) { switch ( rtype(*(rp->gen)) ) { @@ -886,17 +891,17 @@ points_into_tospace (uintptr_t x) // allocation (Region.c) when gc is enabled. For the old // generation, however, it is not sufficient to check the // tospace-bit in a region page to determine if the object (in - // the page) is part of to-space (see comment above). + // the page) is part of to-space (see comment above). return is_tospace_bit(rp->n); } -inline static Gen * +inline static Gen * target_gen(Gen *gen, Rp *rp, uintptr_t *obj_ptr) { #ifdef ENABLE_GEN_GC // We could also choose first to ask if gen is g1 (old generation) // - in this case we could return gen immediately - if ( obj_ptr < rp->colorPtr ) + if ( obj_ptr < rp->colorPtr ) return &(get_ro_from_gen(*gen)->g1); // old gen #ifdef CHECK_GC if ( is_gen_1(*gen) ) @@ -910,31 +915,35 @@ target_gen(Gen *gen, Rp *rp, uintptr_t *obj_ptr) return gen; } -static uintptr_t -evacuate(uintptr_t obj) +static uintptr_t +evacuate(uintptr_t obj) { Rp* rp; Gen* gen; Gen* copy_to_gen; uintptr_t *obj_ptr, *new_obj_ptr; - if (is_integer(obj)) + if (is_integer(obj)) { return obj; // not subject to GC } - obj_ptr = (uintptr_t *)obj; // object is a pointer + obj_ptr = (uintptr_t *)obj; // object is a pointer if ( points_into_dataspace(obj_ptr) ) { + #ifdef CHECK_GC + if ( is_stack_allocated(obj_ptr) ) + die ("GC: obj_ptr is both on stack and in dataspace!"); + #endif // CHECK_GC return obj; // not subject to GC } - if ( is_stack_allocated(obj_ptr) ) + if ( is_stack_allocated(obj_ptr) ) { // object immovable - if ( is_const(*obj_ptr) ) + if ( is_const(*obj_ptr) ) { - return obj; + return obj; } *obj_ptr = set_tag_const(*obj_ptr); // set immovable-bit push_scan_container(obj_ptr); @@ -963,10 +972,10 @@ evacuate(uintptr_t obj) } // Object is in an infinite region - gen = rp->gen; + gen = rp->gen; #ifdef ENABLE_GEN_GC if (is_minor_p && is_gen_1(*gen)) // old generation - { + { // obj_ptr points at old area in g1 and should be returned! return obj; } @@ -978,15 +987,15 @@ evacuate(uintptr_t obj) if ( points_into_tospace(*(obj_ptr+1)) ) // check for forward pointer return *(obj_ptr+1); // obj_ptr points at slot before the actual value - copy_to_gen = target_gen(gen, rp, obj_ptr+1); + copy_to_gen = target_gen(gen, rp, obj_ptr+1); new_obj_ptr = acopy_pair(copy_to_gen, obj_ptr); *(obj_ptr+1) = (uintptr_t)new_obj_ptr; // install forward pointer break; } case RTYPE_REF: - { + { // printf("RTYPE_REF\n"); - // ToDo: GenGC det ser ud til at points_into_tospace checker for + // ToDo: GenGC det ser ud til at points_into_tospace checker for // mere end nødvendigt er - vi ved at det er i en inf-region if ( points_into_tospace(*(obj_ptr+1)) ) // check for forward pointer return *(obj_ptr+1); @@ -1007,14 +1016,14 @@ evacuate(uintptr_t obj) *(obj_ptr+1) = (uintptr_t)new_obj_ptr; // install forward pointer break; } - default: // Object is tagged + default: // Object is tagged { // printf("RTYPE_DEFAULT\n"); if ( is_forward_ptr(*obj_ptr) ) // obj tag contains a fwd-ptr // ToDo: With GenGC, can't we just skip the following // comparison? What should we do if the pointer does not point // into to-space? - { + { // object already copied #ifdef CHECK_GC if ( ! points_into_tospace(*obj_ptr) ) @@ -1024,7 +1033,7 @@ evacuate(uintptr_t obj) } else #endif // CHECK_GC - return clear_forward_ptr(*obj_ptr); + return clear_forward_ptr(*obj_ptr); } //printf("0x%x not a forward ptr - about to copy %p - rp=%p - gen=%p\n", *obj_ptr, obj_ptr, rp, gen); //printf("gen:\n"); @@ -1036,9 +1045,9 @@ evacuate(uintptr_t obj) *obj_ptr = tag_forward_ptr(new_obj_ptr); // install forward pointer } } - if ( is_gen_status_NONE(*copy_to_gen) ) + if ( is_gen_status_NONE(*copy_to_gen) ) { - #ifdef PROFILING + #ifdef PROFILING push_scan_stack(new_obj_ptr - sizeObjectDesc); #else //printf("push_scan_stack: %p - rt=%x, rt_target=%x\n",new_obj_ptr,rtype(*gen),rtype(*copy_to_gen)); @@ -1052,15 +1061,15 @@ evacuate(uintptr_t obj) static uintptr_t* scan_tagged_value(uintptr_t *s) // s is the scan pointer { - // All large objects and objects in finite regions are temporarily - // annotated as immovable. We therefore use val_tag_kind and not + // All large objects and objects in finite regions are temporarily + // annotated as immovable. We therefore use val_tag_kind and not // val_tag_kind_const long sz; // adjust s to point after the string - switch ( val_tag_kind(s) ) { + switch ( val_tag_kind(s) ) { case TAG_STRING: { // Do not GC the content of a string but String str = (String)s; - sz = get_string_size(str->size) + 1 + (sizeof(void *)); // 1 for zero, 4 for tag + sz = get_string_size(str->size) + 1 + (sizeof(void *)); // 1 for zero, sizeof(void *) for tag sz = (sz%(sizeof(void *))) ? (1+sz/(sizeof(void *))) : (sz/(sizeof(void *))); return s + sz; } @@ -1082,7 +1091,7 @@ scan_tagged_value(uintptr_t *s) // s is the scan pointer num_to_skip = get_record_skip(*s); s = s + 1 + num_to_skip; remaining = sz - num_to_skip; - while ( remaining ) + while ( remaining ) { *s = evacuate(*s); s++; @@ -1105,10 +1114,10 @@ scan_tagged_value(uintptr_t *s) // s is the scan pointer return 0; } } -} +} -static void -do_scan_stack() +static void +do_scan_stack() { Rp *rp; Gen *gen; @@ -1117,7 +1126,7 @@ do_scan_stack() while (!((is_scan_stack_empty()) && (is_scan_container_empty()))) { // Run through container - FINITE REGIONS and LARGE OBJECTS - while (!(is_scan_container_empty())) + while (!(is_scan_container_empty())) { uintptr_t* tmp; tmp = pop_scan_container(); @@ -1125,19 +1134,19 @@ do_scan_stack() scan_tagged_value(tmp); } - while (!(is_scan_stack_empty())) + while (!(is_scan_stack_empty())) { uintptr_t *s; // scan pointer s = pop_scan_stack(); //printf("pop_scan_stack: %p\n", s); // Get Region Page and Generation rp = get_rp_header(s); - gen = rp->gen; - switch ( rtype(*gen) ) + gen = rp->gen; + switch ( rtype(*gen) ) { case RTYPE_PAIR: { - while ( s+1 != gen->a ) + while ( s+1 != gen->a ) { #if PROFILING s += sizeObjectDesc; @@ -1150,7 +1159,7 @@ do_scan_stack() } case RTYPE_REF: { - while ( s+1 != gen->a ) + while ( s+1 != gen->a ) { #if PROFILING s += sizeObjectDesc; @@ -1162,7 +1171,7 @@ do_scan_stack() } case RTYPE_TRIPLE: { - while ( s+1 != gen->a ) + while ( s+1 != gen->a ) { #if PROFILING s += sizeObjectDesc; @@ -1180,14 +1189,14 @@ do_scan_stack() } default: { - while ( s != gen->a ) + while ( s != gen->a ) { #if PROFILING s += sizeObjectDesc; #endif // printf("calling scan_tagged_value %p ;gen->a=%p; gen=%d\n", s,gen->a,is_gen_1(*gen)); s = scan_tagged_value(s); - s = next_value(s, gen->a); + s = next_value(s, gen->a); } break; } @@ -1198,17 +1207,17 @@ do_scan_stack() return; } -inline static void -clear_tospace_bit_and_set_colorPtr_in_gen(Gen *gen) +inline static void +clear_tospace_bit_and_set_colorPtr_in_gen(Gen *gen) { Rp *p; - for ( p = clear_fp(gen->fp) ; p ; p = p->n ) + for ( p = clear_fp(gen->fp) ; p ; p = p->n ) { // Clear tospace-bit - in minor gc, pages in g1 are not marked! #ifdef CHECK_GC - if ( ! is_tospace_bit(p->n) + if ( ! is_tospace_bit(p->n) #ifdef ENABLE_GEN_GC - && ( is_major_p || ! is_gen_1(*gen) ) + && ( is_major_p || ! is_gen_1(*gen) ) #endif // ENABLE_GEN_GC ) die ("gc: page in tospace not marked in major gc"); @@ -1234,7 +1243,7 @@ check_all_lobjs(void) // used for debugging { Region r; //printf("[check_all_lobjs begin]\n"); - for( r = TOP_REGION ; r ; r = r->p ) + for( r = TOP_REGION ; r ; r = r->p ) { Lobjs *lobjs; for ( lobjs = r->lobjs ; lobjs ; lobjs = clear_lobj_bit(lobjs->next) ) @@ -1251,7 +1260,7 @@ check_all_lobjs(void) // used for debugging if ( is_const(*tag_ptr) ) die ("check_lobjs: lobj constant bit set"); if ( !is_lobj_bit(lobjs->next) ) - die ("check_lobjs: lobj bit not set"); + die ("check_lobjs: lobj bit not set"); } } //printf("[check_all_lobjs end]\n"); @@ -1262,14 +1271,14 @@ double region_utilize(long pages, long bytes) { if ( pages > 0.0 ) - return (100.0 * (double)bytes - / ((double)(pages * 4 * ALLOCATABLE_WORDS_IN_REGION_PAGE))); - else + return (100.0 * (double)bytes + / ((double)(pages * sizeof(void *) * ALLOCATABLE_WORDS_IN_REGION_PAGE))); + else return 0.0; } - -void -gc(uintptr_t **sp, size_t reg_map) + +void +gc(uintptr_t **sp, size_t reg_map) { long time_gc_one_ms = 0; extern Rp* freelist; @@ -1295,7 +1304,7 @@ gc(uintptr_t **sp, size_t reg_map) // Mutex on the garbage collector; used by alloc_new_block in // Region.c for determining whether the tospace-bit should be set on // new allocated pages. - doing_gc = 1; + doing_gc = 1; #ifdef ENABLE_GEN_GC // See code below after GC proper @@ -1325,10 +1334,10 @@ gc(uintptr_t **sp, size_t reg_map) #endif // ENABLE_GEN_GC } - if ( verbose_gc ) + if ( verbose_gc ) { fprintf(stderr,"[%s#%zd", -#ifdef ENABLE_GEN_GC +#ifdef ENABLE_GEN_GC (is_major_p)?("GC"):("gc"), #else "GC", @@ -1344,7 +1353,9 @@ gc(uintptr_t **sp, size_t reg_map) // Initialize the scan stack (for Infinite Regions) and the // container (for Finite Regions and large objects) + /// fprintf(stderr,"[GC: init_scan_stack]\n"); init_scan_stack(); + /// fprintf(stderr,"[GC: init_scan_container]\n"); init_scan_container(); #ifdef ENABLE_GEN_GC @@ -1362,10 +1373,10 @@ gc(uintptr_t **sp, size_t reg_map) { pp_gen(&(r->g1)); printf("r->g1.b=%p\n", r->g1.b); - die ("problem with middle page"); + die ("problem with middle page"); } } - else + else // last page if ( rp->colorPtr != (uintptr_t *)(r->g1.a) ) { @@ -1378,12 +1389,13 @@ gc(uintptr_t **sp, size_t reg_map) #endif // CHECK_GC #endif // ENABLE_GEN_GC + /// fprintf(stderr,"[GC: mk_from_space]\n"); mk_from_space(); #ifdef ENABLE_GEN_GC if ( is_minor_p ) { - // If minor gc then refs and arrays in old generations (g1) - // and lobjs (i.e., for large arrays) are also considered + // If minor gc then refs and arrays in old generations (g1) + // and lobjs (i.e., for large arrays) are also considered // part of the root-set... for ( r = TOP_REGION ; r ; r = r->p ) { switch ( rtype(r->g1) ) { @@ -1391,25 +1403,25 @@ gc(uintptr_t **sp, size_t reg_map) value_ptr = ((uintptr_t *)clear_fp(r->g1.fp))+HEADER_WORDS_IN_REGION_PAGE - 1; // evacuate content of refs in g1 // refs occupies one word only! - while ( (value_ptr + 1) != r->g1.a ) + while ( (value_ptr + 1) != r->g1.a ) { #if PROFILING value_ptr += sizeObjectDesc; #endif // PROFILING - *(value_ptr+1) = evacuate(*(value_ptr+1)); + *(value_ptr+1) = evacuate(*(value_ptr+1)); value_ptr = next_untagged_value(value_ptr+1,r->g1.a); } break; } - case RTYPE_ARRAY: { + case RTYPE_ARRAY: { size_t tag; ssize_t i, sz; - Lobjs *lobjs; - + Lobjs *lobjs; + value_ptr = ((uintptr_t *)clear_fp(r->g1.fp))+HEADER_WORDS_IN_REGION_PAGE; // evacuate content of arrays in g1 - while ( (value_ptr) != r->g1.a ) - { + while ( (value_ptr) != r->g1.a ) + { #if PROFILING value_ptr += sizeObjectDesc; #endif // PROFILING @@ -1424,7 +1436,7 @@ gc(uintptr_t **sp, size_t reg_map) } // evacuate contents of arrays in lobjs - for ( lobjs = r->lobjs ; lobjs ; lobjs = clear_lobj_bit(lobjs->next) ) + for ( lobjs = r->lobjs ; lobjs ; lobjs = clear_lobj_bit(lobjs->next) ) { value_ptr = &(lobjs->value); #ifdef PROFILING @@ -1454,6 +1466,7 @@ gc(uintptr_t **sp, size_t reg_map) #endif // ENABLE_GEN_GC // Search for live registers + /// fprintf(stderr,"[GC: search for live registers - sp=%p, reg_map=%zx]\n", sp, reg_map); sp_ptr = sp; w = reg_map; for ( offset = 0 ; offset < NUM_REGS ; offset++ ) { @@ -1465,6 +1478,8 @@ gc(uintptr_t **sp, size_t reg_map) } // Do spilled arguments and results to current function + /// fprintf(stderr,"[GC: do spilled arguments - sp=%p, reg_map=%zx, NUM_REGS=%d]\n", sp, reg_map, NUM_REGS); + sp_ptr = sp; sp_ptr = sp_ptr + NUM_REGS; // points at size_spilled_region_args @@ -1475,60 +1490,69 @@ gc(uintptr_t **sp, size_t reg_map) size_ccf = *((long *)sp_ptr); predSPDef(sp_ptr,1); // sp_ptr points at last arg. to current function + /// fprintf(stderr,"[GC: calc done; size_spilled_region_args=%zx; size_rcf=%zx; size_ccf=%zx]\n", + /// size_spilled_region_args,size_rcf,size_ccf); + // All arguments to current function are live - except for region arguments. for ( offset = 0 ; offset < size_ccf ; offset++ ) { value_ptr = ((uintptr_t *)sp_ptr); predSPDef(sp_ptr,1); - if ( offset >= size_spilled_region_args ) + if ( offset >= size_spilled_region_args ) { - *value_ptr = evacuate(*value_ptr); + *value_ptr = evacuate(*value_ptr); } } - /* sp_ptr points at first return address. */ + /* sp_ptr points at first return address. */ /* Below the return address we may have slots for spilled results - */ /* they are not live at this point! */ - /* Search for Frame Descriptors (FD). A FD cover */ - /* - function frame */ - /* - spilled arguments */ - /* - return address */ - /* - spilled results */ + /* Search for Frame Descriptors (FD). An FD covers */ + /* - function frame */ + /* - spilled arguments */ + /* - return address */ + /* - spilled results */ + + /// fprintf(stderr,"[GC: FD processing]\n"); fd_ptr = *sp_ptr; fd_offset_to_return = *(fd_ptr-2); fd_size = *(fd_ptr-3); predSPDef(sp_ptr,size_rcf); + /// fprintf(stderr,"[GC: FD entering loop; sp_ptr=%p; fd_ptr=%p]\n",sp_ptr,fd_ptr); + // sp_ptr points at first address before FD - while ( fd_size != /* 0xFFFFFFFF */ UINTPTR_MAX) + while ( fd_size != /* 0xFFFFFFFFFFFFFFFF */ UINTPTR_MAX) { // Analyse frame - - w_ptr = fd_ptr-4; - + /// fprintf(stderr,"[GC: FD in loop; fd_size=%zx]\n", fd_size); + + + w_ptr = fd_ptr-4; // 4 is ok, also for x64 + // Find RootSet in FD if ( fd_size ) // fd_size may be 0 in which case w_ptr points at arbitrary address. w = *w_ptr; w_idx = 0; - for( offset = 0 ; offset < fd_size ; offset++ ) + for( offset = 0 ; offset < fd_size ; offset++ ) { if (w & 1) { // Evacuate value in frame value_ptr = ((uintptr_t *)sp_ptr) + fd_size - offset; - *value_ptr = evacuate(*value_ptr); + *value_ptr = evacuate(*value_ptr); } w = w >> 1; w_idx++; - if ((w_idx == 32) & (offset+1 < fd_size)) - { + if ((w_idx == 32) & (offset+1 < fd_size)) // 32: code generator uses Word32 + { // Again, w_ptr may point arbitrarily if we are done. w_ptr--; w = *w_ptr; w_idx = 0; } } - + sp_ptr = sp_ptr + fd_offset_to_return + 1; // Points at next return address. fd_ptr = *sp_ptr; fd_offset_to_return = *(fd_ptr-2); @@ -1536,6 +1560,8 @@ gc(uintptr_t **sp, size_t reg_map) predSPDef(sp_ptr,size_rcf); } + // fprintf(stderr,"[GC: FD after loop]\n"); + // Search for data labels; they are part of the root-set. num_d_labs = *data_lab_ptr; /* Number of data labels */ for ( offset = 1 ; offset <= num_d_labs ; offset++ ) { @@ -1543,7 +1569,7 @@ gc(uintptr_t **sp, size_t reg_map) value_ptr = *(((uintptr_t **)data_lab_ptr) + offset); *value_ptr = evacuate(*value_ptr); } - + do_scan_stack(); // We Are Done And Can Now Insert from-space Into The FreeList @@ -1559,7 +1585,7 @@ gc(uintptr_t **sp, size_t reg_map) #ifdef ENABLE_GEN_GC if ( is_major_p ) #endif - for( r = TOP_REGION ; r ; r = r->p ) + for( r = TOP_REGION ; r ; r = r->p ) { Lobjs *lobjs; long first = 1; @@ -1573,10 +1599,10 @@ gc(uintptr_t **sp, size_t reg_map) #else tag_ptr = &(lobjs->value); #endif - if ( is_const(*tag_ptr) + if ( is_const(*tag_ptr) #ifdef ENABLE_GEN_GC || is_minor_p /* Preserve all objects in a minor gc */ -#endif /* ENABLE_GEN_GC */ +#endif /* ENABLE_GEN_GC */ ) { // preserve object // *tag_ptr = clear_const_bit(*tag_ptr); @@ -1585,13 +1611,13 @@ gc(uintptr_t **sp, size_t reg_map) first = 0; *lobjs_ptr = lobjs; } - else + else *lobjs_ptr = set_lobj_bit(lobjs); lobjs_ptr = &(lobjs->next); // update slot lobjs = clear_lobj_bit(lobjs->next); } else // do not preserve object - { + { char* orig; lobjs_current -= size_lobj(*tag_ptr); orig = lobjs->orig; @@ -1599,13 +1625,13 @@ gc(uintptr_t **sp, size_t reg_map) free(orig); // deallocate object } } - + if ( first ) *lobjs_ptr = NULL; else - *lobjs_ptr = set_lobj_bit(NULL); + *lobjs_ptr = set_lobj_bit(NULL); } - + // Unmark all tospace bits in region pages in regions on the stack // Update colorPtr in all region pages. @@ -1628,18 +1654,18 @@ gc(uintptr_t **sp, size_t reg_map) // information is available after gc. mael 2005-03-19 - for( r = TOP_REGION ; r ; r = r->p ) + for( r = TOP_REGION ; r ; r = r->p ) { clear_tospace_bit_and_set_colorPtr_in_gen(&(r->g0)); #ifdef ENABLE_GEN_GC clear_tospace_bit_and_set_colorPtr_in_gen(&(r->g1)); #endif /* ENABLE_GEN_GC */ } - + lobjs_gc_treshold = (long)(heap_to_live_ratio * (double)lobjs_current); - - // Reset all constant-bits in the scan container -- FINITE REGIONS - // and LARGE OBJECTS -- this clearance is safe because we have + + // Reset all constant-bits in the scan container -- FINITE REGIONS + // and LARGE OBJECTS -- this clearance is safe because we have // freed only those large objects that are unmarked and thus do // not occur in the scan container... clear_scan_container(); @@ -1654,12 +1680,12 @@ gc(uintptr_t **sp, size_t reg_map) // leave room for copying... rp_gc_treshold = (int)((heap_to_live_ratio - 1.0) * (double)rp_total / heap_to_live_ratio); if ( (int)((heap_to_live_ratio - 1.0) * (double)rp_used) > rp_gc_treshold ) - { + { #ifdef ENABLE_GEN_GC if ( is_minor_p ) major_p = 1; - else - { + else + { major_p = 0; #endif // ENABLE_GEN_GC rp_gc_treshold = (int)((heap_to_live_ratio - 1.0) * (double)rp_used); @@ -1680,18 +1706,18 @@ gc(uintptr_t **sp, size_t reg_map) // callSbrkArg((int)to_allocate + REGION_PAGE_BAG_SIZE); // } - if ( verbose_gc || report_gc ) + if ( verbose_gc || report_gc ) { getrusage(RUSAGE_SELF, &rusage_end); - time_gc_one_ms = - ((rusage_end.ru_utime.tv_sec+rusage_end.ru_stime.tv_sec)*1000 + - (rusage_end.ru_utime.tv_usec+rusage_end.ru_stime.tv_usec)/1000) - - ((rusage_begin.ru_utime.tv_sec+rusage_begin.ru_stime.tv_sec)*1000 + + time_gc_one_ms = + ((rusage_end.ru_utime.tv_sec+rusage_end.ru_stime.tv_sec)*1000 + + (rusage_end.ru_utime.tv_usec+rusage_end.ru_stime.tv_usec)/1000) - + ((rusage_begin.ru_utime.tv_sec+rusage_begin.ru_stime.tv_sec)*1000 + (rusage_begin.ru_utime.tv_usec+rusage_begin.ru_stime.tv_usec)/1000); time_gc_all_ms += time_gc_one_ms; } - if ( verbose_gc ) + if ( verbose_gc ) { double RI = 0.0, GC = 0.0, FRAG = 0.0; unsigned long bytes_to_space; @@ -1707,33 +1733,34 @@ gc(uintptr_t **sp, size_t reg_map) fprintf(stderr,"(%ldms)", time_gc_one_ms); /* - fprintf(stderr, " rp_total: %d\n", rp_total); - fprintf(stderr, " size_scan_stack: %d\n", (size_scan_stack*4) / 1024); - fprintf(stderr, " size_scan_container: %d\n", (size_scan_container*4) / 1024); - fprintf(stderr, " to_space_old: %d\n", to_space_old); - fprintf(stderr, " alloc_period: %d\n", alloc_period); - fprintf(stderr, " alloc_period_save: %d\n", alloc_period_save); - fprintf(stderr, " bytes_from_space: %d\n", bytes_from_space); - fprintf(stderr, " bytes_to_space: %d\n", bytes_to_space); - fprintf(stderr, " lobjs_beforegc: %d\n", lobjs_beforegc); - fprintf(stderr, " lobjs_aftergc: %d\n", lobjs_aftergc); - fprintf(stderr, " lobjs_period: %d\n", lobjs_period); + fprintf(stderr, " rp_total: %ld\n", rp_total); + fprintf(stderr, " size_scan_stack: %ld\n", (size_scan_stack*sizeof(void *)) / 1024); + fprintf(stderr, " size_scan_container: %ld\n", (size_scan_container*sizeof(void *)) / 1024); + fprintf(stderr, " to_space_old: %ld\n", to_space_old); + fprintf(stderr, " alloc_period: %ld\n", alloc_period); + fprintf(stderr, " alloc_period_save: %ld\n", alloc_period_save); + fprintf(stderr, " bytes_from_space: %ld\n", bytes_from_space); + fprintf(stderr, " bytes_to_space: %ld\n", bytes_to_space); + fprintf(stderr, " lobjs_beforegc: %ld\n", lobjs_beforegc); + fprintf(stderr, " lobjs_aftergc: %ld\n", lobjs_aftergc); + fprintf(stderr, " lobjs_period: %ld\n", lobjs_period); + fprintf(stderr, " lobjs_aftergc_old: %ld\n", lobjs_aftergc_old); */ if ( num_gc != 1 ) { - RI = 100.0 * ( ((double)(to_space_old + lobjs_aftergc_old + alloc_period + + RI = 100.0 * ( ((double)(to_space_old + lobjs_aftergc_old + alloc_period + lobjs_period - bytes_from_space - lobjs_beforegc)) / ((double)(to_space_old + lobjs_aftergc_old + alloc_period + lobjs_period - bytes_to_space - lobjs_aftergc))); - - GC = 100.0 * ( ((double)(bytes_from_space + lobjs_beforegc + + GC = 100.0 * ( ((double)(bytes_from_space + lobjs_beforegc - bytes_to_space - lobjs_aftergc)) / - ((double)(to_space_old + lobjs_aftergc_old - + alloc_period + lobjs_period - + ((double)(to_space_old + lobjs_aftergc_old + + alloc_period + lobjs_period - bytes_to_space - lobjs_aftergc))); - FRAG = 100.0 - 100.0 * (((double)(bytes_from_space + lobjs_beforegc)) / - ((double)(4*ALLOCATABLE_WORDS_IN_REGION_PAGE*pages_from_space + FRAG = 100.0 - 100.0 * (((double)(bytes_from_space + lobjs_beforegc)) / + ((double)(sizeof(void *)*ALLOCATABLE_WORDS_IN_REGION_PAGE*pages_from_space + lobjs_beforegc))); FRAG_sum = FRAG_sum + FRAG; } @@ -1743,25 +1770,25 @@ gc(uintptr_t **sp, size_t reg_map) region_utilize(pages_from_space, bytes_from_space), lobjs_beforegc / 1024, pages_to_space, - region_utilize(pages_to_space, bytes_to_space), + region_utilize(pages_to_space, bytes_to_space), lobjs_aftergc / 1024, size_free_list()); - fprintf(stderr, "RI:%2.0f%%, GC:%2.0f%%]\n", - RI, GC); - + fprintf(stderr, "RI:%2.0lf%%, GC:%2.0lf%%, S:%luMb]\n", + RI, GC, (size_t)(stack_bot_gc - stack_top_gc) / 1024 / 1024); + to_space_old = bytes_to_space; lobjs_aftergc_old = lobjs_aftergc; lobjs_period = 0; alloc_period = 0; } - time_to_gc = 0; + time_to_gc = 0; doing_gc = 0; // Mutex on the garbage collector - - if (raised_exn_interupt) - raise_exn((int)&exn_INTERRUPT); + + if (raised_exn_interupt) + raise_exn((uintptr_t)&exn_INTERRUPT); if (raised_exn_overflow) - raise_exn((int)&exn_OVERFLOW); + raise_exn((uintptr_t)&exn_OVERFLOW); return; } diff --git a/src/Runtime/GC.h b/src/Runtime/GC.h index c49da82ce..221ced791 100644 --- a/src/Runtime/GC.h +++ b/src/Runtime/GC.h @@ -7,6 +7,7 @@ #ifndef GC_H #define GC_H +#define CHECK_GC 1 #ifdef ENABLE_GC extern size_t time_to_gc; extern size_t rp_gc_treshold; @@ -33,6 +34,11 @@ extern ssize_t time_gc_all_ms; extern size_t *data_begin_addr; extern size_t *data_end_addr; +inline static int +points_into_dataspace (uintptr_t *p) { + return (p >= data_begin_addr) && (p <= data_end_addr); +} + size_t size_lobj(size_t tag); void gc(size_t **sp, size_t reg_map); diff --git a/src/Runtime/IO.c b/src/Runtime/IO.c index 0e5f6ed59..c31a7d563 100644 --- a/src/Runtime/IO.c +++ b/src/Runtime/IO.c @@ -2,7 +2,7 @@ * IO * *----------------------------------------------------------------*/ #include -#include +#include #include #include #include @@ -24,11 +24,11 @@ #include "Math.h" #include "Runtime.h" -uintptr_t +uintptr_t openInStream(String path, uintptr_t exn) /* SML Basis */ -{ +{ FILE *fileDesc; - if ((fileDesc = fopen(&(path->data), "r")) == NULL) + if ((fileDesc = fopen(&(path->data), "r")) == NULL) { raise_exn(exn); } @@ -36,11 +36,11 @@ openInStream(String path, uintptr_t exn) /* SML Basis */ return (uintptr_t)(tag_scalar(fileDesc)); } -uintptr_t +uintptr_t openOutStream(String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; - if ((fileDesc = fopen(&(path->data), "w")) == NULL) + if ((fileDesc = fopen(&(path->data), "w")) == NULL) { raise_exn(exn); } @@ -48,11 +48,11 @@ openOutStream(String path, uintptr_t exn) /* SML Basis */ return (uintptr_t)(tag_scalar(fileDesc)); } -uintptr_t +uintptr_t openAppendStream(String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; - if ((fileDesc = fopen(&(path->data), "a")) == NULL) + if ((fileDesc = fopen(&(path->data), "a")) == NULL) { raise_exn(exn); } @@ -60,11 +60,11 @@ openAppendStream(String path, uintptr_t exn) /* SML Basis */ return (uintptr_t)(tag_scalar(fileDesc)); } -uintptr_t +uintptr_t openInBinStream(String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; - if ((fileDesc = fopen(&(path->data), "rb")) == NULL) + if ((fileDesc = fopen(&(path->data), "rb")) == NULL) { raise_exn(exn); } @@ -72,23 +72,23 @@ openInBinStream(String path, uintptr_t exn) /* SML Basis */ return (uintptr_t)(tag_scalar(fileDesc)); } -uintptr_t +uintptr_t openOutBinStream(String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; - if ((fileDesc = fopen(&(path->data), "wb")) == NULL) + if ((fileDesc = fopen(&(path->data), "wb")) == NULL) { raise_exn(exn); - } + } check_tag_scalar(fileDesc); return (uintptr_t)(tag_scalar(fileDesc)); } -uintptr_t +uintptr_t openAppendBinStream(String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; - if ((fileDesc = fopen(&(path->data), "ab")) == NULL) + if ((fileDesc = fopen(&(path->data), "ab")) == NULL) { raise_exn(exn); } @@ -114,11 +114,11 @@ input1Stream(uintptr_t is1) // inputStream: -// Reads n characters from input, n<=64. If EOF is read, +// Reads n characters from input, n<=64. If EOF is read, // then a string less than n is returned. String -REG_POLY_FUN_HDR(inputStream, Region rd, uintptr_t is1, size_t n) +REG_POLY_FUN_HDR(inputStream, Region rd, uintptr_t is1, size_t n) { char buf[100]; size_t i; @@ -140,9 +140,9 @@ REG_POLY_FUN_HDR(inputStream, Region rd, uintptr_t is1, size_t n) resetRegion(rd); } - // i = fread(buf,1,n,is); + // i = fread(buf,1,n,is); // return REG_POLY_CALL(convertBinStringToML, rd, i, buf); - + terminal = isatty(fileno(is)); for ( i = 0; i < n && ((ch = fgetc(is)) != EOF); i++ ) { @@ -154,7 +154,7 @@ REG_POLY_FUN_HDR(inputStream, Region rd, uintptr_t is1, size_t n) } size_t -lookaheadStream(uintptr_t is1) +lookaheadStream(uintptr_t is1) { int ch; FILE *is; @@ -168,8 +168,8 @@ lookaheadStream(uintptr_t is1) return convertIntToML(ch); } -void -closeStream(uintptr_t stream) +void +closeStream(uintptr_t stream) { stream = untag_scalar(stream); fclose((FILE *) stream); @@ -177,8 +177,8 @@ closeStream(uintptr_t stream) } /* -int -endOfStream(FILE *stream) +int +endOfStream(FILE *stream) { int ch; @@ -193,8 +193,8 @@ endOfStream(FILE *stream) } */ -size_t -outputStream(uintptr_t os1, String s, uintptr_t exn) +size_t +outputStream(uintptr_t os1, String s, uintptr_t exn) { FILE *os = (FILE *)untag_scalar(os1); if ( fputs(&(s->data), os) == EOF ) @@ -205,79 +205,79 @@ outputStream(uintptr_t os1, String s, uintptr_t exn) return mlUNIT; } -void -flushStream(uintptr_t stream) +void +flushStream(uintptr_t stream) { stream = untag_scalar(stream); fflush((FILE *) stream); /* What about error. */ } -size_t -stdInStream(uintptr_t dummy) +size_t +stdInStream(uintptr_t dummy) { check_tag_scalar(stdin); return (size_t)tag_scalar(stdin); } -size_t -stdOutStream(size_t dummy) +size_t +stdOutStream(size_t dummy) { check_tag_scalar(stdout); return (size_t)tag_scalar(stdout); } -size_t -stdErrStream(uintptr_t dummy) +size_t +stdErrStream(uintptr_t dummy) { check_tag_scalar(stderr); return (size_t)tag_scalar(stderr); } -void -sml_chdir(String dirname, long exn) /* SML Basis */ +void +sml_chdir(String dirname, uintptr_t exn) /* SML Basis */ { - if ( chdir(&(dirname->data)) != 0 ) + if ( chdir(&(dirname->data)) != 0 ) { raise_exn(exn); } return; } -void -sml_remove(String name, int exn) /* SML Basis */ +void +sml_remove(String name, uintptr_t exn) /* SML Basis */ { int ret; ret = unlink(&(name->data)); - if ( ret != 0 ) + if ( ret != 0 ) { raise_exn(exn); } return; } -void -sml_rename(String oldname, String newname, int exn) /* SML Basis */ +void +sml_rename(String oldname, String newname, uintptr_t exn) /* SML Basis */ { - if ( rename(&(oldname->data), &(newname->data)) != 0 ) + if ( rename(&(oldname->data), &(newname->data)) != 0 ) { raise_exn(exn); } return; } -int -sml_access(String path, int permarg, int exn) /* ML */ +size_t +sml_access(String path, size_t permarg, uintptr_t exn) /* ML */ { long perms; long perm = convertIntToC(permarg); perms = ((0x1 & perm) ? R_OK : 0); perms |= ((0x2 & perm) ? W_OK : 0); perms |= ((0x4 & perm) ? X_OK : 0); - if (perms == 0) + if (perms == 0) { perms = F_OK; } - if (access(&(path->data), perms) == 0) + if (access(&(path->data), perms) == 0) { return mlTRUE; } @@ -285,38 +285,38 @@ sml_access(String path, int permarg, int exn) /* ML */ } String -REG_POLY_FUN_HDR(sml_getdir, Region rAddr, int exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_getdir, Region rAddr, uintptr_t exn) /* SML Basis */ { char directory[MAXPATHLEN]; char *res; errno = 0; res = getcwd(directory, MAXPATHLEN); - if ( res == NULL ) + if ( res == NULL ) { - raise_exn(exn); + raise_exn(exn); } return REG_POLY_CALL(convertStringToML, rAddr, directory); } -int -sml_isdir(String path, int exn) /* SML Basis */ +size_t +sml_isdir(String path, uintptr_t exn) /* SML Basis */ { struct stat buf; - if ( stat(&(path->data), &buf) == -1 ) + if ( stat(&(path->data), &buf) == -1 ) { raise_exn(exn); } - if (S_ISDIR(buf.st_mode)) + if (S_ISDIR(buf.st_mode)) { return mlTRUE; } return mlFALSE; } -void -sml_mkdir(String path, int exn) /* SML Basis */ +void +sml_mkdir(String path, uintptr_t exn) /* SML Basis */ { - if ( mkdir(&(path->data), 0777) == -1 ) + if ( mkdir(&(path->data), 0777) == -1 ) { raise_exn(exn); } @@ -324,11 +324,11 @@ sml_mkdir(String path, int exn) /* SML Basis */ } -int -sml_modtime(uintptr_t vAddr, String path, int exn) /* SML Basis */ +uintptr_t +sml_modtime(uintptr_t vAddr, String path, uintptr_t exn) /* SML Basis */ { struct stat buf; - if ( stat(&(path->data), &buf) == -1 ) + if ( stat(&(path->data), &buf) == -1 ) { raise_exn(exn); } @@ -337,61 +337,61 @@ sml_modtime(uintptr_t vAddr, String path, int exn) /* SML Basis */ return vAddr; } -void -sml_rmdir(String path, int exn) /* SML Basis */ +void +sml_rmdir(String path, uintptr_t exn) /* SML Basis */ { - if ( rmdir(&(path->data)) == -1 ) + if ( rmdir(&(path->data)) == -1 ) { raise_exn(exn); } return; } -void -sml_settime(String path, uintptr_t time, int exn) /* SML Basis */ +void +sml_settime(String path, uintptr_t time, uintptr_t exn) /* SML Basis */ { struct utimbuf tbuf; tbuf.actime = tbuf.modtime = (long)(get_d(time)); - if ( utime(&(path->data), &tbuf) == -1 ) + if ( utime(&(path->data), &tbuf) == -1 ) { raise_exn(exn); } return; } -int -sml_filesize(String path, int exn) /* SML Basis */ +size_t +sml_filesize(String path, uintptr_t exn) /* SML Basis */ { struct stat buf; - if ( stat(&(path->data), &buf) == -1 ) + if ( stat(&(path->data), &buf) == -1 ) { raise_exn(exn); } return (convertIntToML(buf.st_size)); } -uintptr_t -sml_opendir(String path, int exn) /* SML Basis */ +uintptr_t +sml_opendir(String path, uintptr_t exn) /* SML Basis */ { - DIR * dstr; + DIR * dstr; dstr = opendir(&(path->data)); - if ( dstr == NULL ) + if ( dstr == NULL ) { raise_exn(exn); } check_tag_scalar(dstr); - return (uintptr_t)tag_scalar(dstr); + return (uintptr_t)tag_scalar(dstr); } String -REG_POLY_FUN_HDR(sml_readdir, Region rAddr, uintptr_t v, int exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_readdir, Region rAddr, uintptr_t v, uintptr_t exn) /* SML Basis */ { struct dirent *direntry; String res; DIR * dir_ptr; dir_ptr = (DIR *)untag_scalar(v); direntry = readdir(dir_ptr); - if (direntry == NULL) + if (direntry == NULL) { raise_exn(exn); return NULL; @@ -403,7 +403,7 @@ REG_POLY_FUN_HDR(sml_readdir, Region rAddr, uintptr_t v, int exn) /* SML Basi return res; } -void +void sml_rewinddir(uintptr_t v) /* SML Basis */ { DIR *dir_ptr; @@ -413,20 +413,20 @@ sml_rewinddir(uintptr_t v) /* SML Basis */ return; } -void -sml_closedir(uintptr_t v, int exn) /* SML Basis */ +void +sml_closedir(uintptr_t v, uintptr_t exn) /* SML Basis */ { DIR *dir_ptr; dir_ptr = (DIR *)untag_scalar(v); - if (closedir(dir_ptr) == -1) - { + if (closedir(dir_ptr) == -1) + { raise_exn(exn); } return; } -size_t +size_t sml_errno(void) /* SML Basis */ { return convertIntToML((size_t) errno); // not thread-safe!! @@ -434,7 +434,7 @@ sml_errno(void) /* SML Basis */ // FIXME String -REG_POLY_FUN_HDR(sml_errormsg, Region rAddr, int errnum) /* SML Basis */ +REG_POLY_FUN_HDR(sml_errormsg, Region rAddr, size_t errnum) /* SML Basis */ { char *res; res = strerror(convertIntToC(errnum)); @@ -443,41 +443,41 @@ REG_POLY_FUN_HDR(sml_errormsg, Region rAddr, int errnum) /* SML Basis */ return REG_POLY_CALL(convertStringToML, rAddr, res); } -int -sml_islink(String path, int exn) /* SML Basis */ +size_t +sml_islink(String path, uintptr_t exn) /* SML Basis */ { struct stat buf; - if (lstat(&(path->data), &buf) == -1) + if (lstat(&(path->data), &buf) == -1) { raise_exn(exn); } - if (S_ISLNK(buf.st_mode)) - { + if (S_ISLNK(buf.st_mode)) + { return mlTRUE; } return mlFALSE; } -int -sml_isreg(int fd, int exn) /* SML Basis */ +size_t +sml_isreg(size_t fd, uintptr_t exn) /* SML Basis */ { struct stat buf; - if (fstat(convertIntToC(fd), &buf) == -1) + if (fstat(convertIntToC(fd), &buf) == -1) { raise_exn(exn); } - if (S_ISREG(buf.st_mode)) - { + if (S_ISREG(buf.st_mode)) + { return mlTRUE; } return mlFALSE; } -int -sml_filesizefd(int fd, int exn) /* SML Basis */ +size_t +sml_filesizefd(size_t fd, uintptr_t exn) /* SML Basis */ { struct stat buf; - if (fstat(convertIntToC(fd), &buf) == -1) + if (fstat(convertIntToC(fd), &buf) == -1) { raise_exn(exn); } @@ -485,14 +485,14 @@ sml_filesizefd(int fd, int exn) /* SML Basis */ } String -REG_POLY_FUN_HDR(sml_readlink, Region rAddr, String path, int exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_readlink, Region rAddr, String path, uintptr_t exn) /* SML Basis */ { char buffer[MAXPATHLEN]; long result; result = readlink(&(path->data), buffer, MAXPATHLEN); - if (result == -1 || result >= MAXPATHLEN) + if (result == -1 || result >= MAXPATHLEN) { - raise_exn(exn); + raise_exn(exn); } buffer[result] = '\0'; return REG_POLY_CALL(convertStringToML, rAddr, buffer); @@ -501,12 +501,12 @@ REG_POLY_FUN_HDR(sml_readlink, Region rAddr, String path, int exn) /* SML Bas extern char *realpath(); String -REG_POLY_FUN_HDR(sml_realpath, Region rAddr, String path, int exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_realpath, Region rAddr, String path, uintptr_t exn) /* SML Basis */ { char buffer[MAXPATHLEN]; char *result; result = realpath(&(path->data), buffer); - if (result == NULL) + if (result == NULL) { raise_exn(exn); return NULL; @@ -514,11 +514,11 @@ REG_POLY_FUN_HDR(sml_realpath, Region rAddr, String path, int exn) /* SML Basis return REG_POLY_CALL(convertStringToML, rAddr, result); } -uintptr_t -sml_devinode(uintptr_t vAddr, String path, int exn) /* SML Basis */ +uintptr_t +sml_devinode(uintptr_t vAddr, String path, uintptr_t exn) /* SML Basis */ { struct stat buf; - if (stat(&(path->data), &buf) == -1) + if (stat(&(path->data), &buf) == -1) { raise_exn(exn); } @@ -529,12 +529,12 @@ sml_devinode(uintptr_t vAddr, String path, int exn) /* SML Basis */ return vAddr; } -int -sml_system(String cmd, int exn) /* SML Basis */ +size_t +sml_system(String cmd, uintptr_t exn) /* SML Basis */ { int res; res = system(&(cmd->data)); - if (res != 0) + if (res != 0) { res = -1; } @@ -542,22 +542,22 @@ sml_system(String cmd, int exn) /* SML Basis */ } String -REG_POLY_FUN_HDR(sml_getenv, Region rAddr, String var, int exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_getenv, Region rAddr, String var, uintptr_t exn) /* SML Basis */ { char *res; res = (char *)(getenv(&(var->data))); - if (res == NULL) + if (res == NULL) { raise_exn(exn); } return REG_POLY_CALL(convertStringToML, rAddr, res); } -size_t -outputBinStream(uintptr_t os1, String s, uintptr_t exn) +size_t +outputBinStream(uintptr_t os1, String s, uintptr_t exn) { long strsize; FILE *os = (FILE *) os1; - strsize = sizeStringDefine(s); + strsize = sizeStringDefine(s); os = (FILE *)untag_scalar(os); if ( fwrite(&(s->data), 1, strsize, os) != strsize ) { @@ -568,14 +568,14 @@ outputBinStream(uintptr_t os1, String s, uintptr_t exn) } uintptr_t -sml_microsleep(uintptr_t pair, int s, int u) +sml_microsleep(uintptr_t pair, size_t s, size_t u) { - int r; + size_t r; struct timespec req, rem; mkTagPairML(pair); u = convertIntToC(u); s = convertIntToC(s); - while (u > 1000000) + while (u > 1000000) { s++; u -= 1000000; @@ -589,11 +589,10 @@ sml_microsleep(uintptr_t pair, int s, int u) return pair; } -int -sml_poll(int time) +size_t +sml_poll(size_t time) { - int r; + size_t r; r = poll(0,0,time); return r; } - diff --git a/src/Runtime/Makefile.in b/src/Runtime/Makefile.in index 400451936..6f772b171 100644 --- a/src/Runtime/Makefile.in +++ b/src/Runtime/Makefile.in @@ -25,17 +25,18 @@ OFILES_GEN_GC_PROF = $(OFILESWITHGC:%.o=%-gengc-p.o) OFILES_GC_TP = $(OFILESWITHGC:%.o=%-gc-tp.o) OFILES_GC_TP_PROF = $(OFILESWITHGC:%.o=%-gc-tp-p.o) OFILES_KAM = $(OFILES:%.o=%-kam.o) Interp-kam.o LoadKAM-kam.o KamInsts-kam.o Prims.o \ - HeapCache-kam.o + HeapCache-kam.o CFILES_KAM = $(CFILES) Interp.c LoadKAM.c KamInsts.c HeapCache.c OFILES_SMLSERVER = $(OFILES:%.o=%-smlserver.o) Interp-smlserver.o LoadKAM-smlserver.o \ - HeapCache-smlserver.o KamInsts-smlserver.o PrimsApSml.o + HeapCache-smlserver.o KamInsts-smlserver.o PrimsApSml.o CFILES_SMLSERVER = $(CFILES) Interp.c LoadKAM.c HeapCache.c KamInsts.c HEADER_FILES=SysErrTable.h #OPT=-Wall -pedantic -std=c99 -OPT:=-m32 -Wall -std=gnu99 +#OPT:=-m32 -Wall -std=gnu99 +OPT:=-Wall -std=gnu99 OPT:=$(OPT) $(CFLAGS) AR=ar rc @@ -70,8 +71,8 @@ gen_syserror: gen_syserror.c $(CC) -c -DKAM -DLAB_THREADED -DTHREADS -DAPACHE -fpic $(OPT) -o $*-smlserver.o $< %-p.o: %.c -# $(CC) -c -DPROFILING -DDEBUG -o $*-p.o $< - $(CC) -c -DPROFILING $(OPT) -o $*-p.o $< +# $(CC) -c -DPROFILING -DDEBUG -o $*-p.o $< + $(CC) -c -DPROFILING $(OPT) -o $*-p.o $< %-gc.o: %.c $(CC) -c -DTAG_VALUES -DTAG_FREE_PAIRS -DENABLE_GC $(OPT) -o $*-gc.o $< @@ -163,13 +164,13 @@ depend: rm Makefile.in.bak clean: - rm -f $(OFILES) $(OFILES_TAG) $(OFILES_PROF) $(OFILES_GC) $(OFILES_GC_TP) - rm -f $(OFILES_GC_PROF) $(OFILES_GC_TP_PROF) $(OFILES_KAM) $(OFILES_SMLSERVER) + rm -f $(OFILES) $(OFILES_TAG) $(OFILES_PROF) $(OFILES_GC) $(OFILES_GC_TP) + rm -f $(OFILES_GC_PROF) $(OFILES_GC_TP_PROF) $(OFILES_KAM) $(OFILES_SMLSERVER) rm -f $(OFILES_GEN_GC_PROF) $(OFILES_GEN_GC) rm -f core a.out *~ *.bak gen_syserror SysErrTable.h - rm -f runtimeSystemKamApSml.o kam runtimeSystemGCProf.a runtimeSystemGC.a - rm -f runtimeSystemGCTPProf.a runtimeSystemGCTP.a - rm -f runtimeSystemProf.a runtimeSystemTag.a runtimeSystem.a + rm -f runtimeSystemKamApSml.o kam runtimeSystemGCProf.a runtimeSystemGC.a + rm -f runtimeSystemGCTPProf.a runtimeSystemGCTP.a + rm -f runtimeSystemProf.a runtimeSystemTag.a runtimeSystem.a rm -f runtimeSystemGenGCProf.a runtimeSystemGenGC.a ### DO NOT DELETE THIS LINE diff --git a/src/Runtime/Math.c b/src/Runtime/Math.c index 91e88fc49..53d8ba571 100644 --- a/src/Runtime/Math.c +++ b/src/Runtime/Math.c @@ -9,45 +9,40 @@ #include "Tagging.h" #include "Exception.h" -/* -static unsigned int -max(unsigned int a, unsigned int b) -{ - return (a 0 && y > 0) || (x < 0 && y < 0) || (x % y == 0) ) + if ( (x > 0 && y > 0) || (x < 0 && y < 0) || (x % y == 0) ) { return x % y; } return (x % y) + y; } -size_t -__mod_word32ub(size_t x, size_t y, uintptr_t exn) +size_t +__mod_word32ub(size_t x0, size_t y0, uintptr_t exn) { - if ( y == 0 ) + unsigned int x = (unsigned int)x0; + unsigned int y = (unsigned int)y0; + if ( y == 0 ) { raise_exn(exn); return 0; // never reached @@ -144,13 +150,13 @@ __mod_word32ub(size_t x, size_t y, uintptr_t exn) return (x % y); } -size_t -__mod_word31(size_t x, size_t y, uintptr_t exn) +size_t +__mod_word31(size_t x, size_t y, uintptr_t exn) { - size_t xC = i31_to_i32ub(x); - size_t yC = i31_to_i32ub(y); + unsigned int xC = i31_to_i32ub((unsigned int)x); + unsigned int yC = i31_to_i32ub((unsigned int)y); - if ( yC == 0 ) + if ( yC == 0 ) { raise_exn(exn); return 0; // never reached @@ -158,67 +164,67 @@ __mod_word31(size_t x, size_t y, uintptr_t exn) return i32ub_to_i31(xC % yC); } -ssize_t -__quot_int32ub(ssize_t xML, ssize_t yML) +ssize_t +__quot_int32ub(ssize_t xML, ssize_t yML) { - return xML/yML; + return ((int)xML)/((int)yML); } -ssize_t -__quot_int31(ssize_t xML, ssize_t yML) +ssize_t +__quot_int31(ssize_t xML, ssize_t yML) { - ssize_t xC,yC; + int xC,yC; - xC = i31_to_i32ub(xML); - yC = i31_to_i32ub(yML); + xC = i31_to_i32ub((int)xML); + yC = i31_to_i32ub((int)yML); return i32ub_to_i31(xC / yC); } -ssize_t -__rem_int32ub(ssize_t xML, ssize_t yML) +ssize_t +__rem_int32ub(ssize_t xML, ssize_t yML) { - return xML % yML; + return ((int)xML) % ((int)yML); } -ssize_t -__rem_int31(ssize_t xML, ssize_t yML) +ssize_t +__rem_int31(ssize_t xML, ssize_t yML) { - ssize_t xC,yC; + int xC,yC; - xC = i31_to_i32ub(xML); - yC = i31_to_i32ub(yML); + xC = i31_to_i32ub((int)xML); + yC = i31_to_i32ub((int)yML); return i32ub_to_i31(xC % yC); } #ifdef TAG_VALUES -size_t* -__div_int32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +size_t* +__div_int32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) { get_i32b(b) = __div_int32ub(get_i32b(x), get_i32b(y), exn); set_i32b_tag(b); return b; } -size_t* -__div_word32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +size_t* +__div_word32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) { get_i32b(b) = __div_word32ub(get_i32b(x), get_i32b(y), exn); set_i32b_tag(b); return b; } -size_t* -__mod_int32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +size_t* +__mod_int32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) { get_i32b(b) = __mod_int32ub(get_i32b(x), get_i32b(y), exn); set_i32b_tag(b); return b; } -size_t* -__mod_word32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +size_t* +__mod_word32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) { get_i32b(b) = __mod_word32ub(get_i32b(x), get_i32b(y), exn); set_i32b_tag(b); @@ -226,8 +232,8 @@ __mod_word32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) } // quot need not check for y being 0; this is checked for in Int32 -size_t* -__quot_int32b(size_t* b, size_t* x, size_t* y) +size_t* +__quot_int32b(size_t* b, size_t* x, size_t* y) { get_i32b(b) = __quot_int32ub(get_i32b(x), get_i32b(y)); set_i32b_tag(b); @@ -235,8 +241,8 @@ __quot_int32b(size_t* b, size_t* x, size_t* y) } // rem need not check for y being 0; this is checked for in Int32 -size_t* -__rem_int32b(size_t* b, size_t* x, size_t* y) +size_t* +__rem_int32b(size_t* b, size_t* x, size_t* y) { get_i32b(b) = __rem_int32ub(get_i32b(x), get_i32b(y)); set_i32b_tag(b); @@ -245,11 +251,11 @@ __rem_int32b(size_t* b, size_t* x, size_t* y) #endif /*TAG_VALUES*/ -ssize_t -realInt(ssize_t d, ssize_t x) +ssize_t +realInt(ssize_t d, ssize_t x) { debug(printf("[realInt: d = %zu, x = %zu\n", d, x)); - get_d(d) = (double) (convertIntToC(x)); + get_d(d) = (double) (convertIntToC((int)x)); set_dtag(d); debug(printf("]\n")); return d; @@ -259,70 +265,70 @@ realInt(ssize_t d, ssize_t x) * Floating point operations * *----------------------------------------------------------------------*/ -ssize_t -divFloat(ssize_t d, ssize_t x, ssize_t y) +ssize_t +divFloat(ssize_t d, ssize_t x, ssize_t y) { get_d(d) = get_d(x) / get_d(y); set_dtag(d); return d; } -ssize_t -floorFloat(ssize_t f) -{ +ssize_t +floorFloat(ssize_t f) +{ double r; ssize_t i; r = get_d(f); - if( r >= 0.0 ) - { - if ( r >= (Max_Int_d + 1.0) ) + if( r >= 0.0 ) + { + if ( r >= (Max_Int_d + 1.0) ) { raise_exn((uintptr_t)&exn_OVERFLOW); } return (convertIntToML((ssize_t) r)); } - if( r < Min_Int_d ) + if( r < Min_Int_d ) { raise_exn((uintptr_t)&exn_OVERFLOW); } i = (ssize_t) r; - if( r < ((double) i) ) + if( r < ((double) i) ) { i -= 1; } return convertIntToML(i); } -ssize_t -truncFloat(ssize_t f) -{ +ssize_t +truncFloat(ssize_t f) +{ double r; r = get_d(f); - if ((r >= (Max_Int_d + 1.0)) || (r <= (Min_Int_d - 1.0))) - { + if ((r >= (Max_Int_d + 1.0)) || (r <= (Min_Int_d - 1.0))) + { raise_exn((uintptr_t)&exn_OVERFLOW); } return convertIntToML((ssize_t)r); } -ssize_t -ceilFloat(ssize_t f) -{ +ssize_t +ceilFloat(ssize_t f) +{ double arg; ssize_t i; arg = get_d(f); - if( arg >= 0.0 ) - { + if( arg >= 0.0 ) + { if( arg > Max_Int_d ) goto raise_ceil; i = (ssize_t) arg; if( arg > ((double) i) ) i += 1; } - else - { + else + { if( arg <= (Min_Int_d - 1.0) ) goto raise_ceil; i = (ssize_t) arg; } @@ -333,150 +339,150 @@ ceilFloat(ssize_t f) return 0; // never reached } -ssize_t -sqrtFloat(ssize_t d, ssize_t s) -{ - get_d(d) = sqrt(get_d(s)); +ssize_t +sqrtFloat(ssize_t d, ssize_t s) +{ + get_d(d) = sqrt(get_d(s)); set_dtag(d); return d; } -ssize_t -sinFloat(ssize_t d, ssize_t s) +ssize_t +sinFloat(ssize_t d, ssize_t s) { get_d(d) = sin(get_d(s)); set_dtag(d); return d; } -ssize_t -cosFloat(ssize_t d, ssize_t s) +ssize_t +cosFloat(ssize_t d, ssize_t s) { get_d(d) = cos(get_d(s)); set_dtag(d); return d; } -ssize_t -atanFloat (ssize_t d, ssize_t s) +ssize_t +atanFloat (ssize_t d, ssize_t s) { get_d (d) = atan (get_d (s)); set_dtag(d); return d; } -ssize_t -asinFloat (ssize_t d, ssize_t s) +ssize_t +asinFloat (ssize_t d, ssize_t s) { get_d (d) = asin (get_d (s)); set_dtag(d); return d; } -ssize_t -acosFloat (ssize_t d, ssize_t s) +ssize_t +acosFloat (ssize_t d, ssize_t s) { get_d (d) = acos (get_d (s)); set_dtag(d); return d; } -ssize_t -atan2Float (ssize_t d, ssize_t y, ssize_t x) +ssize_t +atan2Float (ssize_t d, ssize_t y, ssize_t x) { get_d (d) = atan2 (get_d (y), get_d (x)); set_dtag(d); return d; } -ssize_t expFloat(ssize_t d, ssize_t s) +ssize_t expFloat(ssize_t d, ssize_t s) { get_d(d) = exp(get_d(s)); set_dtag(d); return d; } -ssize_t -powFloat (ssize_t d, ssize_t x, ssize_t y) +ssize_t +powFloat (ssize_t d, ssize_t x, ssize_t y) { get_d (d) = pow (get_d (x), get_d (y)); set_dtag(d); return d; } -ssize_t -lnFloat(ssize_t d, ssize_t s) +ssize_t +lnFloat(ssize_t d, ssize_t s) { get_d(d) = log(get_d(s)); set_dtag(d); return d; } -ssize_t -sinhFloat(ssize_t d, ssize_t s) +ssize_t +sinhFloat(ssize_t d, ssize_t s) { get_d(d) = sinh(get_d(s)); set_dtag(d); return d; } -ssize_t -coshFloat(ssize_t d, ssize_t s) +ssize_t +coshFloat(ssize_t d, ssize_t s) { get_d(d) = cosh(get_d(s)); set_dtag(d); return d; } -ssize_t -tanhFloat(ssize_t d, ssize_t s) +ssize_t +tanhFloat(ssize_t d, ssize_t s) { get_d(d) = tanh(get_d(s)); set_dtag(d); return d; } -ssize_t -isnanFloat(ssize_t s) +ssize_t +isnanFloat(ssize_t s) { - if (isnan(get_d(s))) + if (isnan(get_d(s))) { return mlTRUE; } return mlFALSE; } -ssize_t -posInfFloat(ssize_t d) +ssize_t +posInfFloat(ssize_t d) { get_d(d) = HUGE_VAL; set_dtag(d); return d; } -ssize_t -negInfFloat(ssize_t d) +ssize_t +negInfFloat(ssize_t d) { get_d(d) = -HUGE_VAL; set_dtag(d); return d; } -// countChar: count the number of times the character `c' +// countChar: count the number of times the character `c' // occurs in the string `s'. static ssize_t countChar(ssize_t c, char * s) { - char *p; + char *p; ssize_t count; count = 0; - for( p=s; *p != '\0'; p++ ) + for( p=s; *p != '\0'; p++ ) { if( *p == c ) count++; } return count; } -// mkSMLMinus: remove all '+', and replace '-' and 'e' +// mkSMLMinus: remove all '+', and replace '-' and 'e' // with '~' and 'E', respectively. static void mkSMLMinus(char * s) { char *p, *q; @@ -494,12 +500,12 @@ static void mkSMLMinus(char * s) { } String -REG_POLY_FUN_HDR(stringOfFloat, Region rAddr, size_t arg) +REG_POLY_FUN_HDR(stringOfFloat, Region rAddr, size_t arg) { char buf[64]; sprintf(buf, "%.12g", get_d(arg)); mkSMLMinus(buf); - if( countChar('.', buf) == 0 && countChar('E', buf) == 0 ) + if( countChar('.', buf) == 0 && countChar('E', buf) == 0 ) { strcat(buf, ".0"); } @@ -507,13 +513,13 @@ REG_POLY_FUN_HDR(stringOfFloat, Region rAddr, size_t arg) } String -REG_POLY_FUN_HDR(generalStringOfFloat, Region rAddr, String format, size_t f) +REG_POLY_FUN_HDR(generalStringOfFloat, Region rAddr, String format, size_t f) { char result_buf[512]; /* Unfortunately there seems to be no way to ensure that this does not - * crash by overflowing the result_buffer (e.g. when specifying a huge - * number of decimal digits in the fixed-point format): + * crash by overflowing the result_buffer (e.g. when specifying a huge + * number of decimal digits in the fixed-point format): */ sprintf(result_buf, &(format->data), get_d(f)); mkSMLMinus(result_buf); @@ -521,8 +527,8 @@ REG_POLY_FUN_HDR(generalStringOfFloat, Region rAddr, String format, size_t f) } /* DEBUG */ -void -printReal(size_t f) +void +printReal(size_t f) { printf("Num: %5.2f\n",get_d(f)); return; @@ -541,7 +547,7 @@ REG_POLY_FUN_HDR(sml_real_to_bytes, Region rAddr, size_t f) return REG_POLY_CALL(convertBinStringToML, rAddr, 8, v); } -size_t +size_t sml_bytes_to_real(size_t d, String s) { double r; @@ -551,3 +557,34 @@ sml_bytes_to_real(size_t d, String s) set_dtag(d); return d; } + + +/* A test function for testing auto */ +uintptr_t +runtime_test0 (uintptr_t a1, uintptr_t a2, uintptr_t a3) { + long int ret = + 2 * (long int)a1 + + 3 * (long int)a2 + + 5 * (long int)a3; + return ret; /* (2*1)+(3*2)+(5*3) ==> 23 */ +} + +/* A test function for testing multi-parameter passing (non-auto) */ +uintptr_t +runtime_test1 (uintptr_t a1, uintptr_t a2, uintptr_t a3, uintptr_t a4, uintptr_t a5, + uintptr_t a6, uintptr_t a7, uintptr_t a8, uintptr_t a9, uintptr_t a10) { + long int ret = + 2 * (long int)(convertIntToC(a1)) + + 3 * (long int)(convertIntToC(a2)) + + 5 * (long int)(convertIntToC(a3)) + + 7 * (long int)(convertIntToC(a4)) + + 11 * (long int)(convertIntToC(a5)) + + 17 * (long int)(convertIntToC(a6)) + + 19 * (long int)(convertIntToC(a7)) + + 23 * (long int)(convertIntToC(a8)) + + 29 * (long int)(convertIntToC(a9)) + + 31 * (long int)(convertIntToC(a10)); + return (uintptr_t)(convertIntToML(ret)); +} + +/* (2*1)+(3*2)+(5*3)+(7*4)+(11*5)+(17*6)+(19*7)+(23*8)+(29*9)+(31*10) ==> 1096 */ diff --git a/src/Runtime/Math.h b/src/Runtime/Math.h index 73c0f7c5c..54a2989de 100644 --- a/src/Runtime/Math.h +++ b/src/Runtime/Math.h @@ -28,31 +28,31 @@ #define minDefine(A,B) ((A> 1) #define Min_Int (INTPTR_MIN >> 1) #define Max_Int_d ((INTPTR_MAX >> 1) * 1.0) #define Min_Int_d ((INTPTR_MIN >> 1) * 1.0) #define val_precision (__WORDSIZE - 1) +*/ #else -#if 0 #define Max_Int 2147483647 #define Min_Int (-2147483647-1) #define Max_Int_d 2147483647.0 #define Min_Int_d -2147483648.0 #define val_precision 32 -#endif +/* #define Max_Int INTPTR_MAX #define Min_Int INTPTR_MIN #define Max_Int_d (INTPTR_MAX * 1.0) #define Min_Int_d (INTPTR_MIN * 1.0) #define val_precision (__WORDSIZE) +*/ #endif /*----------------------------------------------------------------* diff --git a/src/Runtime/Posix.c b/src/Runtime/Posix.c index 1e0b82e9e..381d0201e 100644 --- a/src/Runtime/Posix.c +++ b/src/Runtime/Posix.c @@ -65,8 +65,8 @@ sml_WSTOPSIG(size_t status) return convertIntToML(WSTOPSIG(tmp)); } -uintptr_t -sml_waitpid(uintptr_t pair, size_t waitpid_arg, size_t flags) +uintptr_t +sml_waitpid(uintptr_t pair, size_t waitpid_arg, size_t flags) { int status; int f = 0x0; @@ -85,7 +85,7 @@ ssize_t sml_sysconf(ssize_t t) { long res; - switch (convertIntToC(t)) + switch (convertIntToC(t)) { case 1: res = sysconf(_SC_ARG_MAX); @@ -214,7 +214,7 @@ sml_lower(char *name, size_t rwx_mode, size_t flags, size_t perm, size_t i, size res = fchmod(i,f); break; default: - res = 0; + res = 0; } return res; } @@ -235,9 +235,9 @@ sml_exec (String path, uintptr_t sl, int envl, int kind) } args = (char **) malloc(sizeof(char *) * (n+1)); if (!args) return convertIntToML(-1); - + list = sl; - + for (i = 0; isCONS(list); list = tl(list), i++) { elemML = (String) hd(list); @@ -246,7 +246,7 @@ sml_exec (String path, uintptr_t sl, int envl, int kind) args[i] = NULL; list = envl; - if (isCONS(list)) + if (isCONS(list)) { for (n = 0; isCONS(list); list = tl(list)) { @@ -322,7 +322,7 @@ REG_POLY_FUN_HDR(sml_readVec,uintptr_t pair, Region sr, int fd, int n1) s = REG_POLY_CALL(allocStringC, sr, n+1); ((char *)&(s->data))[n] = 0; r = read(convertIntToC(fd), &(s->data), n); - if (r > 0) + if (r > 0) { ((char *)&(s->data))[r] = 0; } @@ -440,13 +440,13 @@ sml_statA(uintptr_t pair, struct stat *b) res |= (S_IRUSR & b->st_mode ? 1 : 0); res <<= 1; res |= (S_IRWXU & b->st_mode ? 1 : 0); - elemRecordML(pair,1) = convertIntToML(res); - elemRecordML(pair,2) = convertIntToML(b->st_ino); - elemRecordML(pair,3) = convertIntToML(b->st_dev); - elemRecordML(pair,4) = convertIntToML(b->st_nlink); - elemRecordML(pair,5) = convertIntToML(b->st_size); - elemRecordML(pair,6) = convertIntToML(b->st_uid); - elemRecordML(pair,7) = convertIntToML(b->st_gid); + elemRecordML(pair,1) = convertIntToML(res); + elemRecordML(pair,2) = convertIntToML(b->st_ino); + elemRecordML(pair,3) = convertIntToML(b->st_dev); + elemRecordML(pair,4) = convertIntToML(b->st_nlink); + elemRecordML(pair,5) = convertIntToML(b->st_size); + elemRecordML(pair,6) = convertIntToML(b->st_uid); + elemRecordML(pair,7) = convertIntToML(b->st_gid); return pair; } @@ -495,10 +495,10 @@ sml_fstat(uintptr_t pair, size_t fd) return sml_statA(pair, &b); } -static int +static size_t sml_pathconf_number(size_t name) { - int res = 0; + size_t res = 0; switch(name) { case 0: @@ -563,7 +563,7 @@ sml_pathconf(char *file, size_t name) return res; } -static int sml_ttyVals[] = { +static size_t sml_ttyVals[] = { VEOF, // 0 VEOL, VERASE, @@ -637,25 +637,25 @@ static int sml_ttyVals[] = { NCCS // 70 }; -int -sml_getTty(int i) +size_t +sml_getTty(size_t i) { return sml_ttyVals[i]; } #include "SysErrTable.h" -static int +static int sml_posixFind(char *s, struct syserr_entry arr[], int amount) { - int i = 0, j, k,n; + int i = 0, j, k, n; j = amount; while (i <= j) { k = i + (j-i) / 2; n = strcmp(arr[k].name, s); if (n == 0) return arr[k].number; - if (n < 0) + if (n < 0) { i = k+1; continue; @@ -669,22 +669,22 @@ sml_posixFind(char *s, struct syserr_entry arr[], int amount) return -1; } -int +size_t sml_syserror(char *s) { return sml_posixFind(s, syserrTableName, sml_numberofErrors); } -int +size_t sml_findsignal(char *s) { return sml_posixFind(s, syssigTableNumber, sml_numberofSignals); } -static String -REG_POLY_FUN_HDR(sml_PosixName, Region rs, int e, struct syserr_entry arr[], int amount) +static String +REG_POLY_FUN_HDR(sml_PosixName, Region rs, size_t e, struct syserr_entry arr[], size_t amount) { - int i = 0, j, k,n; + size_t i = 0, j, k,n; j = amount; e = convertIntToC(e); while (i <= j) @@ -695,7 +695,7 @@ REG_POLY_FUN_HDR(sml_PosixName, Region rs, int e, struct syserr_entry arr[], int { return REG_POLY_CALL(convertStringToML, rs, arr[k].name); } - if (n < 0) + if (n < 0) { i = k+1; continue; @@ -735,7 +735,7 @@ REG_POLY_FUN_HDR(sml_getgrgid, uintptr_t triple, Region nameR, Region memberList } res = getgrgid_r(gid, &gbuf, b, s-1, &gbuf2); third(triple) = res; - if (res) + if (res) { free(b); return triple; @@ -781,7 +781,7 @@ REG_POLY_FUN_HDR(sml_getgrnam, uintptr_t triple, Region memberListR, Region memb } res = getgrnam_r(name, &gbuf, b, s-1, &gbuf2); third(triple) = res; - if (res) + if (res) { free(b); return triple; @@ -825,7 +825,7 @@ REG_POLY_FUN_HDR(sml_getpwuid, long tuple, Region nameR, Region homeR, Region sh } res = getpwuid_r(uid, &pbuf, b, s-1, &pbuf2); elemRecordML(tuple,4) = res; - if (res) + if (res) { free(b); return tuple; @@ -861,7 +861,7 @@ REG_POLY_FUN_HDR(sml_getpwnam, long tuple, Region homeR, Region shellR, String n } res = getpwnam_r(name, &pbuf, b, s-1, &pbuf2); elemRecordML(tuple,4) = res; - if (res) + if (res) { free(b); return tuple; @@ -879,7 +879,7 @@ REG_POLY_FUN_HDR(sml_getpwnam, long tuple, Region homeR, Region shellR, String n return tuple; } -String +String REG_POLY_FUN_HDR(sml_ctermid, Region r) { String rs; @@ -960,20 +960,20 @@ int getlogin_r(char *buf, size_t bufsize); // within /usr/include/stdio.h. // Trying setting // #undef __USE_XOPEN2K -// #define __USE_GNU 1 -// at the top of Runtime.c also fixes the problem - makes sence if +// #define __USE_GNU 1 +// at the top of Runtime.c also fixes the problem - makes sence if // you look at stdio_lim.h -// The constant L_ctermid IS set in stdio_lim.h because it is used +// The constant L_ctermid IS set in stdio_lim.h because it is used // without problems further down. // Everything compiles if we define it directly here instead - or moves // the defines above to Runtime.c: -#define L_cuserid 9 +#define L_cuserid 100 String REG_POLY_FUN_HDR(sml_getlogin, Region rs) { String s; int r; - s = REG_POLY_CALL(allocStringC,rs, L_cuserid + 4); /* was 1 - hmm*/ + s = REG_POLY_CALL(allocStringC,rs, L_cuserid + 8); /* was 1 - hmm*/ r = getlogin_r(&(s->data), L_cuserid); if (r != 0) { @@ -1062,7 +1062,3 @@ REG_POLY_FUN_HDR(sml_uname, Region rl, Region rp, Region s1, Region s2) list = REG_POLY_CALL(cons_pair_of_strings, rl, rp, s1, s2, "machine", i.machine, list); return (uintptr_t)list; } - - - - diff --git a/src/Runtime/Posix.h b/src/Runtime/Posix.h index 856fb5869..3da8d98ac 100644 --- a/src/Runtime/Posix.h +++ b/src/Runtime/Posix.h @@ -1,5 +1,5 @@ struct syserr_entry { char *name; - int number; + size_t number; }; diff --git a/src/Runtime/Profiling.c b/src/Runtime/Profiling.c index 8a43aa0d5..46bf20941 100644 --- a/src/Runtime/Profiling.c +++ b/src/Runtime/Profiling.c @@ -27,11 +27,11 @@ long *stackBot; long timeToProfile; long maxStack; // max. stack size from check_stack long *maxStackP=NULL; // Max. stack addr. from ProfileTick -long tempAntal; +long tempCount; long tellTime; /* 1, if the next profile tick should print out the * current time - 0 otherwise */ -struct itimerval rttimer; +struct itimerval rttimer; struct itimerval old_rttimer; int profileON = TRUE; /* if false profiling is not started after a profileTick. */ @@ -41,26 +41,24 @@ long freeProfilingRest; /* Number of bytes left in freeProfiling-chunk. */ TickList * firstTick; /* Pointer to data for the first tick. */ TickList * lastTick; /* Pointer to data for the last tick. */ -/* The following two global arrays are used as hash tables during +/* The following two global arrays are used as hash tables during * a profile tick. */ RegionListHashList * regionListHashTable[REGION_LIST_HASH_TABLE_SIZE]; /* Used as hash table into a region list. */ ObjectListHashList * objectListHashTable[OBJECT_LIST_HASH_TABLE_SIZE]; /* Used as hash table into an object list. */ ProfTabList * profHashTab[PROF_HASH_TABLE_SIZE]; /* Hash table for information collected during execution */ -int profTabCountDebug = 0; - +long profTabCountDebug = 0; unsigned long numberOfTics=0; /* Number of profilings so far. */ - -unsigned long lastCpuTime=0; /* CPU time after last tick. */ -unsigned long cpuTimeAcc=0; /* Used time by program excl. profiling. */ +unsigned long lastCpuTime=0; /* CPU time after last tick. */ +unsigned long cpuTimeAcc=0; /* Used time by program excl. profiling. */ long noTimer = /* Profile with a constant number of function calls. */ ITIMER_REAL+ITIMER_VIRTUAL+ITIMER_PROF; /* A number different from the other constants. */ long profType = ITIMER_VIRTUAL; /* Type of profiling to use */ long signalType = SIGVTALRM; /* Signal to catch depending on profType. */ -long profNo = 10000; +long profNo = 10000; long microsec = 0; long sec = 1; long verboseProfileTick = 0; @@ -70,8 +68,6 @@ long showStat = 0; char logName[100]="profile.rp"; /* Name of log file to use. */ FILE* logFile; -FILE* logFile_xx; -char logName_xx[100]="profile.rp"; /* Name of log file to use. */ int noOfTickInFile = 0; char prgName[100]; @@ -79,11 +75,6 @@ long doing_prof = 0; long raised_exn_interupt_prof = 0; long raised_exn_overflow_prof = 0; - -// static unsigned int max(unsigned int a, unsigned int b) { -// return (anext) { count++ ; } return count; } +*/ -int profTabSize(void) { - int count, i; +long profTabSize(void) { + long count, i; ProfTabList* p; for (count = 0, i = 0 ; i < PROF_HASH_TABLE_SIZE ; i++) for (p=profHashTab[i]; p != NULL; p=p->next, count++) {} @@ -123,8 +116,8 @@ ProfTabList* profTabListInsertAndInitialize(ProfTabList* p, long regionId) { /* checkProfTab("profTabListInsertAndInitialize.enter"); */ profTabCountDebug ++; - /* - printf("Entering profTabListInsertAndInitialize; regionId = %d, profSize = %d, count = %d\n", + /* + printf("Entering profTabListInsertAndInitialize; regionId = %d, profSize = %d, count = %d\n", regionId, profSize(p), profTabCountDebug); */ pNew = (ProfTabList*)allocMemProfiling_xx(sizeof(ProfTabList)); @@ -206,7 +199,7 @@ void profTabDecrNoOfPages(long regionId, long i) { return; }; printf("regionId is %ld\n", regionId); - perror("profTabDecrNoOfPages error"); + perror("profTabDecrNoOfPages error"); exit(-1); } @@ -220,7 +213,7 @@ void profTabDecrAllocNow(long regionId, long i, char *s) { return; }; fprintf(stderr, "Error.%s: regionId %ld does not exist in profiling table\n", s, regionId); - fprintf(stderr, "profTabCountDebug = %d, profTabSize = %d\n", profTabCountDebug, + fprintf(stderr, "profTabCountDebug = %ld, profTabSize = %ld\n", profTabCountDebug, profTabSize()); printProfTab(); perror("profTabDecrAllocNow error\n"); @@ -251,20 +244,20 @@ void profTabIncrAllocNow(long regionId, long i) { /* ---------------------------------------------------------- * - * Hash table to hold LOCAL region map. Hash table used + * Hash table to hold LOCAL region map. Hash table used * locally during a profile tick to make lookup fast. * ---------------------------------------------------------- */ void initializeRegionListTable(void) { - int i; + long i; for (i = 0 ; i < REGION_LIST_HASH_TABLE_SIZE; i++ ) regionListHashTable[i] = NULL; return; } -void insertRegionListTable(int regionId, RegionList* rl) { +void insertRegionListTable(long regionId, RegionList* rl) { RegionListHashList* p; - int index; + long index; index = regionListHashTabIndex(regionId); for (p=regionListHashTable[index]; p != NULL; p=p->next) if (p->regionId == regionId) { @@ -283,9 +276,9 @@ void insertRegionListTable(int regionId, RegionList* rl) { return; } -RegionList* lookupRegionListTable(int regionId) { +RegionList* lookupRegionListTable(long regionId) { RegionListHashList* p; - int index; + long index; index = regionListHashTabIndex(regionId); for (p=regionListHashTable[index]; p != NULL; p=p->next) if (p->regionId == regionId) return p->rl; @@ -293,20 +286,20 @@ RegionList* lookupRegionListTable(int regionId) { } /* ---------------------------------------------------------- * - * Hash table to hold LOCAL object map. The hash table is used + * Hash table to hold LOCAL object map. The hash table is used * locally during a profile tick to make lookup fast. * ---------------------------------------------------------- */ void initializeObjectListTable(void) { - int i; + long i; for (i = 0; i < OBJECT_LIST_HASH_TABLE_SIZE; i++) objectListHashTable[i] = NULL; return; } -void insertObjectListTable(int atId, ObjectList* ol) { +void insertObjectListTable(long atId, ObjectList* ol) { ObjectListHashList* p; - int index; + long index; index = objectListHashTabIndex(atId); for (p=objectListHashTable[index]; p != NULL; p=p->next) if (p->atId == atId) { @@ -324,10 +317,10 @@ void insertObjectListTable(int atId, ObjectList* ol) { objectListHashTable[index] = p; /* update hash table; new element is stored in front */ return; } - -ObjectList* lookupObjectListTable(int atId) { + +ObjectList* lookupObjectListTable(long atId) { ObjectListHashList* p; - int index; + long index; index = objectListHashTabIndex(atId); for (p=objectListHashTable[index]; p != NULL; p=p->next) if (p->atId == atId) return p->ol; @@ -341,8 +334,8 @@ ObjectList* lookupObjectListTable(int atId) { /* This function sets the flags 'tellTime' so that next time a tick is made, the time is printed on stdout */ -void -queueMarkProf(StringDesc *str, int pPoint) +void +queueMarkProf(StringDesc *str, long pPoint) { tellTime = 1; fprintf(stderr,"Reached \"%s\"\n", &(str->data)); @@ -352,13 +345,13 @@ queueMarkProf(StringDesc *str, int pPoint) /* Calculate the allocated and used space in a region. */ /* All instantiated regions with this region name is */ /* calculated as one region. */ -void +void AllocatedSpaceInARegion(Ro *rp) -{ - unsigned int n; +{ + long n; - n = profTabGetNoOfPages(rp->regionId) * ALLOCATABLE_WORDS_IN_REGION_PAGE * 4; - fprintf(stderr," Allocated bytes in region %5zd: %5u\n",rp->regionId, n); + n = profTabGetNoOfPages(rp->regionId) * ALLOCATABLE_WORDS_IN_REGION_PAGE * sizeof(long*); + fprintf(stderr," Allocated bytes in region %5zd: %5ld\n",rp->regionId, n); return; } @@ -366,25 +359,25 @@ AllocatedSpaceInARegion(Ro *rp) void PrintGen(Gen *gen) { - int i; + long i; Rp *p; if ( gen ) { fprintf(stderr,"\n Address of Gen: %p, First free word: %p, Border of region: %p\n ",gen,gen->a,gen->b); - for ( p = clear_fp(gen->fp) , i = 1 ; p ; p = p->n , i++ ) + for ( p = clear_fp(gen->fp) , i = 1 ; p ; p = p->n , i++ ) { - fprintf(stderr,"-->Page%2d:%p",i,p); + fprintf(stderr,"-->Page%2ld:%p",i,p); if (i%3 == 0) - fprintf(stderr,"\n "); + fprintf(stderr,"\n "); } fprintf(stderr,"\n"); } } /* Prints all pages in the region. */ -void +void PrintRegion(Region r) -{ +{ fprintf(stderr,"\nAddress of Ro: %p\n ",r); PrintGen(&(r->g0)); @@ -393,8 +386,8 @@ PrintRegion(Region r) #endif /* ENABLE_GEN_GC */ } -void -resetProfiler() +void +resetProfiler() { outputProfilePre(); initializeProfTab(); @@ -403,23 +396,23 @@ resetProfiler() { timeToProfile = 1; } - else + else { timeToProfile = 0; rttimer.it_value.tv_sec = sec; /* Time in seconds to first tick. */ rttimer.it_value.tv_usec = microsec; /* Time in microseconds to first tick. */ rttimer.it_interval.tv_sec = 0; /* Time in seconds between succeding ticks. */ rttimer.it_interval.tv_usec = 0; /* Time in microseconds between succeding ticks. */ - + signal(signalType, AlarmHandler); - - profiling_on(); + + profiling_on(); } - if (verboseProfileTick) + if (verboseProfileTick) { fprintf(stderr, "---------------------Profiling-Enabled---------------------\n"); - if (profType == noTimer) + if (profType == noTimer) { fprintf(stderr," The profile timer is turned off; a profile tick occurs\n"); fprintf(stderr,"every %ldth entrance to a function.\n", profNo); @@ -432,9 +425,9 @@ resetProfiler() fprintf(stderr," The profile timer (unix profile timer) is turned on.\n"); if (microsec != 0 && profType != noTimer) fprintf(stderr," A profile tick occurs every %ldth microsecond.\n", microsec); - if (sec != 0 && profType != noTimer) + if (sec != 0 && profType != noTimer) fprintf(stderr," A profile tick occurs every %ldth second.\n", sec); - if (exportProfileDatafile) + if (exportProfileDatafile) fprintf(stderr," Profiling data is exported to file %s.\n", logName); else fprintf(stderr," No profiling data is exported.\n"); @@ -443,14 +436,14 @@ resetProfiler() return; } -void -checkProfTab(char* s) +void +checkProfTab(char* s) { unsigned long i; ProfTabList* p; - for ( i = 0 ; i < PROF_HASH_TABLE_SIZE ; i++ ) + for ( i = 0 ; i < PROF_HASH_TABLE_SIZE ; i++ ) for ( p = profHashTab[i] ; p ; p = p->next ) - if ( p->regionId > 1000000 ) + if ( p->regionId > 1000000 ) { printProfTab(); printf("Mysterious regionId (%ld) in ProfTab: %s\n", p->regionId, s); @@ -458,8 +451,8 @@ checkProfTab(char* s) } } -void -printProfTab() +void +printProfTab() { long i; long noOfPagesTab, maxNoOfPagesTab; @@ -474,7 +467,7 @@ printProfTab() maxAllocTot = 0; fprintf(stderr,"\n\nPRINTING PROFILING TABLE.\n"); - for ( i = 0 ; i < PROF_HASH_TABLE_SIZE ; i++ ) + for ( i = 0 ; i < PROF_HASH_TABLE_SIZE ; i++ ) for (p=profHashTab[i];p!=NULL;p=p->next) { noOfPagesTab = p->noOfPages; noOfPagesTot += noOfPagesTab; @@ -486,18 +479,18 @@ printProfTab() maxAllocTot += maxAllocTab; /* if (maxNoOfPagesTab) */ fprintf(stderr," profTab[rId%5ld]: noOfPages = %8ld, maxNoOfPages = %8ld, allocNow = %8ld, maxAlloc = %8ld\n", - p->regionId, noOfPagesTab, maxNoOfPagesTab, allocNowTab*4, maxAllocTab*4); + p->regionId, noOfPagesTab, maxNoOfPagesTab, allocNowTab*sizeof(long*), maxAllocTab*sizeof(long*)); } fprintf(stderr, " ---------------------------------------------------------------------------------------------------\n"); fprintf(stderr, " %8ld SUM OF MAX: %8ld Bytes: %8ld Bytes: %8ld\n", - noOfPagesTot, maxNoOfPagesTot, allocNowTot*4, maxAllocTot*4); + noOfPagesTot, maxNoOfPagesTot, allocNowTot*sizeof(long*), maxAllocTot*sizeof(long*)); fprintf(stderr, " ===================================================================================================\n"); } -void +void Statistics() -{ +{ double Mb = 1024.0*1024.0; if (showStat) { @@ -511,69 +504,69 @@ Statistics() fprintf(stderr," Alloc. in each malloc call: %ld bytes\n", BYTES_ALLOC_BY_SBRK); fprintf(stderr," Total allocation by malloc: %ld bytes (%.1fMb)\n", BYTES_ALLOC_BY_SBRK*callsOfSbrk, (BYTES_ALLOC_BY_SBRK*callsOfSbrk)/Mb ); - + fprintf(stderr,"\nREGION PAGES\n"); - fprintf(stderr," Size of one page: %d bytes\n",ALLOCATABLE_WORDS_IN_REGION_PAGE*4); + fprintf(stderr," Size of one page: %ld bytes\n",ALLOCATABLE_WORDS_IN_REGION_PAGE*sizeof(long*)); fprintf(stderr," Max number of allocated pages: %ld\n",maxNoOfPages); fprintf(stderr," Number of allocated pages now: %ld\n",noOfPages); - fprintf(stderr," Max space for region pages: %ld bytes (%.1fMb)\n", - maxNoOfPages*ALLOCATABLE_WORDS_IN_REGION_PAGE*(sizeof(void *)), (maxNoOfPages*ALLOCATABLE_WORDS_IN_REGION_PAGE*(sizeof(void *)))/Mb); - + fprintf(stderr," Max space for region pages: %ld bytes (%.1fMb)\n", + maxNoOfPages*ALLOCATABLE_WORDS_IN_REGION_PAGE*(sizeof(long*)), (maxNoOfPages*ALLOCATABLE_WORDS_IN_REGION_PAGE*(sizeof(long*)))/Mb); + fprintf(stderr,"\nINFINITE REGIONS\n"); - /* fprintf(stderr," Size of infinite reg. desc. (incl. prof info): %d bytes\n",sizeRo*4); */ - fprintf(stderr," Size of infinite region descriptor: %ld bytes\n",(sizeRo-sizeRoProf)*(sizeof(void *))); + /* fprintf(stderr," Size of infinite reg. desc. (incl. prof info): %d bytes\n",sizeRo*sizeof(long*)); */ + fprintf(stderr," Size of infinite region descriptor: %ld bytes\n",(sizeRo-sizeRoProf)*(sizeof(long*))); fprintf(stderr," Number of calls to allocateRegionInf: %ld\n",callsOfAllocateRegionInf); - fprintf(stderr," Number of calls to deallocateRegionInf: %ld\n",callsOfDeallocateRegionInf); + fprintf(stderr," Number of calls to deallocateRegionInf: %ld\n",callsOfDeallocateRegionInf); fprintf(stderr," Number of calls to alloc: %ld\n",callsOfAlloc); fprintf(stderr," Number of calls to resetRegion: %ld\n",callsOfResetRegion); fprintf(stderr," Number of calls to deallocateRegionsUntil: %ld\n",callsOfDeallocateRegionsUntil); - fprintf(stderr,"\nALLOCATION\n"); + fprintf(stderr,"\nALLOCATION\n"); /* - fprintf(stderr," Alloc. space in infinite regions: %d bytes (%.1fMb)\n", allocNowInf*4, (allocNowInf*4)/Mb); - fprintf(stderr," Alloc. space in finite regions: %d bytes (%.1fMb)\n", allocNowFin*4, (allocNowFin*4)/Mb); - fprintf(stderr," Alloc. space in regions: %d bytes (%.1fMb)\n", (allocNowInf+allocNowFin)*4,((allocNowInf+allocNowFin)*4)/Mb); + fprintf(stderr," Alloc. space in infinite regions: %d bytes (%.1fMb)\n", allocNowInf*sizeof(long*), (allocNowInf*sizeof(long*))/Mb); + fprintf(stderr," Alloc. space in finite regions: %d bytes (%.1fMb)\n", allocNowFin*sizeof(long*), (allocNowFin*sizeof(long*))/Mb); + fprintf(stderr," Alloc. space in regions: %d bytes (%.1fMb)\n", (allocNowInf+allocNowFin)*sizeof(long*),((allocNowInf+allocNowFin)*sizeof(long*))/Mb); */ - fprintf(stderr," Max alloc. space in pages: %ld bytes (%.1fMb)\n", maxAllocInf*(sizeof(void *)),(maxAllocInf*(sizeof(void *)))/Mb); + fprintf(stderr," Max alloc. space in pages: %ld bytes (%.1fMb)\n", maxAllocInf*(sizeof(long*)),(maxAllocInf*(sizeof(long*)))/Mb); /* - fprintf(stderr, " Space in regions at that time used on profiling: %d bytes (%4.1fMb)\n", maxAllocProfInf*4, - (maxAllocProfInf*4)/Mb); + fprintf(stderr, " Space in regions at that time used on profiling: %d bytes (%4.1fMb)\n", maxAllocProfInf*sizeof(long*), + (maxAllocProfInf*sizeof(long*))/Mb); fprintf(stderr," -------------------------------------------------------------------------------\n"); */ - fprintf(stderr," incl. prof. info: %ld bytes (%.1fMb)\n", - (maxAllocProfInf+maxAllocInf)*(sizeof(void *)), ((maxAllocProfInf+maxAllocInf)*(sizeof(void *)))/Mb); + fprintf(stderr," incl. prof. info: %ld bytes (%.1fMb)\n", + (maxAllocProfInf+maxAllocInf)*(sizeof(long*)), ((maxAllocProfInf+maxAllocInf)*(sizeof(long*)))/Mb); fprintf(stderr," Infinite regions utilisation (%ld/%ld): %2.0f%%\n", - (maxAllocProfInf+maxAllocInf)*(sizeof(void *)), - (maxNoOfPages*ALLOCATABLE_WORDS_IN_REGION_PAGE*(sizeof(void *))), - ((maxAllocProfInf+maxAllocInf)*1.0*(sizeof(void *)))/(maxNoOfPages*ALLOCATABLE_WORDS_IN_REGION_PAGE*1.0*(sizeof(void *)))*100.0); + (maxAllocProfInf+maxAllocInf)*(sizeof(long*)), + (maxNoOfPages*ALLOCATABLE_WORDS_IN_REGION_PAGE*(sizeof(long*))), + ((maxAllocProfInf+maxAllocInf)*1.0*(sizeof(long*)))/(maxNoOfPages*ALLOCATABLE_WORDS_IN_REGION_PAGE*1.0*(sizeof(long*)))*100.0); fprintf(stderr," Number of allocated large objects: %ld\n", allocatedLobjs); - fprintf(stderr,"\nSTACK\n"); + fprintf(stderr,"\nSTACK\n"); fprintf(stderr," Number of calls to allocateRegionFin: %ld\n",callsOfAllocateRegionFin); fprintf(stderr," Number of calls to deallocateRegionFin: %ld\n",callsOfDeallocateRegionFin); - fprintf(stderr," Max space for finite regions: %ld bytes (%.1fMb)\n", maxAllocFin*(sizeof(void *)), - (maxAllocFin*(sizeof(void *)))/Mb); - fprintf(stderr," Max space for region descs: %ld bytes (%.1fMb)\n", - maxRegionDescUseInf*4, (maxRegionDescUseInf*(sizeof(void *)))/Mb); + fprintf(stderr," Max space for finite regions: %ld bytes (%.1fMb)\n", maxAllocFin*(sizeof(long*)), + (maxAllocFin*(sizeof(long*)))/Mb); + fprintf(stderr," Max space for region descs: %ld bytes (%.1fMb)\n", + maxRegionDescUseInf*sizeof(long*), (maxRegionDescUseInf*(sizeof(long*)))/Mb); fprintf(stderr," Max size of stack: %ld bytes (%.1fMb)\n", - ((long)stackBot)-((long)maxStack)-(maxProfStack*(sizeof(void *))), (((long)stackBot)-((long)maxStack)-(maxProfStack*(sizeof(void *))))/Mb); - fprintf(stderr," incl. prof. info: %ld bytes (%.1fMb)\n", + ((long)stackBot)-((long)maxStack)-(maxProfStack*(sizeof(long*))), (((long)stackBot)-((long)maxStack)-(maxProfStack*(sizeof(long*))))/Mb); + fprintf(stderr," incl. prof. info: %ld bytes (%.1fMb)\n", ((long)stackBot)-((long)maxStack), ((((long)stackBot)-((long)maxStack))*1.0)/Mb); - fprintf(stderr," in profile tick: %ld bytes (%.1fMb)\n", + fprintf(stderr," in profile tick: %ld bytes (%.1fMb)\n", ((long)stackBot)-((long)maxStackP), (((long)stackBot)-((long)maxStackP))/Mb); fprintf(stderr,"Number of profile ticks: %d\n", noOfTickInFile); /* - fprintf(stderr, " Space used on prof. info. at that time: %d bytes (%.1fMb)\n", - maxRegionDescUseProfInf*4, (maxRegionDescUseProfInf*4)/Mb); + fprintf(stderr, " Space used on prof. info. at that time: %d bytes (%.1fMb)\n", + maxRegionDescUseProfInf*sizeof(long*), (maxRegionDescUseProfInf*sizeof(long*))/Mb); fprintf(stderr," ---------------------------------------------------------------------------------------------\n"); - fprintf(stderr," Max space used on infinite region descs on stack: %d bytes (%4.1fMb)\n", - (maxRegionDescUseInf+maxRegionDescUseProfInf)*4,((maxRegionDescUseInf+maxRegionDescUseProfInf)*4)/Mb); - fprintf(stderr," Space used on profiling information at that time: %d bytes (%4.1fMb)\n", - (maxAllocProfFin+maxRegionDescUseProfFin)*4, ((maxAllocProfFin+maxRegionDescUseProfFin)*4)/Mb); + fprintf(stderr," Max space used on infinite region descs on stack: %d bytes (%4.1fMb)\n", + (maxRegionDescUseInf+maxRegionDescUseProfInf)*sizeof(long*),((maxRegionDescUseInf+maxRegionDescUseProfInf)*sizeof(long*))/Mb); + fprintf(stderr," Space used on profiling information at that time: %d bytes (%4.1fMb)\n", + (maxAllocProfFin+maxRegionDescUseProfFin)*sizeof(long*), ((maxAllocProfFin+maxRegionDescUseProfFin)*sizeof(long*))/Mb); fprintf(stderr," -------------------------------------------------------------------------------------------\n"); - fprintf(stderr," Max space used on finite regions on stack: %d bytes (%4.1fMb)\n", - (maxAllocFin+maxAllocProfFin+maxRegionDescUseProfFin)*4,((maxAllocFin+maxAllocProfFin+maxRegionDescUseProfFin)*4)/Mb); - fprintf(stderr," Space used on profiling information at that time: %d bytes (%4.1fMb)\n", - maxProfStack*4, (maxProfStack*4)/Mb); + fprintf(stderr," Max space used on finite regions on stack: %d bytes (%4.1fMb)\n", + (maxAllocFin+maxAllocProfFin+maxRegionDescUseProfFin)*sizeof(long*),((maxAllocFin+maxAllocProfFin+maxRegionDescUseProfFin)*sizeof(long*))/Mb); + fprintf(stderr," Space used on profiling information at that time: %d bytes (%4.1fMb)\n", + maxProfStack*sizeof(long*), (maxProfStack*sizeof(long*))/Mb); fprintf(stderr," -------------------------------------------------------------------------------\n"); */ fprintf(stderr,"\n*********End of region statistics*********\n"); @@ -599,8 +592,8 @@ Statistics() * error and stop. * *------------------------------------------------------*/ char errorStr[255]; -void -profileERROR(char *errorStr) +void +profileERROR(char *errorStr) { fprintf(stderr,"\n***********************ERROR*****************************\n"); fprintf(stderr,"%s\n", errorStr); @@ -612,8 +605,8 @@ profileERROR(char *errorStr) * This function prints the contents of a finite * * region on screen. * *-----------------------------------------------*/ -void -pp_finite_region (FiniteRegionDesc *frd) +void +pp_finite_region (FiniteRegionDesc *frd) { ObjectDesc *obj; obj = (ObjectDesc *) (frd+1); @@ -626,18 +619,18 @@ pp_finite_region (FiniteRegionDesc *frd) * This function prints the contents of an infinite * * region on screen. * *--------------------------------------------------*/ -void -pp_infinite_region_gen (Gen *gen) +void +pp_infinite_region_gen (Gen *gen) { ObjectDesc *fObj; Rp *rp; fprintf(stderr,"Generation %lu at address %p\n", generation(*gen),gen); - for( rp = clear_fp(gen->fp) ; rp ; rp = rp->n ) + for( rp = clear_fp(gen->fp) ; rp ; rp = rp->n ) { fObj = (ObjectDesc *) (((long *)rp)+HEADER_WORDS_IN_REGION_PAGE); - while ( ((long *)fObj < ((long *)rp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE) - && (fObj->atId!=notPP) ) + while ( ((long *)fObj < ((long *)rp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE) + && (fObj->atId!=notPP) ) { fprintf(stderr,"ObjAtId %zu, Size: %zu\n", fObj->atId, fObj->size); fObj=(ObjectDesc *)(((size_t *)fObj)+((fObj->size)+sizeObjectDesc)); /* Find next object. */ @@ -646,15 +639,15 @@ pp_infinite_region_gen (Gen *gen) return; } -void -pp_infinite_region (Region r) +void +pp_infinite_region (Region r) { r = clearStatusBits(r); fprintf(stderr,"Region %zu\n", r->regionId); pp_infinite_region_gen(&(r->g0)); #ifdef ENABLE_GEN_GC - pp_infinite_region_gen(&(r->g1)); + pp_infinite_region_gen(&(r->g1)); #endif /* ENABLE_GEN_GC */ return; @@ -664,14 +657,14 @@ pp_infinite_region (Region r) * This function prints the contents of all infinite * * regions on screen. * *---------------------------------------------------*/ -void -pp_infinite_regions() +void +pp_infinite_regions() { Region r; - for ( r = TOP_REGION ; r ; r = r->p ) + for ( r = TOP_REGION ; r ; r = r->p ) pp_infinite_region(r); - + return; } @@ -680,8 +673,8 @@ pp_infinite_regions() * profiling_on * * Sets alarm for profiling. * *------------------------------------------------------*/ -void -profiling_on() +void +profiling_on() { setitimer(profType, &rttimer, &old_rttimer); profileON = TRUE; @@ -694,10 +687,10 @@ profiling_on() * profiling_off * * Stop alarm for profiling. * *------------------------------------------------------*/ -void -profiling_off() +void +profiling_off() { - struct itimerval zerotimer; + struct itimerval zerotimer; zerotimer.it_value.tv_sec = 0; /* Time in seconds to first tick. */ zerotimer.it_value.tv_usec = 0; /* Time in microseconds to first tick. */ @@ -716,26 +709,26 @@ profiling_off() * allocated for profiling data. * *------------------------------------------------------*/ char * -allocMemProfiling_xx(long i) +allocMemProfiling_xx(long i) { char * p; char * tempPtr; tempPtr = (char *)malloc(i); - if ( tempPtr == NULL ) + if ( tempPtr == NULL ) { perror("malloc error in allocMemProfiling\n"); exit(-1); } - if ( ((long)tempPtr) % (sizeof(void *)) ) + if ( ((long)tempPtr) % (sizeof(long*)) ) { perror("allocMemProfiling_xx not aligned\n"); exit(-1); } // for debugging: initialize elements - for ( p = tempPtr ; p < tempPtr+i ; p++ ) + for ( p = tempPtr ; p < tempPtr+i ; p++ ) { *p = 1; /*dummy*/ } @@ -743,19 +736,19 @@ allocMemProfiling_xx(long i) return tempPtr; } -void -freeTick(TickList *tick) +void +freeTick(TickList *tick) { ObjectList *o, *n_o; RegionList *r, *n_r; debug(printf("[freeTick...")); r = tick->fRegion; - while( r ) + while( r ) { - n_r = r->nRegion; + n_r = r->nRegion; o = r->fObj; - while( o ) + while( o ) { n_o = o->nObj; free(o); @@ -771,8 +764,8 @@ freeTick(TickList *tick) * AlarmHandler: * * Handler function used to profile regions. * *------------------------------------------------------*/ -void -AlarmHandler() +void +AlarmHandler() { timeToProfile = 1; signal(signalType, AlarmHandler); // setup signal again @@ -782,11 +775,11 @@ AlarmHandler() * ProfileTick: Update the tick list by traversing all regions. * *-------------------------------------------------------------------*/ -static inline void +static inline void profileObj(ObjectDesc *fObj, ObjectList *newObj, RegionList *newRegion, - long *infiniteObjectUse, long *infiniteObjectDescUse) + long *infiniteObjectUse, long *infiniteObjectDescUse) { - if ( lookupObjectListTable(fObj->atId) == NULL ) + if ( lookupObjectListTable(fObj->atId) == NULL ) { // Allocate new object newObj = (ObjectList *)allocMemProfiling_xx(sizeof(ObjectList)); @@ -797,8 +790,8 @@ profileObj(ObjectDesc *fObj, ObjectList *newObj, RegionList *newRegion, newRegion->used += fObj->size; newRegion->noObj++; insertObjectListTable(fObj->atId, newObj); - } - else + } + else { newObj = lookupObjectListTable(fObj->atId); newObj->size += fObj->size; @@ -808,52 +801,52 @@ profileObj(ObjectDesc *fObj, ObjectList *newObj, RegionList *newRegion, *infiniteObjectDescUse += sizeObjectDesc; } -static inline void -profileGen(Gen *gen, ObjectList *newObj, RegionList *newRegion, +static inline void +profileGen(Gen *gen, ObjectList *newObj, RegionList *newRegion, long *infiniteObjectUse, long *infiniteObjectDescUse, long *infiniteRegionWaste) { ObjectDesc *fObj; Rp *crp; /* Pointer to a region page. */ - /* Traverse objects in generation gen, except the last region page, - * which is traversed independently; crp always points at the + /* Traverse objects in generation gen, except the last region page, + * which is traversed independently; crp always points at the * beginning of a regionpage(=nPtr|dummy|data). */ - for( crp = clear_fp(gen->fp) ; crp->n ; crp = crp->n ) + for( crp = clear_fp(gen->fp) ; crp->n ; crp = crp->n ) { fObj = (ObjectDesc *) (((long *)crp)+HEADER_WORDS_IN_REGION_PAGE); // crp is a Rp // notPP = 0 means no object allocated - while ( ((long *)fObj < ((long *)crp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE) - && (fObj->atId!=notPP) ) + while ( ((long *)fObj < ((long *)crp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE) + && (fObj->atId!=notPP) ) { profileObj(fObj,newObj,newRegion,infiniteObjectUse,infiniteObjectDescUse); fObj=(ObjectDesc *)(((long*)fObj)+((fObj->size)+sizeObjectDesc)); // Find next object } - newRegion->waste += + newRegion->waste += (long)((((long *)crp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE)-((long *)fObj)); - *infiniteRegionWaste += + *infiniteRegionWaste += (long)((((long *)crp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE)-((long *)fObj)); /* No more objects in current region page. */ } - /* Now we need to traverse the last region page, now pointed + /* Now we need to traverse the last region page, now pointed * to by crp (crp is a Rp) */ fObj = (ObjectDesc *) (((long *)crp)+HEADER_WORDS_IN_REGION_PAGE); - while ( (uintptr_t *)fObj < gen->a ) + while ( (uintptr_t *)fObj < gen->a ) { profileObj(fObj,newObj,newRegion,infiniteObjectUse,infiniteObjectDescUse); fObj=(ObjectDesc *)(((size_t *)fObj)+((fObj->size)+sizeObjectDesc)); /* Find next object. */ } - newRegion->waste += + newRegion->waste += (size_t)((((size_t *)crp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE)-((size_t *)fObj)); - *infiniteRegionWaste += + *infiniteRegionWaste += (size_t)((((size_t *)crp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE)-((size_t *)fObj)); - + /* No more objects in the last region page. */ } -void -profileTick(long *stackTop) +void +profileTick(long *stackTop) { TickList *newTick; FiniteRegionDesc *frd; @@ -872,21 +865,21 @@ profileTick(long *stackTop) /* checkProfTab("profileTick.enter"); */ - doing_prof = 1; /* Mutex on profilig */ + doing_prof = 1; /* Mutex on profilig */ debug(printf("Entering profileTick\n")); - if ( profType == noTimer ) + if ( profType == noTimer ) { - tempAntal ++; - if ( tempAntal < profNo ) + tempCount ++; + if ( tempCount < profNo ) return; - tempAntal = 0; - } + tempCount = 0; + } else { timeToProfile = 0; // We use timer so no profiling before next tick } - + if ( verboseProfileTick ) { fprintf(stderr,"profileTick -- ENTER\n"); @@ -903,12 +896,12 @@ profileTick(long *stackTop) /* Allocate new tick. */ newTick = (TickList *)allocMemProfiling_xx(sizeof(TickList)); - newTick->stackUse = ((long *)stackBot)-((long *)stackTop); - maxStackP = (long *) min((unsigned long)maxStackP, (unsigned long)stackTop); + newTick->stackUse = stackBot - stackTop; //maybe +1 + maxStackP = (long*) min((unsigned long)maxStackP, (unsigned long)stackTop); - /* printf("Stackuse at entry %d, stackbot: %x, stackTop: %x\n", newTick->stackUse, stackBot, stackTop); */ + //printf("Stackuse at entry %ld, stackbot: %p, stackTop: %p\n", newTick->stackUse, stackBot, stackTop); - if ( newTick->stackUse < 0 ) + if ( newTick->stackUse < 0 ) { sprintf(errorStr, "ERROR1 - PROFILE_TICK -- stackUse in profileTick less than zero %ld (bot %p, top %p)\n", newTick->stackUse, stackBot, stackTop); @@ -918,18 +911,18 @@ profileTick(long *stackTop) newTick->regionDescUse = 0; cpuTimeAcc += (unsigned long)(((unsigned long)clock())-lastCpuTime); newTick->time = cpuTimeAcc; - if ( tellTime == 1 ) + if ( tellTime == 1 ) { fprintf(stderr,"The time is: %ld\n", cpuTimeAcc); tellTime = 0; } - newTick->nTick = NULL; - newTick->fRegion = NULL; - if (firstTick == NULL) - firstTick = newTick; - else - lastTick->nTick = newTick; - lastTick = newTick; + newTick->nTick = NULL; + newTick->fRegion = NULL; + if (firstTick == NULL) + firstTick = newTick; + else + lastTick->nTick = newTick; + lastTick = newTick; /* Initialize hash table for regions. */ initializeRegionListTable(); @@ -938,13 +931,13 @@ profileTick(long *stackTop) /* Traverse finite region list. */ /********************************/ - for ( frd = topFiniteRegion ; frd ; frd = frd->p ) + for ( frd = topFiniteRegion ; frd ; frd = frd->p ) { finiteRegionDescUse += sizeFiniteRegionDesc; finiteObjectDescUse += sizeObjectDesc; newTick->stackUse -= sizeFiniteRegionDesc; newTick->stackUse -= sizeObjectDesc; - if (newTick->stackUse < 0) + if (newTick->stackUse < 0) { sprintf(errorStr, "ERROR2 - PROFILE_TICK -- stackUse in profileTick less than zero %ld\n", newTick->stackUse); @@ -952,22 +945,24 @@ profileTick(long *stackTop) } fObj = (ObjectDesc *) (frd+1); - /* printf("FiniteRegionInfo: regionId: %d, pPoint: %d, size: %d, stackuse: %d, stacksize: %d\n", - frd->regionId, fObj->atId, fObj->size, newTick->stackUse, - ((int *)stackBot)-((int *)stackTop)); 2001-05-11, Niels */ - - if ( fObj->size >= ALLOCATABLE_WORDS_IN_REGION_PAGE ) + //printf("FiniteRegionInfo: regionId: %ld, pPoint: %ld, size: %ld, stackuse: %ld, stacksize: %ld\n", + // frd->regionId, fObj->atId, fObj->size, newTick->stackUse, + // stackBot - stackTop); // 2001-05-11, Niels + + if ( fObj->size >= ALLOCATABLE_WORDS_IN_REGION_PAGE ) { - sprintf(errorStr, "ERROR - PROFILE_TICK -- Size quite big, pp: %zu with \ - size %zu, fObj-1: %zu, fObj %zu in finite region %lu\n", + sprintf(errorStr, "ERROR - PROFILE_TICK -- Size quite big, pp: %zu with size: %zu, fObj-1: %zu, fObj: %zu in finite region: %lu\n", fObj->atId, fObj->size, *(((size_t*)fObj)-1), (size_t)fObj, frd->regionId); profileERROR(errorStr); } - + newTick->stackUse -= fObj->size; + //fprintf(stderr,"NOTE PROFILE_TICK -- stackUse: %ld, after object with size %zu, stackBot: %p, stackTop: %p\n", + // newTick->stackUse, fObj->size, stackBot, stackTop); + finiteObjectUse += fObj->size; - if ( newTick->stackUse < 0 ) + if ( newTick->stackUse < 0 ) { fprintf(stderr,"ERROR3 - PROFILE_TICK -- stackUse in profileTick less than \ zero %ld, after object with size %zu and pp %zu, stackBot: %p, stackTop: %p\n", @@ -975,12 +970,12 @@ profileTick(long *stackTop) profileERROR(errorStr); } - if ( lookupRegionListTable(frd->regionId) == NULL ) + if ( lookupRegionListTable(frd->regionId) == NULL ) { newRegion = (RegionList *)allocMemProfiling_xx(sizeof(RegionList)); newRegion->regionId = frd->regionId; - newRegion->used = fObj->size; - newRegion->waste = 0; + newRegion->used = fObj->size; + newRegion->waste = 0; newRegion->noObj = 1; newRegion->infinite = 0; newRegion->nRegion = newTick->fRegion; @@ -991,12 +986,12 @@ profileTick(long *stackTop) newObj->size = fObj->size; newObj->nObj = NULL; insertRegionListTable(frd->regionId, newRegion); - } - else + } + else { newRegion = lookupRegionListTable(frd->regionId); - if ( newRegion->infinite ) - { + if ( newRegion->infinite ) + { // for check only sprintf(errorStr, "ERROR - PROFILE_TICK -- finite region %3ld is allocated as infinite. \n", newRegion->regionId); @@ -1012,8 +1007,8 @@ profileTick(long *stackTop) newObj = tempObj; } - if ( newObj == NULL ) - { + if ( newObj == NULL ) + { // Allocate new object newObj = (ObjectList *)allocMemProfiling_xx(sizeof(ObjectList)); newObj->atId = fObj->atId; @@ -1021,8 +1016,8 @@ profileTick(long *stackTop) newObj->nObj = newRegion->fObj; newRegion->fObj = newObj; newRegion->noObj++; - } - else + } + else { newObj->size += fObj->size; } @@ -1033,14 +1028,17 @@ profileTick(long *stackTop) /* Traverse infinite region list. */ /**********************************/ - for ( rd = TOP_REGION ; rd ; rd = rd->p ) + for ( rd = TOP_REGION ; rd ; rd = rd->p ) { - - /* printf("ERROR4 -PROFILE_TICK -- stackUse in profileTick less than zero %d, regionId: %d\n", - newTick->stackUse, rd->regionId); */ + //printf("INF REGION PROFILE_TICK -- stackUse: %ld, regionId: %ld\n", + // newTick->stackUse, rd->regionId); newTick->stackUse -= sizeRo; // size of infinite region desc - if (newTick->stackUse < 0) + + //printf("INF REGION PROFILE_TICK -- stackUse after subtract of sizeRo: %ld\n", + // newTick->stackUse); + + if (newTick->stackUse < 0) { sprintf(errorStr, "ERROR4 -PROFILE_TICK -- stackUse in profileTick less than zero %ld\n", newTick->stackUse); @@ -1048,24 +1046,24 @@ profileTick(long *stackTop) } newTick->regionDescUse += (sizeRo-sizeRoProf); // size of infinite region desc without prof regionDescUseProf += sizeRoProf; // size of profiling fields in inf reg desc - if ( lookupRegionListTable(rd->regionId) == NULL ) + if ( lookupRegionListTable(rd->regionId) == NULL ) { newRegion = (RegionList *)allocMemProfiling_xx(sizeof(RegionList)); newRegion->regionId = rd->regionId; newRegion->used = 0; - newRegion->waste = 0; + newRegion->waste = 0; newRegion->noObj = 0; newRegion->infinite = 1; newRegion->nRegion = newTick->fRegion; newTick->fRegion = newRegion; newRegion->fObj = NULL; insertRegionListTable(rd->regionId, newRegion); - } - else + } + else { newRegion = lookupRegionListTable(rd->regionId); - if ( newRegion->infinite != 1 ) - { + if ( newRegion->infinite != 1 ) + { // For check only sprintf(errorStr, "ERROR - PROFILE_TICK -- infinite region %3ld is allocated as finite. \n", newRegion->regionId); @@ -1075,14 +1073,14 @@ profileTick(long *stackTop) // Initialize hash table for objects initializeObjectListTable(); - + for ( newObj = newRegion->fObj ; newObj ; newObj = newObj->nObj ) { insertObjectListTable(newObj->atId, newObj); } - /* Traverse objects in current region, except the last region page, - * which is traversed independently; crp always points at the + /* Traverse objects in current region, except the last region page, + * which is traversed independently; crp always points at the * beginning of a regionpage(=nPtr|dummy|data). */ profileGen(&(rd->g0),newObj,newRegion,&infiniteObjectUse, &infiniteObjectDescUse,&infiniteRegionWaste); @@ -1092,44 +1090,44 @@ profileTick(long *stackTop) &infiniteObjectDescUse,&infiniteRegionWaste); #endif /* ENABLE_GEN_GC */ } - + lastCpuTime = (unsigned int)clock(); - - if ( verboseProfileTick ) - { + + if ( verboseProfileTick ) + { fprintf(stderr,"Memory use on the stack at time %ld (in bytes)\n", newTick->time); - fprintf(stderr," Infinite region descriptors..........: %10ld\n", newTick->regionDescUse*(sizeof(void *))); - fprintf(stderr," Objects allocated in finite regions..: %10ld\n", finiteObjectUse*(sizeof(void *))); - fprintf(stderr," Other data on the stack..............: %10ld\n", newTick->stackUse*(sizeof(void *))); + fprintf(stderr," Infinite region descriptors..........: %10ld\n", newTick->regionDescUse*(sizeof(long*))); + fprintf(stderr," Objects allocated in finite regions..: %10ld\n", finiteObjectUse*(sizeof(long*))); + fprintf(stderr," Other data on the stack..............: %10ld\n", newTick->stackUse*(sizeof(long*))); fprintf(stderr," Total allocated data by program........: %10ld\n\n", - (newTick->regionDescUse+finiteObjectUse+newTick->stackUse)*(sizeof(void *))); - fprintf(stderr," Finite region descriptors............: %10ld\n", finiteRegionDescUse*(sizeof(void *))); - fprintf(stderr," Prof. fields in infinite region desc.: %10ld\n", regionDescUseProf*(sizeof(void *))); - fprintf(stderr," Object descriptors in finite regions.: %10ld\n", finiteObjectDescUse*(sizeof(void *))); - fprintf(stderr," Total allocated data by profiler.......: %10ld\n", (finiteRegionDescUse+finiteObjectDescUse+regionDescUseProf)*(sizeof(void *))); + (newTick->regionDescUse+finiteObjectUse+newTick->stackUse)*(sizeof(long*))); + fprintf(stderr," Finite region descriptors............: %10ld\n", finiteRegionDescUse*(sizeof(long*))); + fprintf(stderr," Prof. fields in infinite region desc.: %10ld\n", regionDescUseProf*(sizeof(long*))); + fprintf(stderr," Object descriptors in finite regions.: %10ld\n", finiteObjectDescUse*(sizeof(long*))); + fprintf(stderr," Total allocated data by profiler.......: %10ld\n", (finiteRegionDescUse+finiteObjectDescUse+regionDescUseProf)*(sizeof(long*))); fprintf(stderr," Total stack use..........................: %10ld\n", - (newTick->regionDescUse+finiteObjectUse+newTick->stackUse+finiteRegionDescUse+finiteObjectDescUse+regionDescUseProf)*(sizeof(void *))); - + (newTick->regionDescUse+finiteObjectUse+newTick->stackUse+finiteRegionDescUse+finiteObjectDescUse+regionDescUseProf)*(sizeof(long*))); + if (((newTick->regionDescUse+finiteObjectUse+newTick->stackUse+ - finiteRegionDescUse+finiteObjectDescUse+regionDescUseProf)*(sizeof(void *))) != (stackBot-stackTop)*(sizeof(void *))) + finiteRegionDescUse+finiteObjectDescUse+regionDescUseProf)*(sizeof(long*))) != (stackBot-stackTop)*(sizeof(long*))) fprintf(stderr,"ERROR -- stacksize error in ProfileTick\n"); - + fprintf(stderr,"Memory use in regions at time %ld (in bytes)\n", newTick->time); fprintf(stderr," Objects allocated in infinite regions..: %10ld\n", infiniteObjectUse); fprintf(stderr," Object descriptors in infinite regions.: %10ld\n", infiniteObjectDescUse); fprintf(stderr," Total waste in region pages............: %10ld\n", infiniteRegionWaste); - fprintf(stderr," Total memory allocated to region pages...: %10ld\n", - (infiniteObjectUse+infiniteObjectDescUse+infiniteRegionWaste)*(sizeof(void *))); - if ( ((infiniteObjectUse+infiniteObjectDescUse+infiniteRegionWaste)*(sizeof(void *))) % ALLOCATABLE_WORDS_IN_REGION_PAGE != 0 ) + fprintf(stderr," Total memory allocated to region pages...: %10ld\n", + (infiniteObjectUse+infiniteObjectDescUse+infiniteRegionWaste)*(sizeof(long*))); + if ( ((infiniteObjectUse+infiniteObjectDescUse+infiniteRegionWaste)*(sizeof(long*))) % ALLOCATABLE_WORDS_IN_REGION_PAGE != 0 ) fprintf(stderr,"ERROR -- region page size error in profileTick\n"); - + fprintf(stderr,"profileTick -- LEAVE\n"); } - + outputProfileTick(newTick); freeTick(newTick); - - if ( profileON && profType != noTimer ) + + if ( profileON && profType != noTimer ) { profiling_on(); } @@ -1137,29 +1135,29 @@ profileTick(long *stackTop) doing_prof = 0; /* checkProfTab("profileTick.exit"); */ - - if (raised_exn_interupt_prof) - raise_exn((int)&exn_INTERRUPT); + + if (raised_exn_interupt_prof) + raise_exn((uintptr_t)&exn_INTERRUPT); if (raised_exn_overflow_prof) - raise_exn((int)&exn_OVERFLOW); + raise_exn((uintptr_t)&exn_OVERFLOW); } /*-------------------------------------------------------------------* * PrintProfile: Print all collected data on screen. * *-------------------------------------------------------------------*/ -void -printProfile(void) +void +printProfile(void) { TickList *newTick; ObjectList *newObj; RegionList *newRegion; - for ( newTick = firstTick ; newTick ; newTick = newTick->nTick ) + for ( newTick = firstTick ; newTick ; newTick = newTick->nTick ) { fprintf(stderr,"Starting new tick.\n"); - for ( newRegion = newTick->fRegion ; newRegion ; newRegion = newRegion->nRegion ) + for ( newRegion = newTick->fRegion ; newRegion ; newRegion = newRegion->nRegion ) { - if ( newRegion->infinite ) + if ( newRegion->infinite ) { fprintf(stderr," Infinite region: %3ld, used: %3ld, waste: %3ld, noObj: %3ld, Infinite: %3ld.\n", newRegion->regionId, newRegion->used, newRegion->waste, @@ -1171,7 +1169,7 @@ printProfile(void) newRegion->regionId, newRegion->used, newRegion->waste, newRegion->noObj,newRegion->infinite); } - for ( newObj = newRegion->fObj ; newObj ; newObj = newObj->nObj ) + for ( newObj = newRegion->fObj ; newObj ; newObj = newObj->nObj ) { fprintf(stderr," Starting new object with allocation point %3ld, and size %3ld.\n", newObj->atId, newObj->size); @@ -1216,21 +1214,21 @@ printProfile(void) * regionId, MaxAlloc * *----------------------------------------------------------------*/ -void -outputProfilePre(void) +void +outputProfilePre(void) { debug(printf("[outputProfilePre...")); - if ( exportProfileDatafile ) + if ( exportProfileDatafile ) { - if ((logFile_xx = fopen((char *) &logName_xx, "w")) == NULL) { + if ((logFile = fopen((char *) &logName, "w")) == NULL) { fprintf(stderr,"Cannot open logfile.\n"); exit(-1); } } - putw(42424242, logFile_xx); /* dummy maxAlloc, updated in outputProfilePost */ - putw(42424242, logFile_xx); /* dummy noOfTicks, updated in outputProfilePost */ + putw(42424242, logFile); /* dummy maxAlloc, updated in outputProfilePost */ + putw(42424242, logFile); /* dummy noOfTicks, updated in outputProfilePost */ noOfTickInFile = 0; /* Initialize counter tick-counter */ @@ -1239,39 +1237,39 @@ outputProfilePre(void) return; } -void -outputProfileTick(TickList *tick) +void +outputProfileTick(TickList *tick) { - int noOfRegions; + long noOfRegions; ObjectList *newObj; RegionList *newRegion; debug(printf("[outputProfileTick...")); - if (exportProfileDatafile) + if (exportProfileDatafile) { noOfTickInFile++; /* Increment no of tick-counter */ noOfRegions = 0; for (newRegion = tick->fRegion ; newRegion ; newRegion = newRegion->nRegion ) noOfRegions++; - putw(noOfRegions, logFile_xx); - putw(tick->stackUse, logFile_xx); - putw(tick->regionDescUse, logFile_xx); - putw(tick->time, logFile_xx); + putw(noOfRegions, logFile); + putw(tick->stackUse, logFile); + putw(tick->regionDescUse, logFile); + putw(tick->time, logFile); - for (newRegion = tick->fRegion ; newRegion ; newRegion = newRegion->nRegion ) + for (newRegion = tick->fRegion ; newRegion ; newRegion = newRegion->nRegion ) { - putw(newRegion->regionId, logFile_xx); - putw(newRegion->used, logFile_xx); - putw(newRegion->waste, logFile_xx); - putw(newRegion->noObj, logFile_xx); - putw(newRegion->infinite, logFile_xx); + putw(newRegion->regionId, logFile); + putw(newRegion->used, logFile); + putw(newRegion->waste, logFile); + putw(newRegion->noObj, logFile); + putw(newRegion->infinite, logFile); - for ( newObj = newRegion->fObj ; newObj ; newObj = newObj->nObj ) + for ( newObj = newRegion->fObj ; newObj ; newObj = newObj->nObj ) { - putw(newObj->atId, logFile_xx); - putw(newObj->size, logFile_xx); + putw(newObj->atId, logFile); + putw(newObj->size, logFile); } } } @@ -1279,28 +1277,28 @@ outputProfileTick(TickList *tick) return; } -void -outputProfilePost(void) +void +outputProfilePost(void) { - int i; + long i; ProfTabList* p; debug(printf("[outputProfilePost...")); /* Output profTab to log file. */ - putw(profTabSize(), logFile_xx); - for ( i = 0 ; i < PROF_HASH_TABLE_SIZE ; i++ ) - for (p=profHashTab[i]; p != NULL; p=p->next) + putw(profTabSize(), logFile); + for ( i = 0 ; i < PROF_HASH_TABLE_SIZE ; i++ ) + for (p=profHashTab[i]; p != NULL; p=p->next) { - putw(p->regionId, logFile_xx); - putw(p->maxAlloc, logFile_xx); + putw(p->regionId, logFile); + putw(p->maxAlloc, logFile); } - fseek(logFile_xx, 0, SEEK_SET); // seek to the beginning of file - putw(maxAlloc, logFile_xx); // overwrite first two words - putw(noOfTickInFile, logFile_xx); - fclose(logFile_xx); - debug(printf("]")); + fseek(logFile, 0, SEEK_SET); // seek to the beginning of file + putw(maxAlloc, logFile); // overwrite first two words + putw(noOfTickInFile, logFile); + fclose(logFile); + debug(printf("]")); return; } @@ -1311,16 +1309,16 @@ void calcAllocInGen(Gen *gen,long *alloc, long *allocProf) ObjectDesc *fObj; Rp *crp; /* Pointer to a region page. */ - /* Traverse objects in generation gen, except the last region page, - * which is traversed independently; crp always points at the + /* Traverse objects in generation gen, except the last region page, + * which is traversed independently; crp always points at the * beginning of a regionpage(=nPtr|dummy|data). */ - for( crp = clear_fp(gen->fp) ; crp->n ; crp = crp->n ) + for( crp = clear_fp(gen->fp) ; crp->n ; crp = crp->n ) { fObj = (ObjectDesc *) (((size_t *)crp)+HEADER_WORDS_IN_REGION_PAGE); // crp is a Rp // notPP = 0 means no object allocated - while ( ((size_t *)fObj < ((size_t *)crp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE) - && (fObj->atId!=notPP) ) + while ( ((size_t *)fObj < ((size_t *)crp)+ALLOCATABLE_WORDS_IN_REGION_PAGE+HEADER_WORDS_IN_REGION_PAGE) + && (fObj->atId!=notPP) ) { *alloc += fObj->size; *allocProf += sizeObjectDesc; @@ -1328,11 +1326,11 @@ void calcAllocInGen(Gen *gen,long *alloc, long *allocProf) } /* No more objects in current region page. */ } - - /* Now we need to traverse the last region page, now pointed + + /* Now we need to traverse the last region page, now pointed * to by crp (crp is a Rp) */ fObj = (ObjectDesc *) (((size_t *)crp)+HEADER_WORDS_IN_REGION_PAGE); - while ( (uintptr_t *)fObj < gen->a ) + while ( (uintptr_t *)fObj < gen->a ) { *alloc += fObj->size; *allocProf += sizeObjectDesc; @@ -1344,7 +1342,7 @@ void calcAllocInGen(Gen *gen,long *alloc, long *allocProf) #else /*PROFILING is not defined */ -void +void queueMark(StringDesc *str) { return; diff --git a/src/Runtime/Profiling.h b/src/Runtime/Profiling.h index 2c6dd7d1a..34e3e342d 100644 --- a/src/Runtime/Profiling.h +++ b/src/Runtime/Profiling.h @@ -13,8 +13,8 @@ typedef struct objectList { long atId; /* Allocation point identifier. */ - long size; /* Size of object in bytes. */ - struct objectList *nObj; /* Pointer to next object. */ + long size; /* Size of object in words. */ + struct objectList *nObj; /* Pointer to next object. */ } ObjectList; typedef struct regionList { @@ -23,22 +23,22 @@ typedef struct regionList { long waste; /* number of not used words in the region. */ long noObj; /* number of objects with different program points. */ long infinite; /* is region finite of infinite. */ - ObjectList *fObj; /* Pointer to first object. */ - struct regionList * nRegion; /* Pointer to next region. */ + ObjectList *fObj; /* Pointer to first object. */ + struct regionList * nRegion; /* Pointer to next region. */ } RegionList; typedef struct tickList { - RegionList * fRegion; /* Pointer to first region. */ + RegionList * fRegion; /* Pointer to first region. */ long stackUse; /* Number of words used on the stack excl. regions. */ long regionDescUse; /* Number of words used to infinite regiondescriptors on the stack. */ unsigned long time; /* Number of 1/CLOCKS_PER_SEC seconds after start (excl. profiling.) */ - struct tickList * nTick; /* Pointer to data for the next tick. */ + struct tickList * nTick; /* Pointer to data for the next tick. */ } TickList; /* -------------------------------------------------- - * The following two type definitions are for - * holding objects for internal fast lookup + * The following two type definitions are for + * holding objects for internal fast lookup * during a profile tick; see function profileTick(). * -------------------------------------------------- */ @@ -51,7 +51,7 @@ typedef struct regionListHashList { typedef struct objectListHashList { long atId; struct objectList * ol; /* entry */ - struct objectListHashList * next; /* next hashed element */ + struct objectListHashList * next; /* next hashed element */ } ObjectListHashList; #define REGION_LIST_HASH_TABLE_SIZE 4096 @@ -82,11 +82,6 @@ typedef struct profTabList { /* size of hash table */ -/* -#define PROF_HASH_TABLE_SIZE 3881 -#define profHashTabIndex(regionId) ((regionId) % PROF_HASH_TABLE_SIZE) -*/ - #define PROF_HASH_TABLE_SIZE 4096 #define profHashTabIndex(regionId) ((regionId) & (PROF_HASH_TABLE_SIZE-1)) @@ -102,7 +97,7 @@ void profileTick(long *stackTop); void profiling_on(void); void profiling_off(void); void AlarmHandler(); -//void Statistik(); + void resetProfiler(); void queueMarkProf(); /* tell the time next time there is a profile tick */ char *allocMemProfiling_xx(long i); diff --git a/src/Runtime/Region.c b/src/Runtime/Region.c index 9332145f5..3435e3d37 100644 --- a/src/Runtime/Region.c +++ b/src/Runtime/Region.c @@ -29,8 +29,8 @@ extern Ns_Mutex freelistMutex; #if ( REGION_PAGE_STAT ) -RegionPageMap* -regionPageMapInsert(RegionPageMap* regionPageMap, unsigned int addr) +RegionPageMap* +regionPageMapInsert(RegionPageMap* regionPageMap, uintptr_t addr) { int index; RegionPageMapHashList* newElem; @@ -47,27 +47,27 @@ regionPageMapInsert(RegionPageMap* regionPageMap, unsigned int addr) newElem->next = regionPageMap[index]; regionPageMap[index] = newElem; - return regionPageMap; /* We want to allow for hash-table + return regionPageMap; /* We want to allow for hash-table * resizing in the future */ -} +} /* Create and allocate space for a new regionPageMapHashTable */ -void +void regionPageMapZero(RegionPageMap* regionPageMap) { int i; - for ( i = 0 ; i < REGION_PAGE_MAP_HASH_TABLE_SIZE ; i++ ) + for ( i = 0 ; i < REGION_PAGE_MAP_HASH_TABLE_SIZE ; i++ ) { regionPageMap[i] = NULL; } } -RegionPageMap* -regionPageMapNew(void) +RegionPageMap* +regionPageMapNew(void) { RegionPageMap* regionPageMap; - regionPageMap = (RegionPageMap*)malloc(sizeof(void *) * REGION_PAGE_MAP_HASH_TABLE_SIZE); + regionPageMap = (RegionPageMap*)malloc(sizeof(long*) * REGION_PAGE_MAP_HASH_TABLE_SIZE); if ( regionPageMap == NULL ) { die("Unable to allocate memory for RegionPageMapHashTable"); } @@ -77,27 +77,27 @@ regionPageMapNew(void) } RegionPageMap* -regionPageMapIncr(RegionPageMap* regionPageMap, unsigned int addr) +regionPageMapIncr(RegionPageMap* regionPageMap, uintptr_t addr) { RegionPageMapHashList* p; - for ( p = regionPageMap[hashRegionPageIndex(addr)]; p != NULL ; p = p->next ) + for ( p = regionPageMap[hashRegionPageIndex(addr)]; p != NULL ; p = p->next ) { - if ( p->addr == addr ) + if ( p->addr == addr ) { p->n++; return regionPageMap; } } return regionPageMapInsert(regionPageMap,addr); -} +} uintptr_t regionPageMapLookup(RegionPageMap* regionPageMap, uintptr_t addr) { RegionPageMapHashList* p; - for ( p = regionPageMap[hashRegionPageIndex(addr)]; p != NULL ; p = p->next ) + for ( p = regionPageMap[hashRegionPageIndex(addr)]; p != NULL ; p = p->next ) { - if ( p->addr == addr ) + if ( p->addr == addr ) { return p->n; } @@ -111,7 +111,7 @@ regionPageMapClear(RegionPageMap* regionPageMap) int i; RegionPageMapHashList *p, *n; - for ( i = 0 ; i < REGION_PAGE_MAP_HASH_TABLE_SIZE ; i++ ) + for ( i = 0 ; i < REGION_PAGE_MAP_HASH_TABLE_SIZE ; i++ ) { p = regionPageMap[i]; while ( p ) @@ -125,9 +125,9 @@ regionPageMapClear(RegionPageMap* regionPageMap) } RegionPageMap* rpMap = NULL; -#define REGION_PAGE_MAP_INCR(rp) (regionPageMapIncr(rpMap,(unsigned int)(rp))); +#define REGION_PAGE_MAP_INCR(rp) (regionPageMapIncr(rpMap,(uintptr_t)(rp))); #else -#define REGION_PAGE_MAP_INCR(rp) +#define REGION_PAGE_MAP_INCR(rp) #endif /* REGION_PAGE_STAT */ /*----------------------------------------------------------------* @@ -140,9 +140,9 @@ Ro * topRegion; #endif #ifdef ENABLE_GC -int rp_used = 0; +long rp_used = 0; #endif /* ENABLE_GC */ -int rp_total = 0; +long rp_total = 0; #ifdef PROFILING FiniteRegionDesc * topFiniteRegion = NULL; @@ -162,7 +162,7 @@ unsigned long callsOfDeallocateRegionInf=0, allocNowFin=0, /* Allocated in fin. regions now. */ maxAllocFin=0, /* Max. allocated in fin. regions. */ allocProfNowInf=0, /* Words used on object descriptors in inf. regions. */ - maxAllocProfInf=0, /* At time maxAllocInf how much were + maxAllocProfInf=0, /* At time maxAllocInf how much were used on object descriptors. */ allocProfNowFin=0, /* Words used on object descriptors in fin. regions. */ maxAllocProfFin=0, /* At time maxAllocFin how much were used on object descriptors. */ @@ -182,8 +182,8 @@ unsigned long callsOfDeallocateRegionInf=0, /* called from the assembler file. */ allocatedLobjs=0; /* Total number of allocated large objects allocated with malloc */ -inline static unsigned int -max(unsigned int a, unsigned int b) +inline static unsigned int +max(unsigned int a, unsigned int b) { return (afp, + gen->fp, gen->a, - gen->b); + gen->b); for (rp = clear_fp(gen->fp) ; rp ; rp = clear_tospace_bit(rp->n)) { #ifdef ENABLE_GEN_GC fprintf(stderr," Rp %p, next:%p, colorPtr:%p, data: %p, rp+1: %p\n", rp, rp->n, rp->colorPtr, - &(rp->i), + &(rp->i), rp+1); #else fprintf(stderr," Rp %p, next:%p, data: %p, rp+1: %p\n", @@ -257,8 +257,8 @@ pp_gen(Gen *gen) fprintf(stderr,"]\n"); } -void -pp_reg(Region r, char *str) +void +pp_reg(Region r, char *str) { r = clearStatusBits(r); fprintf(stderr,"printRegionInfo called from: %s\n",str); @@ -271,8 +271,8 @@ pp_reg(Region r, char *str) return; } -void -chk_obj_in_gen(Gen *gen, uintptr_t *obj_ptr, char* s) +void +chk_obj_in_gen(Gen *gen, uintptr_t *obj_ptr, char* s) { Rp* rp; int found = 0; @@ -302,13 +302,13 @@ void printRegionStack() { */ /* Calculate number of pages in a generation */ -inline size_t -NoOfPagesInGen(Gen *gen) +inline size_t +NoOfPagesInGen(Gen *gen) { size_t i; Rp *rp; - debug(printf("[NoOfPagesInGen...")); + debug(printf("[NoOfPagesInGen...")); for ( i = 0, rp = clear_fp(gen->fp) ; rp ; rp = clear_tospace_bit(rp->n) ) i++; @@ -319,8 +319,8 @@ NoOfPagesInGen(Gen *gen) } /* Calculate number of pages in an infinite region. */ -size_t -NoOfPagesInRegion(Region r) +size_t +NoOfPagesInRegion(Region r) { #ifdef ENABLE_GEN_GC return NoOfPagesInGen(&(r->g0)) + NoOfPagesInGen(&(r->g1)); @@ -330,8 +330,8 @@ NoOfPagesInRegion(Region r) } /* -void -printFreeList() +void +printFreeList() { Rp *kp; @@ -350,8 +350,8 @@ printFreeList() #ifdef ENABLE_GC -size_t -size_free_list() +size_t +size_free_list() { Rp *rp; size_t i=0; @@ -376,7 +376,7 @@ size_free_list() * alloc: Allocates n words in a region. * * resetRegion: Resets a region by freeing all pages except one * * deallocateRegionsUntil: All regions above a threshold are deallocated. * - * deallocateRegionsUntil_X86: ---- for stack growing towards -inf * + * deallocateRegionsUntil_X64: ---- for stack growing towards -inf * *-------------------------------------------------------------------------*/ /*----------------------------------------------------------------------* @@ -385,14 +385,15 @@ size_free_list() * The second argument is a pointer to the generation in r to use * * Important: alloc_new_block must preserve all marks in fp (Region.h) * *----------------------------------------------------------------------*/ -void -alloc_new_block(Gen *gen) -{ +void +alloc_new_block(Gen *gen) +{ Rp* np; -#ifdef PROFILING + debug(printf("[alloc_new_block: gen: %p", gen);) +#ifdef PROFILING Ro *r; r = get_ro_from_gen(*gen); -#endif /* PROFILING */ +#endif /* PROFILING */ #ifdef PROFILING profTabIncrNoOfPages(r->regionId, 1); @@ -402,9 +403,9 @@ alloc_new_block(Gen *gen) #ifdef ENABLE_GC rp_used++; - if ( (!disable_gc) && (!time_to_gc) ) + if ( (!disable_gc) && (!time_to_gc) ) { - // the treshold suggests when we can garbage collect without allocating + // the treshold suggests when we can garbage collect without allocating // more memory. // double treshold = (double)rp_total - (((double)rp_total) / heap_to_live_ratio); if ( rp_used > rp_gc_treshold ) @@ -421,7 +422,7 @@ alloc_new_block(Gen *gen) #endif /* ENABLE_GC */ LOCK_LOCK(FREELISTMUTEX); - if ( freelist == NULL ) callSbrk(); + if ( freelist == NULL ) callSbrk(); np = freelist; freelist = freelist->n; @@ -437,20 +438,20 @@ alloc_new_block(Gen *gen) // udefinerede? Det tror jeg faktisk ikke. Dem i g0 anvendes til at // angive farve ved what gen to alloc to og i g1 anvendes de i // points_in_tospace. - np->colorPtr = (uintptr_t *)(&(np->i)); + np->colorPtr = (uintptr_t *)(&(np->i)); #endif /* ENABLE_GEN_GC */ #ifdef ENABLE_GC - if ( doing_gc + if ( doing_gc #ifdef ENABLE_GEN_GC && ( major_p || !is_gen_1(*gen) ) #endif ) np->n = set_tospace_bit(NULL); // to-space bit - else + else #endif np->n = NULL; - np->gen = gen; // Install origin-pointer to generation - used by GC + np->gen = gen; // Install origin-pointer to generation - used by GC if ( clear_fp(gen->fp) ) #ifdef ENABLE_GC @@ -462,18 +463,20 @@ alloc_new_block(Gen *gen) (((Rp *)(gen->b))-1)->n = np; // Updates the next field in the last region page. else { #ifdef ENABLE_GC - int rt; + uintptr_t rt; if ( (rt = all_marks_fp(*gen)) /* was rtype(*gen) 2003-08-06, nh */ ) { gen->fp = np; /* Update pointer to the first page. */ set_fp(*gen,rt); } - else + else #endif gen->fp = np; /* Update pointer to the first page. */ } gen->a = (uintptr_t *) (&(np->i)); /* Updates the allocation pointer. */ gen->b = (uintptr_t *) (np+1); /* Updates the border pointer. */ + + debug(printf("]\n");) } /*----------------------------------------------------------------------* @@ -482,14 +485,14 @@ alloc_new_block(Gen *gen) * Put a region administrationsstructure on the stack. The address is * * in roAddr. * *----------------------------------------------------------------------*/ -static inline Region +static inline Region allocateRegion0(Region r #ifdef KAM , Region* topRegionCell #endif - ) -{ - debug(printf("[allocateRegion (rAddr=%p)...",r)); + ) +{ + debug(printf("[allocateRegion (rAddr=%p)...",r)); r = clearStatusBits(r); r->g0.fp = NULL; @@ -501,19 +504,19 @@ allocateRegion0(Region r set_gen_1(r->g1); // Mark generation alloc_new_block(&(r->g1)); // Allocate the first region page in g1 #endif /* ENABLE_GEN_GC */ - + TOP_REGION = r; debug(printf("]\n")); return r; -} +} Region allocateRegion(Region r #ifdef KAM , Region* topRegionCell #endif - ) + ) { r = allocateRegion0(r #ifdef KAM @@ -525,7 +528,7 @@ allocateRegion(Region r } #ifdef ENABLE_GC -Region +Region allocatePairRegion(Region r) { r = allocateRegion0(r); @@ -537,7 +540,7 @@ allocatePairRegion(Region r) return r; } -Region +Region allocateArrayRegion(Region r) { r = allocateRegion0(r); @@ -549,7 +552,7 @@ allocateArrayRegion(Region r) return r; } -Region +Region allocateRefRegion(Region r) { r = allocateRegion0(r); @@ -561,7 +564,7 @@ allocateRefRegion(Region r) return r; } -Region +Region allocateTripleRegion(Region r) { r = allocateRegion0(r); @@ -578,7 +581,7 @@ void free_lobjs(Lobjs* lobjs) { //if ( lobjs ) // fprintf(stderr, "Freeing large objs: lobjs=%p\n", lobjs); - while ( lobjs ) + while ( lobjs ) { Lobjs* lobjsTmp; @@ -588,10 +591,10 @@ void free_lobjs(Lobjs* lobjs) tag = *((&(lobjs->value)) + sizeObjectDesc); #else tag = lobjs->value; - #endif + #endif lobjs_current -= size_lobj(tag); -#endif +#endif lobjsTmp = clear_lobj_bit(lobjs->next); #ifdef ENABLE_GC free(lobjs->orig); @@ -612,7 +615,7 @@ void deallocateRegion( #ifdef KAM Region* topRegionCell #endif - ) { + ) { #ifdef PROFILING int i; #endif @@ -637,8 +640,8 @@ void deallocateRegion( free_lobjs(TOP_REGION->lobjs); - /* Insert the region pages in the freelist; there is always - * at least one page in a generation. */ + /* Insert the region pages in the freelist; there is always + * at least one page in a generation. */ LOCK_LOCK(FREELISTMUTEX); (((Rp *)TOP_REGION->g0.b)-1)->n = freelist; // Free pages in generation 0 freelist = clear_fp(TOP_REGION->g0.fp); @@ -660,9 +663,9 @@ alloc_lobjs(int n) { Lobjs* lobjs; #ifdef ENABLE_GC char *p; - size_t r; + size_t r; size_t sz_bytes; - sz_bytes = 4*n + sizeof(Lobjs) + 1024; + sz_bytes = sizeof(uintptr_t)*n + sizeof(Lobjs) + 1024; p = malloc(sz_bytes); if ( p == NULL ) die("alloc_lobjs: malloc returned NULL"); @@ -676,12 +679,12 @@ alloc_lobjs(int n) { die("alloc_lobjs: large object is not properly aligned."); lobjs->orig = p; #else - lobjs = (Lobjs*)malloc(4*n + sizeof(Lobjs)); + lobjs = (Lobjs*)malloc(sizeof(uintptr_t)*n + sizeof(Lobjs)); if ( lobjs == NULL ) die("alloc_lobjs: malloc returned NULL"); #endif /* ENABLE_GC */ #ifdef KAM - lobjs->sizeOfLobj = 4*n; + lobjs->sizeOfLobj = sizeof(uintptr_t)*n; #endif return lobjs; } @@ -691,7 +694,7 @@ alloc_lobjs(int n) { * Sbrk is called and the free list is updated. * * The free list has to be empty. * *----------------------------------------------------------------------*/ -void callSbrk() { +void callSbrk() { Rp *np, *old_free_list; char *sb; size_t temp; @@ -705,7 +708,7 @@ void callSbrk() { /* For GC we require 1Kb alignments, that is the size of a region page! */ - sb = malloc(BYTES_ALLOC_BY_SBRK + 1024 /*8*/); + sb = malloc(BYTES_ALLOC_BY_SBRK + sizeof(Rp) + 1024 ); if ( sb == NULL ) { perror("I could not allocate more memory; either no more memory is\navailable or the memory subsystem is detectively corrupted\n"); @@ -713,12 +716,17 @@ void callSbrk() { } /* alignment (martin) */ - if (( temp = (size_t)sb % 1024 )) { - sb = sb + 1024 - temp; + if (( temp = (size_t)(((uintptr_t)sb) % sizeof(Rp) ))) { + sb = sb + sizeof(Rp) - temp; } - if ( ! is_rp_aligned((size_t)sb) ) + if ( ! is_rp_aligned((size_t)sb) ) { + printf ("sb=%p\n", sb); + printf ("sizeof(Rp)=%ld\n", sizeof(Rp)); + printf ("sizeof(uintptr_t)=%ld\n", sizeof(uintptr_t)); + printf ("temp=%ld\n", temp); die("SBRK region page is not properly aligned."); + } old_free_list = freelist; np = (Rp *) sb; @@ -727,7 +735,7 @@ void callSbrk() { rp_total++; /* fragment the SBRK-chunk into region pages */ - while ((void *)(np+1) < ((void *)freelist)+BYTES_ALLOC_BY_SBRK) { + while ((char *)(np+1) < ((char *)freelist)+BYTES_ALLOC_BY_SBRK) { np++; (np-1)->n = np; rp_total++; @@ -751,7 +759,7 @@ void callSbrk() { * malloc. * *----------------------------------------------------------------------*/ inline uintptr_t * -allocGen (Gen *gen, size_t n) { +allocGen (Gen *gen, size_t n) { uintptr_t *t1; uintptr_t *t2; uintptr_t *t3; @@ -761,7 +769,8 @@ allocGen (Gen *gen, size_t n) { uintptr_t *i; #endif - debug(printf("[allocGen... generation: %p", gen)); + debug(printf("[allocGen... generation: %p, n:%zu ", gen,n)); + debug(fflush(stdout)); #ifdef PROFILING r = get_ro_from_gen(*gen); @@ -778,7 +787,7 @@ allocGen (Gen *gen, size_t n) { r->allocProfNow += sizeObjectDesc; #endif /* PROFILING */ - // see if the size of requested memory exceeds + // see if the size of requested memory exceeds // the size of a region page if ( n > ALLOCATABLE_WORDS_IN_REGION_PAGE ) // notice: n is in words @@ -794,14 +803,14 @@ allocGen (Gen *gen, size_t n) { allocatedLobjs++; #endif #ifdef ENABLE_GC - lobjs_current += 4*n; - lobjs_period += 4*n; - if ( (!disable_gc) && (lobjs_current>lobjs_gc_treshold) ) + lobjs_current += sizeof(void*)*n; + lobjs_period += sizeof(void*)*n; + if ( (!disable_gc) && (lobjs_current>lobjs_gc_treshold) ) { time_to_gc = 1; } #endif - // set the constant bit so that GC won't run + // set the constant bit so that GC won't run // through the thing before there is data in the // object. This shouldn't be necessary; mael 2005-11-09 // lobjs->value = set_tag_const(lobjs->value); @@ -809,7 +818,7 @@ allocGen (Gen *gen, size_t n) { } #ifdef ENABLE_GC - alloc_period += 4*n; + alloc_period += sizeof(void*)*n; #endif t1 = gen->a; @@ -818,9 +827,10 @@ allocGen (Gen *gen, size_t n) { t3 = gen->b; if (t2 > t3) { #if defined(PROFILING) || defined(ENABLE_GC) - /* insert zeros in the rest of the current region page */ + /* insert zeros in the rest of the current region page; + * mael 2019-01-28: why is this necessary when just GC is enabled? */ for ( i = t1 ; i < t3 ; i++ ) *i = notPP; - #endif + #endif alloc_new_block(gen); t1 = gen->a; @@ -828,7 +838,16 @@ allocGen (Gen *gen, size_t n) { } gen->a = t2; - debug(printf("]\n")); + #ifdef ENABLE_GC + #ifdef CHECK_GC + if ( points_into_dataspace(t1) ) { + die("allocated value points into dataspace"); + } + #endif /* CHECK_GC */ + #endif /* ENABLE_GC */ + + debug(printf(", t1=%p, t2=%p]\n", t1,t2)); + debug(fflush(stdout)); return t1; } @@ -843,16 +862,16 @@ uintptr_t *alloc (Region r, size_t n) { * the region administration structure is updated. The statusbits are * * not changed. * *----------------------------------------------------------------------*/ -static inline +static inline void resetGen(Gen *gen) { - /* There is always at least one page in a generation. */ + /* There is always at least one page in a generation. */ if ( (clear_fp(gen->fp))->n ) { /* There are more than one page in the generation. */ #ifdef ENABLE_GC rp_used--; // at least one page is freed; see comment in alloc_new_block // concerning conservative computation. -#endif /* ENABLE_GC */ +#endif /* ENABLE_GC */ LOCK_LOCK(FREELISTMUTEX); (((Rp *)(gen->b))-1)->n = freelist; @@ -870,11 +889,11 @@ void resetGen(Gen *gen) return; } -Region -resetRegion(Region rAdr) -{ +Region +resetRegion(Region rAdr) +{ Ro *r; - + #ifdef PROFILING int j; #endif @@ -888,7 +907,7 @@ resetRegion(Region rAdr) j = NoOfPagesInRegion(r); /* There is always at-least one page in a generation. */ - noOfPages -= j-MIN_NO_OF_PAGES_IN_REGION; + noOfPages -= j-MIN_NO_OF_PAGES_IN_REGION; profTabDecrNoOfPages(r->regionId, j-MIN_NO_OF_PAGES_IN_REGION); allocNowInf -= r->allocNow; @@ -921,17 +940,17 @@ resetRegion(Region rAdr) * description. It deallocates all regions that are placed over sp. * * The function does not return or alter anything. * *-------------------------------------------------------------------------*/ -void +void deallocateRegionsUntil(Region r #ifdef KAM , Region* topRegionCell #endif - ) -{ + ) +{ // debug(printf("[deallocateRegionsUntil(r = %x, topFiniteRegion = %x)...\n", r, topFiniteRegion)); r = clearStatusBits(r); - + #ifdef PROFILING callsOfDeallocateRegionsUntil++; while ((FiniteRegionDesc *)r <= topFiniteRegion) @@ -940,8 +959,8 @@ deallocateRegionsUntil(Region r } #endif - while (r <= TOP_REGION) - { + while (r <= TOP_REGION) + { /*printf("r: %0x, top region %0x\n",r,TOP_REGION);*/ deallocateRegion( #ifdef KAM @@ -953,24 +972,26 @@ deallocateRegionsUntil(Region r debug(printf("]\n")); return; -} +} /*-------------------------------------------------------------------------* - *deallocateRegionsUntil_X86: version of the above function working with * + *deallocateRegionsUntil_X64: version of the above function working with * * the stack growing towards negative infinity. * *-------------------------------------------------------------------------*/ #ifndef KAM -void -deallocateRegionsUntil_X86(Region r) -{ - // debug(printf("[deallocateRegionsUntil_X86(r = %x, topFiniteRegion = %x)...\n", r, topFiniteRegion)); +void +deallocateRegionsUntil_X64(Region r) +{ + // debug(printf("[deallocateRegionsUntil_X64(r = %x, topFiniteRegion = %x)...\n", r, topFiniteRegion)); + + debug(printf("[deallocateRegionsUntil_X64(r = %p)...\n", r)); r = clearStatusBits(r); - + #ifdef PROFILING callsOfDeallocateRegionsUntil++; - /* Don't call deallocRegionFiniteProfiling if no finite + /* Don't call deallocRegionFiniteProfiling if no finite * regions are allocated. mael 2001-03-20 */ while ( topFiniteRegion && (FiniteRegionDesc *)r >= topFiniteRegion) { @@ -978,7 +999,7 @@ deallocateRegionsUntil_X86(Region r) } #endif - while (r >= TOP_REGION) + while (r >= TOP_REGION) { /*printf("r: %0x, top region %0x\n",r,TOP_REGION);*/ deallocateRegion(); @@ -987,7 +1008,7 @@ deallocateRegionsUntil_X86(Region r) debug(printf("]\n")); return; -} +} #endif /* not KAM */ @@ -1015,8 +1036,8 @@ deallocateRegionsUntil_X86(Region r) * roAddr points at. * *----------------------------------------------------------------------*/ Region -allocRegionInfiniteProfiling(Region r, size_t regionId) -{ +allocRegionInfiniteProfiling(Region r, size_t regionId) +{ /* printf("[allocRegionInfiniteProfiling r=%x, regionId=%d...", r, regionId);*/ callsOfAllocateRegionInf++; @@ -1051,17 +1072,17 @@ allocRegionInfiniteProfiling(Region r, size_t regionId) return r; } -/* In CodeGenX86, we use a generic function to compile a C-call. The regionId */ +/* In CodeGenX64, we use a generic function to compile a C-call. The regionId */ /* may therefore be tagged, which this stub-function takes care of. */ Region -allocRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) -{ +allocRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +{ return allocRegionInfiniteProfiling(r, convertIntToC(regionId)); } #ifdef ENABLE_GC Region -allocPairRegionInfiniteProfiling(Region r, size_t regionId) +allocPairRegionInfiniteProfiling(Region r, size_t regionId) { r = allocRegionInfiniteProfiling(r, regionId); set_pairregion(clearStatusBits(r)->g0); @@ -1072,7 +1093,7 @@ allocPairRegionInfiniteProfiling(Region r, size_t regionId) } Region -allocArrayRegionInfiniteProfiling(Region r, size_t regionId) +allocArrayRegionInfiniteProfiling(Region r, size_t regionId) { r = allocRegionInfiniteProfiling(r, regionId); set_arrayregion(clearStatusBits(r)->g0); @@ -1084,7 +1105,7 @@ allocArrayRegionInfiniteProfiling(Region r, size_t regionId) } Region -allocRefRegionInfiniteProfiling(Region r, size_t regionId) +allocRefRegionInfiniteProfiling(Region r, size_t regionId) { r = allocRegionInfiniteProfiling(r, regionId); set_refregion(clearStatusBits(r)->g0); @@ -1096,7 +1117,7 @@ allocRefRegionInfiniteProfiling(Region r, size_t regionId) } Region -allocTripleRegionInfiniteProfiling(Region r, size_t regionId) +allocTripleRegionInfiniteProfiling(Region r, size_t regionId) { r = allocRegionInfiniteProfiling(r, regionId); set_tripleregion(clearStatusBits(r)->g0); @@ -1108,8 +1129,8 @@ allocTripleRegionInfiniteProfiling(Region r, size_t regionId) } Region -allocPairRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) -{ +allocPairRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +{ r = allocRegionInfiniteProfiling(r, convertIntToC(regionId)); set_pairregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC @@ -1120,8 +1141,8 @@ allocPairRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) } Region -allocArrayRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) -{ +allocArrayRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +{ r = allocRegionInfiniteProfiling(r, convertIntToC(regionId)); set_arrayregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC @@ -1132,8 +1153,8 @@ allocArrayRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) } Region -allocRefRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) -{ +allocRefRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +{ r = allocRegionInfiniteProfiling(r, convertIntToC(regionId)); set_refregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC @@ -1144,8 +1165,8 @@ allocRefRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) } Region -allocTripleRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) -{ +allocTripleRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +{ r = allocRegionInfiniteProfiling(r, convertIntToC(regionId)); set_tripleregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC @@ -1154,7 +1175,7 @@ allocTripleRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) return r; } -#endif /*ENABLE_GC*/ +#endif /*ENABLE_GC*/ /*-------------------------------------------------------------------------------* * allocRegionFiniteProfiling: * @@ -1165,11 +1186,11 @@ allocTripleRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) * There has to be room on the stack for the finite region descriptor and the * * object descriptor. rdAddr points at the region descriptor when called. * *-------------------------------------------------------------------------------*/ -#define notPrgPoint 1 -void +#define notPrgPoint 1 +void allocRegionFiniteProfiling(FiniteRegionDesc *rdAddr, size_t regionId, size_t size) { - ObjectDesc *objPtr; + ObjectDesc *objPtr; /* printf("[Entering allocRegionFiniteProfiling, rdAddr=%x, regionId=%d, size=%d ...\n", rdAddr, regionId, size); */ @@ -1195,17 +1216,17 @@ allocRegionFiniteProfiling(FiniteRegionDesc *rdAddr, size_t regionId, size_t siz objPtr->atId = notPrgPoint; objPtr->size = size; - debug(printf("exiting, topFiniteRegion = %x, topFiniteRegion->p = %x, &topFiniteRegion = %x]\n", + debug(printf("exiting, topFiniteRegion = %x, topFiniteRegion->p = %x, &topFiniteRegion = %x]\n", topFiniteRegion, topFiniteRegion->p, &topFiniteRegion)); return; } -/* In CodeGenX86, we use a generic function to compile a C-call. The regionId */ +/* In CodeGenX64, we use a generic function to compile a C-call. The regionId */ /* and size may therefore be tagged, which this stub-function takes care of. */ -void -allocRegionFiniteProfilingMaybeUnTag(FiniteRegionDesc *rdAddr, size_t regionId, size_t size) -{ +void +allocRegionFiniteProfilingMaybeUnTag(FiniteRegionDesc *rdAddr, size_t regionId, size_t size) +{ allocRegionFiniteProfiling(rdAddr, convertIntToC(regionId), convertIntToC(size)); return; } @@ -1216,9 +1237,9 @@ allocRegionFiniteProfilingMaybeUnTag(FiniteRegionDesc *rdAddr, size_t regionId, * finite region descriptor, which will be the new stack address. * *-----------------------------------------------------------------*/ void -deallocRegionFiniteProfiling(void) -{ - int size; +deallocRegionFiniteProfiling(void) +{ + long size; /* printf("[Entering deallocRegionFiniteProfiling regionId=%d (topFiniteRegion = %x)...\n", @@ -1248,17 +1269,17 @@ deallocRegionFiniteProfiling(void) * beginning of the user value, as if profiling is not enabled. * *-----------------------------------------------------------------*/ uintptr_t * -allocGenProfiling(Gen *gen, size_t n, size_t pPoint) +allocGenProfiling(Gen *gen, size_t n, size_t pPoint) { uintptr_t *res; debug(printf("[Entering allocProfiling... gen:%x, n:%d, pp:%d.", gen, n, pPoint)); res = allocGen(gen, n+sizeObjectDesc); // allocate object descriptor and object - + ((ObjectDesc *)res)->atId = pPoint; // initialize object descriptor ((ObjectDesc *)res)->size = n; - + res = (uintptr_t *)(((ObjectDesc *)res) + 1); // return pointer to user data debug(printf("exiting]\n")); @@ -1266,14 +1287,14 @@ allocGenProfiling(Gen *gen, size_t n, size_t pPoint) } uintptr_t * -allocProfiling(Region r, size_t n, size_t pPoint) +allocProfiling(Region r, size_t n, size_t pPoint) { return allocGenProfiling(&(clearStatusBits(r)->g0),n,pPoint); } #endif /*PROFILING*/ #ifdef KAM -void +void free_region_pages(Rp* first, Rp* last) { if ( first == 0 ) diff --git a/src/Runtime/Region.h b/src/Runtime/Region.h index 0b1f74e28..6e0008e51 100644 --- a/src/Runtime/Region.h +++ b/src/Runtime/Region.h @@ -6,19 +6,19 @@ #include #include "Flags.h" - + /* Overview -------- -This module defines the runtime representation of regions. +This module defines the runtime representation of regions. There are two types of regions: {\em finite} and {\em infinite}. A region is finite if its (finite) size has been found at compile -time and to which at most one object will ever be written. +time and to which at most one object will ever be written. Otherwise it is infinite. -The runtime representation of a region depends on +The runtime representation of a region depends on (a) whether the region is finite or infinite; (b) whether profiling is turned on or not. @@ -27,7 +27,7 @@ We describe each of the four possibilities in turn. (a) Finite region of size n bytes (n%4==0) -- meaning that every object that may be stored in the region has size at most n bytes: - (i) without profiling, the region is n/4 words on the + (i) without profiling, the region is n/4 words on the runtime stack; (ii) with profiling, the region is represented by first pushing a region descriptor (see below) on the stack, @@ -36,11 +36,11 @@ We describe each of the four possibilities in turn. of finite regions are linked together which the profiler can traverse. (b) Infinite region -- meaning that the region can contain objects - of different sizes. + of different sizes. (i) without profiling, the region is represented by a {\em region descriptor} on the stack. The region descriptor points to the beginning and the end of a linked list of - fixed size region pages (see below). + fixed size region pages (see below). (ii) with profiling, the representation is the same as without profiling, except that the region descriptor contains more fields for profiling statistics. @@ -73,20 +73,28 @@ RegionPageMap* regionPageMapNew(void); extern RegionPageMap* rpMap; #endif /* REGION_PAGE_STAT */ -/* +/* * Number of words that can be allocated in each regionpage and number * of words in the header part of each region page. * - * ALLOCATABLE_WORDS_IN_REGION_PAGE + HEADER_WORDS_IN_REGION_PAGE must + * HEADER_WORDS_IN_REGION_PAGE + ALLOCATABLE_WORDS_IN_REGION_PAGE must * be one 1Kb - used by GC. */ #ifdef ENABLE_GEN_GC -#define ALLOCATABLE_WORDS_IN_REGION_PAGE 253 #define HEADER_WORDS_IN_REGION_PAGE 3 +#if defined(__LP64__) || (__WORDSIZE == 64) +#define ALLOCATABLE_WORDS_IN_REGION_PAGE 125 +#else +#define ALLOCATABLE_WORDS_IN_REGION_PAGE 253 +#endif +#else /* not(ENABLE_GEN_GC) */ +#define HEADER_WORDS_IN_REGION_PAGE 2 +#if defined(__LP64__) || (__WORDSIZE == 64) +#define ALLOCATABLE_WORDS_IN_REGION_PAGE 126 #else #define ALLOCATABLE_WORDS_IN_REGION_PAGE 254 -#define HEADER_WORDS_IN_REGION_PAGE 2 +#endif #endif /* ENABLE_GEN_GC */ typedef struct rp { @@ -98,11 +106,13 @@ typedef struct rp { uintptr_t i[ALLOCATABLE_WORDS_IN_REGION_PAGE]; /* space for data*/ } Rp; -#if defined(__LP64__) || (__WORDSIZE == 64) -#define is_rp_aligned(rp) (((rp) & 0x7FF) == 0) -#else -#define is_rp_aligned(rp) (((rp) & 0x3FF) == 0) -#endif +/* #if defined(__LP64__) || (__WORDSIZE == 64) */ +/* #define SIZE_REGION_PAGE 0x800 */ +/* #else */ +/* #define SIZE_REGION_PAGE 0x400 */ +/* #endif */ + +#define is_rp_aligned(rp) (((rp) & (sizeof(Rp)-1)) == 0) /* Free pages are kept in a free list. When the free list becomes * empty and more space is required, the runtime system calls the @@ -110,7 +120,7 @@ typedef struct rp { * (here 30) of fresh region pages: */ /* Size of allocated space in each SBRK-call. */ -#define BYTES_ALLOC_BY_SBRK REGION_PAGE_BAG_SIZE*sizeof(Rp) +#define BYTES_ALLOC_BY_SBRK REGION_PAGE_BAG_SIZE*sizeof(Rp) /* When garbage collection is enabled, a single bit in a region page * descriptor specifies if the page is part of to-space during garbage @@ -179,24 +189,28 @@ typedef struct lobjs { /* By introducing generational garbage collection we need two region page lists in each region descriptor. We therefore define a sub-structure called Gen (for generation) containing the three - pointers controlling the allocation into a generation: fp, a and b */ + pointers controlling the allocation into a generation: fp, a and + b. */ typedef struct gen { - uintptr_t * a; /* Pointer to first unused word in the newest region page - of the region. */ - uintptr_t * b; /* Pointer to the border of the newest region page, defined as the - address of the first word to follow the region page. One maintains - the invariant a<=b; a=b means the region page is full.*/ - Rp *fp; /* Pointer to the oldest (first allocated) page of the region. - The beginning of the newest page of the region can be calculated - as a fixed offset from b. Thus the region descriptor gives - direct access to both the first and the last region page - of the region. This makes it possible to de-allocate the - entire region in constant time, by appending it to the free list.*/ + uintptr_t * a; /* Pointer to first unused word in the newest region + page of the region. */ + uintptr_t * b; /* Pointer to the border of the newest region page, + defined as the address of the first word to + follow the region page. One maintains the + invariant a<=b; a=b means the region page is + full. */ + Rp *fp; /* Pointer to the oldest (first allocated) page of the + region. The beginning of the newest page of the region + can be calculated as a fixed offset from b. Thus the + region descriptor gives direct access to both the first + and the last region page of the region. This makes it + possible to deallocate the entire region in constant + time, by appending it to the free list. */ } Gen; -/* +/* Region descriptors ------------------ ro is the type of region descriptors. Region descriptors are kept on @@ -210,14 +224,14 @@ are raised) */ #define offsetG1InRo (sizeof(Gen)) /* bytes */ #endif typedef struct ro { - Gen g0; /* g0 is the only generation when ordinary GC is used. g0 + Gen g0; /* g0 is the only generation when ordinary GC is used. g0 is the youngest generation when using generational GC. */ #ifdef ENABLE_GEN_GC Gen g1; /* g1 is the old generation. */ #endif - struct ro * p; /* Pointer to previous region descriptor. It has to be at + struct ro * p; /* Pointer to previous region descriptor. It has to be at the bottom of the structure */ /* here are the extra fields that are used when profiling is turned on: */ @@ -233,7 +247,7 @@ typedef struct ro { typedef Ro* Region; -#define sizeRo (sizeof(Ro)/(sizeof(void *))) /* size of region descriptor in words */ +#define sizeRo (sizeof(Ro)/(sizeof(long*))) /* size of region descriptor in words */ #define sizeRoProf (3) /* We use three words extra when profiling. */ #ifdef ENABLE_GEN_GC @@ -247,7 +261,7 @@ typedef Ro* Region; #define descRo_a(rAddr,w) (rAddr->g0.a = rAddr->g0.a - w) /* Used in IO.inputStream */ -// When GC is enabled, bits in the region descriptor (in the r->g0.fp pointer) +// When GC is enabled, bits in the region descriptor (in the r->g0.fp pointer) // are used to tell the type of values in the region, in the // case that the values are untagged. Because region pages are aligned // on 1k boundaries, plenty of bits are available in the r->g0.fp pointer. @@ -255,15 +269,15 @@ typedef Ro* Region; // // 000 (hex 0x0) ordinary tagged values // 001 (hex 0x1) pairs -// 010 (hex 0x2) arrays (value is tagged, but the region type +// 010 (hex 0x2) arrays (value is tagged, but the region type // is needed by generational collector) // 011 (hex 0x3) refs // 111 (hex 0x7) triples -// To make Generational GC possible we use two more bits to encode +// To make Generational GC possible we use two more bits to encode // (1) the status SOME or NONE saying whether the generation is // on the scan stack or not -// (2) the generation (being either 0 or 1). This info is used +// (2) the generation (being either 0 or 1). This info is used // to calculate the address of the region descriptor given // a pointer to the generation (either g0 or g1) in the // region descriptor. @@ -336,18 +350,18 @@ of the region and is useful for, among other things, tail recursion). /* Operations on the two least significant */ /* bits in a regionpointer. */ /* C ~ 1100, D ~ 1101, E ~ 1110 og F ~ 1111. */ -#define setInfiniteBit(x) ((x) | 0x00000001) +#define setInfiniteBit(x) ((x) | 0x1) #define clearInfiniteBit(x) ((x) & (UINTPTR_MAX ^ 0x1)) // #define clearInfiniteBit(x) ((x) & 0xFFFFFFFE) -#define setAtbotBit(x) ((x) | 0x00000002) +#define setAtbotBit(x) ((x) | 0x2) #define clearAtbotBit(x) ((x) & (UINTPTR_MAX ^ 0x2)) // #define clearAtbotBit(x) ((x) & 0xFFFFFFFD) -#define setStatusBits(x) ((x) | 0x00000003) +#define setStatusBits(x) ((x) | 0x3) #define clearStatusBits(x) ((Region)(((uintptr_t)(x)) & (UINTPTR_MAX ^ 0x3))) // #define clearStatusBits(x) ((Region)(((unsigned long)(x)) & 0xFFFFFFFC)) -#define is_inf_and_atbot(x) ((((uintptr_t)(x)) & 0x00000003)==0x00000003) -#define is_inf(x) ((((uintptr_t)(x)) & 0x00000001)==0x00000001) -#define is_atbot(x) ((((uintptr_t)(x)) & 0x00000002)==0x00000002) +#define is_inf_and_atbot(x) ((((uintptr_t)(x)) & 0x3)==0x3) +#define is_inf(x) ((((uintptr_t)(x)) & 0x1)==0x1) +#define is_atbot(x) ((((uintptr_t)(x)) & 0x2)==0x2) /*----------------------------------------------------------------* * Type of freelist and top-level region * @@ -378,7 +392,7 @@ void deallocateRegionsUntil(Region rAdr, Region* topRegionCell); Region allocateRegion(Region roAddr); void deallocateRegion(); void deallocateRegionsUntil(Region rAddr); -void deallocateRegionsUntil_X86(Region rAddr); +void deallocateRegionsUntil_X64(Region rAddr); #endif uintptr_t *alloc (Region r, size_t n); @@ -417,19 +431,19 @@ size_t NoOfPagesInGen(Gen* gen); #define notPP 0 /* Also used by GC */ #ifdef PROFILING -/* +/* Here is the type of region descriptors for finite regions when profiling is enabled (see item (a)(ii) at the beginning of the file): */ typedef struct finiteRegionDesc { - struct finiteRegionDesc * p; /* Has to be in the bottom of the descriptor + struct finiteRegionDesc * p; /* Has to be in the bottom of the descriptor for deallocation. */ size_t regionId; /* If msb. set then infinite region. (? - mads)*/ } FiniteRegionDesc; -#define sizeFiniteRegionDesc (sizeof(FiniteRegionDesc)/sizeof(void *)) +#define sizeFiniteRegionDesc (sizeof(FiniteRegionDesc)/sizeof(long*)) -/* +/* Object descriptors ------------------ When profiling is turned on, every object is prefixed by an @@ -446,11 +460,11 @@ This applies irrespective of whether profiling is turned on or not. typedef struct objectDesc { size_t atId; /* Allocation point. */ - size_t size; /* Size of object in bytes. */ + size_t size; /* Size of object in words. */ } ObjectDesc; -#define sizeObjectDesc (sizeof(ObjectDesc)/(sizeof(void *))) +#define sizeObjectDesc (sizeof(ObjectDesc)/(sizeof(long*))) -/* +/* Profiling is done by scanning the store at regular intervals. Every such interruption of the normal execution is called a {\em profile tick}. During a profile tick, the runtime system diff --git a/src/Runtime/Runtime.c b/src/Runtime/Runtime.c index dd5e2f737..fa764d83b 100644 --- a/src/Runtime/Runtime.c +++ b/src/Runtime/Runtime.c @@ -3,11 +3,12 @@ *----------------------------------------------------------------*/ #include #include -#include +#include #include #include #include #include +#include #include "Runtime.h" #include "Flags.h" #include "Tagging.h" @@ -31,22 +32,24 @@ #include "Interp.h" #endif -int -die (const char *s) -{ - fprintf(stderr,"Runtime Error: %s\n",s); +int +die (const char *s) +{ + fprintf(stderr,"Runtime Error: %s\n",s); fflush(stderr); - exit(-1); + exit(-1); } -int -die2 (const char *s1, const char* s2) -{ - fprintf(stderr,"Runtime Error: %s\n%s\n",s1,s2); +int +die2 (const char *s1, const char* s2) +{ + fprintf(stderr,"Runtime Error: %s\n%s\n",s1,s2); fflush(stderr); - exit(-1); + exit(-1); } +static struct rlimit limit; + void setStackSize(rlim_t size) { @@ -68,6 +71,13 @@ setStackSize(rlim_t size) bad = strerror(errno); die2("setStackSize(2)", bad); } + res = getrlimit(RLIMIT_STACK, &limit); + if (res == -1) + { + bad = strerror(errno); + die2("setStackSize(2)", bad); + } + // printf("Stack size: %llu; %lluMb\n", limit.rlim_cur, limit.rlim_cur / 1024 / 1024); return; } @@ -77,9 +87,9 @@ setStackSizeUnlimited(void) return setStackSize(RLIM_INFINITY); } -long -terminateML (long status) -{ +long +terminateML (long status) +{ callExportFun("sml_exitCallback", convertIntToML(8)); // exported in Initial2.sml #ifdef ENABLE_GC @@ -93,12 +103,12 @@ terminateML (long status) #ifdef PROFILING outputProfilePost(); - Statistics(); + Statistics(); #endif #ifdef ENABLE_GC if ( report_gc || verbose_gc ) - { + { alloc_total += alloc_period; fprintf(stderr, "[GC(%zdms): %zd collections", time_gc_all_ms, num_gc); #ifdef ENABLE_GEN_GC @@ -107,28 +117,27 @@ terminateML (long status) fprintf(stderr, ", %zdkb rpages", rp_total); } - if ( report_gc ) - { - fprintf(stderr, "]\n"); - fflush(stderr); - } - - if ( verbose_gc ) + if ( verbose_gc ) { double ri = 0.0; double gc = 0.0; alloc_total += lobjs_period; gc = 100.0 * ((double)gc_total) / ((double)alloc_total); ri = 100.0 - gc; - fprintf(stderr, ", RI:%2.0f%%, GC:%2.0f%%, Frag avg:%2.0f%%]\n", - ri, gc, FRAG_sum / (double)(num_gc-1)); + fprintf(stderr, ", RI:%2.0f%%, GC:%2.0f%%, Frag avg:%2.0f%%]\n", + ri, gc, FRAG_sum / (double)(num_gc-1)); + fflush(stderr); + } + else if ( report_gc ) + { + fprintf(stderr, "]\n"); fflush(stderr); } #endif /* ENABLE_GC */ debug(printf("]\n")); - exit (convertIntToC(status)); + exit (convertIntToC(status)); } size_t failNumber = SIZE_MAX; @@ -150,11 +159,11 @@ sml_setFailNumber(uintptr_t ep, int i) return; } -void -uncaught_exception (String exnStr, unsigned long n, uintptr_t ep) -{ +void +uncaught_exception (String exnStr, unsigned long n, uintptr_t ep) +{ uintptr_t a; - fprintf(stderr,"uncaught exception "); + fprintf(stderr,"uncaught exception "); fflush(stderr); fputs(&(exnStr->data), stderr); fflush(stderr); @@ -173,36 +182,36 @@ uncaught_exception (String exnStr, unsigned long n, uintptr_t ep) fputs(&(((String) a)->data),stderr); fflush(stderr); } - fprintf(stderr, "\n"); + fprintf(stderr, "\n"); fflush(stderr); #ifdef PROFILING outputProfilePost(); - Statistics(); + Statistics(); #endif - exit (-1); + exit (-1); } #ifdef TAG_VALUES -static inline int -equalTable(Table x, Table y) +static inline size_t +equalTable(Table x, Table y) { - int i, sz_x, *px, *py; + size_t i, sz_x, *px, *py; sz_x = get_table_size(x->size); if ( sz_x != get_table_size(y->size)) { return mlFALSE; } - px = &(x->data); - py = &(y->data); + px = &(x->data); + py = &(y->data); for ( i = 0 ; i < sz_x ; i ++ ) { if ( equalPolyML(*(px+i), *(py+i)) == mlFALSE ) - { - return mlFALSE; - } + { + return mlFALSE; + } } return mlTRUE; } @@ -210,8 +219,8 @@ equalTable(Table x, Table y) /*----------------------------------------------------------------------* *equalPolyML: * *----------------------------------------------------------------------*/ -uintptr_t -equalPolyML(uintptr_t x, uintptr_t y) +uintptr_t +equalPolyML(uintptr_t x, uintptr_t y) { int i; @@ -247,24 +256,24 @@ equalPolyML(uintptr_t x, uintptr_t y) } /* if (valTagKind(x) == valueTagReal) { if (get_d(x) == get_d(y)) - return mlTRUE; - else return mlFALSE; + return mlTRUE; + else return mlFALSE; }Obsolete 10/01/1999, Niels */ if (val_tag_kind(x) == TAG_STRING) { return equalStringML((String) x, (String) y); } if (val_tag_kind(x) == TAG_RECORD) { for (i = 1; i <= get_record_size(x); i++) { - if (equalPolyML(*(((uintptr_t *)x)+i), *(((uintptr_t *)y)+i)) == mlFALSE) - return mlFALSE; + if (equalPolyML(*(((uintptr_t *)x)+i), *(((uintptr_t *)y)+i)) == mlFALSE) + return mlFALSE; } return mlTRUE; } if (val_tag_kind(x) == TAG_REF) { - if ((((uintptr_t *)x)+1) == (((uintptr_t *)y)+1)) - return mlTRUE; - else - return mlFALSE; + if ((((uintptr_t *)x)+1) == (((uintptr_t *)y)+1)) + return mlTRUE; + else + return mlFALSE; } if (val_tag_kind(x) == TAG_TABLE) { return equalTable((Table)x,(Table)y); @@ -272,12 +281,27 @@ equalPolyML(uintptr_t x, uintptr_t y) die("equal_poly - No matching tag!"); return mlFALSE; // never comes here } -} +} #endif /* TAG_VALUES */ -void -sig_handler_int(void) +/* +void +sig_handler_segv(int sig, siginfo_t *info, void *extra) +{ + if (sig != SIGSEGV) return; + char* buf = "In HANDLER\n"; + int sz = strlen(buf); + write(STDERR_FILENO, buf, sz); + //fprintf(stderr, "[Max stack size: %lluMb]\n", limit.rlim_cur / 1024 / 1024); + _exit(1); + //raise_exn((uintptr_t)&exn_INTERRUPT); + return; // never comes here +} +*/ + +void +sig_handler_int(void) { signal(SIGINT, (SignalHandler)sig_handler_int); /* setup handler again */ @@ -299,8 +323,8 @@ sig_handler_int(void) return; /* never comes here */ } -void -sig_handler_fpe(void) +void +sig_handler_fpe(void) { signal(SIGFPE, (SignalHandler)sig_handler_fpe); /* setup handler again */ @@ -327,9 +351,13 @@ extern void code(void); #endif #ifndef APACHE -int -main(int argc, char *argv[]) + +int +main(int argc, char *argv[]) { + //static struct sigaction sigact; + //static sigset_t sigset; + if ((((double)Max_Int) != Max_Int_d) || (((double)Min_Int) != Min_Int_d)) die("main - integer configuration is erroneous"); @@ -346,6 +374,26 @@ rpMap = regionPageMapNew(); #endif /* setup handlers */ + /* + if ( sigemptyset(&sigset) == -1 ) { + die("failed to create empty signal set"); + exit(1); + } + if ( sigprocmask(SIG_SETMASK, &sigset, NULL) == -1 ) { + die("failed to clear signal processing mask"); + exit(1); + } + sigact.sa_flags = SA_SIGINFO; + if ( sigemptyset(&sigact.sa_mask) == -1 ) { + die("failed to create empty signal mask"); + exit(1); + } + sigact.sa_sigaction = sig_handler_segv; + if ( sigaction(SIGSEGV, &sigact, NULL) == -1 ) { + die ("failed to set SIGSEGV signal handler"); + exit(1); + } + */ //signal(SIGINT, (SignalHandler)sig_handler_int); //signal(SIGFPE, (SignalHandler)sig_handler_fpe); @@ -354,9 +402,8 @@ rpMap = regionPageMapNew(); return (main_interp(argc, argv)); #else code(); - return (EXIT_FAILURE); /* never comes here (i.e., exits through - * terminateML or uncaught_exception) */ + return (EXIT_FAILURE); /* never comes here (i.e., exits through + * terminateML or uncaught_exception) */ #endif } #endif - diff --git a/src/Runtime/String.c b/src/Runtime/String.c index 1b094d9ee..902c31f43 100644 --- a/src/Runtime/String.c +++ b/src/Runtime/String.c @@ -14,12 +14,12 @@ // allocString: Allocates a string of size in region rAddr. Returns a // pointer to the string. Uses alloc to allocate memory for the string, // which then exists in contiguous memory because alloc uses -// malloc when the string cannot fit in a region page. The size is in -// bytes, so we have to convert to words, and make alignment. The -// content of the string is not initialized. +// malloc when the string cannot fit in a region page. The size is in +// bytes, so we have to convert to words, and make alignment. The +// content of the string is not initialized. static inline String -REG_POLY_FUN_HDR(allocString, Region rAddr, size_t size) +REG_POLY_FUN_HDR(allocString, Region rAddr, size_t size) { String sd; size_t szAlloc; // size of string in words + tag @@ -35,15 +35,15 @@ REG_POLY_FUN_HDR(allocString, Region rAddr, size_t size) } // convertStringToC: Copy ML string to 'buf' of size 'buflen' -void -convertStringToC(String mlStr, char *buf, size_t buflen, uintptr_t exn) +void +convertStringToC(String mlStr, char *buf, size_t buflen, uintptr_t exn) { size_t sz; char *p; - sz = sizeStringDefine(mlStr); - if ( sz > buflen-1) - { + sz = sizeStringDefine(mlStr); + if ( sz > buflen-1) + { raise_exn(exn); } for ( p = &(mlStr->data); *p != '\0'; ) @@ -54,10 +54,10 @@ convertStringToC(String mlStr, char *buf, size_t buflen, uintptr_t exn) return; } -// convertStringToML: The ML string is allocated in the region +// convertStringToML: The ML string is allocated in the region // pointen at by rAddr. String -REG_POLY_FUN_HDR(convertStringToML, Region rAddr, const char *cStr) +REG_POLY_FUN_HDR(convertStringToML, Region rAddr, const char *cStr) { String res; char *p; @@ -77,7 +77,7 @@ REG_POLY_FUN_HDR(convertStringToML, Region rAddr, const char *cStr) // not test on \0 in during the copy. However, you must be sure that // the legth is correct. String -REG_POLY_FUN_HDR(convertBinStringToML, Region rAddr, size_t l, const char *cStr) +REG_POLY_FUN_HDR(convertBinStringToML, Region rAddr, size_t l, const char *cStr) { String res; char *p; @@ -118,20 +118,20 @@ REG_POLY_FUN_HDR(allocStringC, Region rAddr, size_t sizeC) return strPtr; } -size_t -chrCharML(size_t charNrML, uintptr_t exn) +size_t +chrCharML(size_t charNrML, uintptr_t exn) { - size_t charNrC = convertIntToC(charNrML); - if ( charNrC <= 255 ) + size_t charNrC = convertIntToC(charNrML); + if ( charNrC <= 255 ) { - return convertIntToML (charNrC); + return convertIntToML (charNrC); } raise_exn(exn); return 0; // never reached } String -REG_POLY_FUN_HDR(concatStringML, Region rAddr, String str1, String str2) +REG_POLY_FUN_HDR(concatStringML, Region rAddr, String str1, String str2) { String res; char *s, *p; @@ -157,7 +157,7 @@ REG_POLY_FUN_HDR(concatStringML, Region rAddr, String str1, String str2) } String -REG_POLY_FUN_HDR(implodeCharsML, Region rAddr, uintptr_t xs) +REG_POLY_FUN_HDR(implodeCharsML, Region rAddr, uintptr_t xs) { String res; size_t length = 0; @@ -165,20 +165,20 @@ REG_POLY_FUN_HDR(implodeCharsML, Region rAddr, uintptr_t xs) char *p; // maybe reset region - if ( is_inf_and_atbot(rAddr) ) + if ( is_inf_and_atbot(rAddr) ) { resetRegion(rAddr); } // calculate length of string - for ( ys = xs; isCONS(ys); ys = tl(ys) ) + for ( ys = xs; isCONS(ys); ys = tl(ys) ) { length++; } res = REG_POLY_CALL(allocString, rAddr, length); p = &(res->data); - for ( ys = xs; isCONS(ys); ys = tl(ys) ) + for ( ys = xs; isCONS(ys); ys = tl(ys) ) { *p++ = (unsigned char) convertIntToC (hd(ys)); } @@ -187,10 +187,10 @@ REG_POLY_FUN_HDR(implodeCharsML, Region rAddr, uintptr_t xs) } // implodeStringML -// Example: ["ABC","DEF","GHI","JKL"] +// Example: ["ABC","DEF","GHI","JKL"] // = CONS("ABC",CONS("DEF",CONS("GHI",CONS("JKL",NIL)))) String -REG_POLY_FUN_HDR(implodeStringML, Region rAddr, uintptr_t xs) +REG_POLY_FUN_HDR(implodeStringML, Region rAddr, uintptr_t xs) { String res; size_t sz=0; @@ -221,8 +221,8 @@ REG_POLY_FUN_HDR(implodeStringML, Region rAddr, uintptr_t xs) return res; } -void -printStringML(String str) +void +printStringML(String str) { fputs(&(str->data),stdout); fflush(stdout); @@ -230,7 +230,7 @@ printStringML(String str) } static inline int -mystrcmp (String s1, String s2) +mystrcmp (String s1, String s2) { size_t min, l1, l2, i; unsigned char *p1, *p2; @@ -245,7 +245,7 @@ mystrcmp (String s1, String s2) p1 = (unsigned char *) &(s1->data); p2 = (unsigned char *) &(s2->data); - + for ( i = 0; i < min; i++, p1++, p2++ ) { if ( *p1 < *p2 ) return -1; @@ -256,8 +256,8 @@ mystrcmp (String s1, String s2) return 0; } -size_t -lessStringML(String s1, String s2) +size_t +lessStringML(String s1, String s2) { if ( mystrcmp (s1, s2) < 0 ) { @@ -266,8 +266,8 @@ lessStringML(String s1, String s2) return mlFALSE; } -size_t -lesseqStringML(String s1, String s2) +size_t +lesseqStringML(String s1, String s2) { if ( mystrcmp (s1, s2) <= 0 ) { @@ -276,8 +276,8 @@ lesseqStringML(String s1, String s2) return mlFALSE; } -size_t -greaterStringML(String s1, String s2) +size_t +greaterStringML(String s1, String s2) { if ( mystrcmp (s1, s2) > 0 ) { @@ -286,8 +286,8 @@ greaterStringML(String s1, String s2) return mlFALSE; } -size_t -greatereqStringML(String s1, String s2) +size_t +greatereqStringML(String s1, String s2) { if ( mystrcmp (s1, s2) >= 0 ) { @@ -296,14 +296,14 @@ greatereqStringML(String s1, String s2) return mlFALSE; } -size_t -equalStringML(String s1, String s2) +size_t +equalStringML(String s1, String s2) { char *p1, *p2; size_t sz; if (s1 == s2) return mlTRUE; - - sz = sizeStringDefine(s1); + + sz = sizeStringDefine(s1); if ( sz != sizeStringDefine(s2) ) return mlFALSE; for (p1 = &(s1->data), p2 = &(s2->data) ; sz > 0 ; sz-- ) @@ -311,10 +311,10 @@ equalStringML(String s1, String s2) return mlTRUE; } -// exnNameML: return name of exception; the function +// exnNameML: return name of exception; the function // is exomorphic by copying String -REG_POLY_FUN_HDR(exnNameML, Region rAddr, uintptr_t e) +REG_POLY_FUN_HDR(exnNameML, Region rAddr, uintptr_t e) { String ml_s; @@ -327,11 +327,11 @@ REG_POLY_FUN_HDR(exnNameML, Region rAddr, uintptr_t e) return REG_POLY_CALL(convertStringToML, rAddr, &(ml_s->data)); } -/* explodeStringML(rAddr, str): convert a string to a char list. +/* explodeStringML(rAddr, str): convert a string to a char list. * A list is kept in one region, pointed to by rAddr. */ uintptr_t * -REG_POLY_FUN_HDR(explodeStringML, Region rAddr, String str) +REG_POLY_FUN_HDR(explodeStringML, Region rAddr, String str) { uintptr_t *res, *consPtr, *pair, *tpair; size_t i, sz; @@ -346,7 +346,7 @@ REG_POLY_FUN_HDR(explodeStringML, Region rAddr, String str) // save first char such that we can return a pointer to it p = &(str->data); - + #ifdef PROFILING allocPairMLProf(rAddr, pair, pPoint); #else @@ -359,9 +359,9 @@ REG_POLY_FUN_HDR(explodeStringML, Region rAddr, String str) for ( i = 1 ; i < sz; i++ ) { #ifdef PROFILING - allocPairMLProf(rAddr, tpair, pPoint); + allocPairMLProf(rAddr, tpair, pPoint); #else - allocPairML(rAddr, tpair); + allocPairML(rAddr, tpair); #endif first(tpair) = convertIntToML (*p++); @@ -375,9 +375,26 @@ REG_POLY_FUN_HDR(explodeStringML, Region rAddr, String str) } // for debugging */ -void -printNum(ssize_t n) +void +printNum(ssize_t n) { - printf("Num: %zd\n",convertIntToC(n)); + printf("Num: %d\n",convertIntToC((int)n)); + /* + asm volatile ( "movq $32, %rdi\n\t" + "movq $52, %rsi\n\t" + "movq $62, %rdx\n\t" + "movq $72, %rcx\n\t" + "movq $82, %r8\n\t" + "movq $92, %r9\n\t" + "movq $102, %r10\n\t" + "movq $112, %r11\n\t" + "movq $122, %rax\n\t" + "movq $132, %rbx\n\t" + "movq $142, %r12\n\t" + "movq $152, %r13\n\t" + "movq $162, %r14\n\t" + "movq $172, %r15\n\t" + ); + */ return; } diff --git a/src/Runtime/Table.c b/src/Runtime/Table.c index e6eac83b4..80b5d7e71 100644 --- a/src/Runtime/Table.c +++ b/src/Runtime/Table.c @@ -2,14 +2,10 @@ #include "Table.h" #include "Tagging.h" -// word_table0(rAddr, n): return a pointer to a table +// word_table0(rAddr, n): return a pointer to a table // with n elements allocated in the region indicated by rAddr -Table -#ifdef PROFILING -word_table0Prof (Region rAddr, int n, int pPoint) -#else -word_table0 (Region rAddr, int n) -#endif +Table +REG_POLY_FUN_HDR(word_table0, Region rAddr, size_t n) { Table res; @@ -22,8 +18,8 @@ word_table0 (Region rAddr, int n) res->size = val_tag_table(n); #ifdef ENABLE_GC { - int *p; - int i; + size_t *p; + size_t i; for ( i = 0, p = &(res->data) ; i < n ; i++, p++ ) { *p = 1; // scalar value @@ -33,18 +29,15 @@ word_table0 (Region rAddr, int n) return res; } -// word_table_init(rAddr, n, x): return a pointer to a table -// with n initialized (=x) elements allocated in the region +// word_table_init(rAddr, n, x): return a pointer to a table +// with n initialized (=x) elements allocated in the region // indicated by rAddr -/* 'a */ Table -#ifdef PROFILING -word_table_initProf (Region rAddr, int n, int x, int pPoint) -#else -word_table_init (Region rAddr, int n, int x /* :'a */) -#endif +/* 'a */ +Table +REG_POLY_FUN_HDR(word_table_init, Region rAddr, size_t n, size_t x) { Table res; - int i, *p; + size_t i, *p; n = convertIntToC(n); #ifdef PROFILING @@ -58,6 +51,6 @@ word_table_init (Region rAddr, int n, int x /* :'a */) for ( i = 0 ; i < n ; i ++ ) { *p++ = x; - } + } return res; } diff --git a/src/Runtime/Table.h b/src/Runtime/Table.h index 1147b1160..c4d60c4e5 100644 --- a/src/Runtime/Table.h +++ b/src/Runtime/Table.h @@ -1,32 +1,22 @@ - #ifndef __TABLE_H #define __TABLE_H #include "Region.h" +#include "Tagging.h" typedef struct { - int size; // combined size and tag-field - int data; // first element + size_t size; // combined size and tag-field + size_t data; // first element } TableDesc; -typedef TableDesc* Table; +typedef TableDesc* Table; -// word_table0(rAddr, n): return a pointer to a table +// word_table0(rAddr, n): return a pointer to a table // with n elements allocated in the region indicated by rAddr -#ifdef PROFILING -Table word_table0Prof (Region rAddr, int n, int pPoint); -#else -Table word_table0 (Region rAddr, int n); -#endif +Table REG_POLY_FUN_HDR(word_table0, Region rAddr, size_t n); -// word_table_init(rAddr, n, x): return a pointer to a table -// with n initialized (=x) elements allocated in the +// word_table_init(rAddr, n, x): return a pointer to a table +// with n initialized (=x) elements allocated in the // region indicated by rAddr -#ifdef PROFILING -Table word_table_initProf (Region rAddr, int n, int x, int pPoint); -#else -Table word_table_init (Region rAddr, int n, int x); -#endif +Table REG_POLY_FUN_HDR(word_table_init, Region rAddr, size_t n, size_t x); #endif /*__TABLE_H*/ - - diff --git a/src/Runtime/Time.c b/src/Runtime/Time.c index 45c054fea..3a4e1c1c8 100644 --- a/src/Runtime/Time.c +++ b/src/Runtime/Time.c @@ -22,14 +22,14 @@ #define TIMEBASE (Min_Int) #endif -uintptr_t -get_time_base(int dummy) +uintptr_t +get_time_base(int dummy) { - return convertIntToML(TIMEBASE); + return convertIntToML((int)TIMEBASE); } -uintptr_t -sml_getrealtime (uintptr_t vAddr) +uintptr_t +sml_getrealtime (uintptr_t vAddr) { struct timeval tp; gettimeofday(&tp, NULL); @@ -39,8 +39,8 @@ sml_getrealtime (uintptr_t vAddr) return vAddr; } -uintptr_t -sml_localtime (uintptr_t vAddr, uintptr_t v) +uintptr_t +sml_localtime (uintptr_t vAddr, uintptr_t v) { struct tm tmr; time_t clock = (long)(get_d(v)); @@ -58,8 +58,8 @@ sml_localtime (uintptr_t vAddr, uintptr_t v) return vAddr; } -uintptr_t -sml_gmtime (uintptr_t vAddr, uintptr_t r) +uintptr_t +sml_gmtime (uintptr_t vAddr, uintptr_t r) { struct tm tmr; time_t clock = (long)(get_d(r)); @@ -77,8 +77,8 @@ sml_gmtime (uintptr_t vAddr, uintptr_t r) return vAddr; } -uintptr_t -sml_mktime (uintptr_t vAddr, uintptr_t v) +uintptr_t +sml_mktime (uintptr_t vAddr, uintptr_t v) { struct tm tmr; tmr.tm_hour = convertIntToC(elemRecordML(v,0)); @@ -96,7 +96,7 @@ sml_mktime (uintptr_t vAddr, uintptr_t v) } String -REG_POLY_FUN_HDR(sml_asctime, Region rAddr, uintptr_t v, int exn) +REG_POLY_FUN_HDR(sml_asctime, Region rAddr, uintptr_t v, int exn) { struct tm tmr; char *r; @@ -111,7 +111,7 @@ REG_POLY_FUN_HDR(sml_asctime, Region rAddr, uintptr_t v, int exn) tmr.tm_yday = convertIntToC(elemRecordML(v,7)); tmr.tm_year = convertIntToC(elemRecordML(v,8)); r = asctime_r(&tmr, res); - if ( r == NULL ) + if ( r == NULL ) { raise_exn(exn); } @@ -119,7 +119,7 @@ REG_POLY_FUN_HDR(sml_asctime, Region rAddr, uintptr_t v, int exn) } String -REG_POLY_FUN_HDR(sml_strftime, Region rAddr, String fmt, uintptr_t v, int exn) +REG_POLY_FUN_HDR(sml_strftime, Region rAddr, String fmt, uintptr_t v, int exn) { struct tm tmr; int ressize; @@ -143,8 +143,8 @@ REG_POLY_FUN_HDR(sml_strftime, Region rAddr, String fmt, uintptr_t v, int exn) #undef BUFSIZE } -uintptr_t -sml_localoffset (uintptr_t vAddr) +uintptr_t +sml_localoffset (uintptr_t vAddr) { struct tm gmt; time_t t1, t2, td; @@ -154,12 +154,12 @@ sml_localoffset (uintptr_t vAddr) t2 = tm2cal(&gmt); td = difftime(t2, t1); get_d(vAddr) = (double)td; - set_dtag(vAddr); + set_dtag(vAddr); return vAddr; } -uintptr_t -sml_getrutime(uintptr_t vAddr) +uintptr_t +sml_getrutime(uintptr_t vAddr) { struct rusage rusages; getrusage(RUSAGE_SELF, &rusages); diff --git a/src/Tools/Rp2ps/Makefile.in b/src/Tools/Rp2ps/Makefile.in index 60d0aa2e1..568ee1413 100644 --- a/src/Tools/Rp2ps/Makefile.in +++ b/src/Tools/Rp2ps/Makefile.in @@ -15,7 +15,7 @@ CFILES = $(OFILES:%.o=%.c) BINDIR=$(top_srcdir)/bin -OPT=-m32 -Wall -std=gnu99 $(CFLAGS) +OPT=-Wall -std=gnu99 $(CFLAGS) .PHONY: clean depend @@ -29,7 +29,7 @@ $(BINDIR)/rp2ps: rp2ps $(INSTALLPROGRAM) rp2ps $(BINDIR) rp2ps: $(OFILES) - $(CC) -m32 -o rp2ps $(OFILES) -lm + $(CC) -o rp2ps $(OFILES) -lm clean: rm -f *.o core a.out *~ rp2ps diff --git a/src/Tools/Tester/Tester.sml b/src/Tools/Tester/Tester.sml index aa9f90dfa..4e4323a2e 100644 --- a/src/Tools/Tester/Tester.sml +++ b/src/Tools/Tester/Tester.sml @@ -1,15 +1,15 @@ -signature TESTER = - sig +signature TESTER = + sig val main : string * string list -> OS.Process.status end structure Tester : TESTER = struct -(* val _ = SMLofNJ.Internals.GC.messages false; *) - + val log = "TESTmessages" + fun files_equal (s1,s2) = - let fun open_file s = TextIO.openIn s + let fun open_file s = TextIO.openIn s val is1 = open_file s1 val is2 = open_file s2 fun close() = (TextIO.closeIn is1; TextIO.closeIn is2) @@ -21,18 +21,27 @@ structure Tester : TESTER = local val error_counter = ref 0 + val dotcounter = ref 0 + fun pr_dot () = + if !dotcounter < 60 then + ( dotcounter := !dotcounter + 1 + ; print ".") + else ( dotcounter := 1 + ; print "\n.") in fun reset_error_counter() = error_counter:=0 val msglog = ref TextIO.stdOut - fun msg s = (TextIO.output(!msglog,s ^ "\n"); TextIO.flushOut (!msglog); print (s ^ "\n"); + fun msg0 s = (TextIO.output(!msglog,s ^ "\n"); TextIO.flushOut (!msglog); TestReport.add_log_line s) - fun msg' s = (TextIO.output(!msglog,s ^ "\n"); TextIO.flushOut (!msglog); print (s ^ "\n")) + fun msg s = (msg0 s; pr_dot()) + fun msgp s = (msg0 s; print ("\n" ^ s ^ "\n"); dotcounter := 0) + fun msg' s = (TextIO.output(!msglog,s ^ "\n"); TextIO.flushOut (!msglog); pr_dot()) fun msgOk s = msg (" ok: " ^ s) - fun msgErr s = (error_counter := !error_counter + 1; msg (" ERR: " ^ s)) - fun msgErrors () = - if !error_counter = 0 then msg "\nTEST SUCCEEDED; there were no errors." - else if !error_counter = 1 then msg "***TEST FAILED: there was 1 error." - else msg ("***TEST FAILED: there were " ^ Int.toString (!error_counter) ^ " errors.") + fun msgErr s = (error_counter := !error_counter + 1; msgp (" ERR: " ^ s)) + fun msgErrors () = + if !error_counter = 0 then msgp "TEST SUCCEEDED; there were no errors." + else if !error_counter = 1 then msgp "***TEST FAILED: there was 1 error." + else msgp ("***TEST FAILED: there were " ^ Int.toString (!error_counter) ^ " errors.") fun noOfErrors() = !error_counter end @@ -51,26 +60,26 @@ structure Tester : TESTER = val _ = msg ("Processing file `" ^ filepath ^ "'") val _ = OS.Process.system "rm -f -r MLB" (* first delete MLB directories *) fun opt t = List.exists (fn a => a=t) opts - val recover : unit -> unit = + val recover : unit -> unit = let val memdir = OS.FileSys.getDir() in fn () => OS.FileSys.chDir memdir end val {dir, file} = OS.Path.splitDirFile filepath val _ = if dir="" then () else OS.FileSys.chDir dir - val compile_command_base = kitexe ^ " --log_to_file " ^ + val compile_command_base = kitexe ^ " --log_to_file " ^ (if opt "nobasislib" then "-no_basislib " else "") ^ (if opt "tc" (*Time Compiler*) then "--timings " else "") ^ - (if opt "ccl" (*Compare Compiler Logs*) then "--report_file_sig " else "") + (if opt "ccl" (*Compare Compiler Logs*) then "--report_file_sig " else "") ^ concatWith " " flags - val compile_command = compile_command_base ^ file + val compile_command = compile_command_base ^ file fun maybe_compare_complogs success = let fun success_as_expected() = - if opt "ecte" (*Expect Compile Time Error*) then + if opt "ecte" (*Expect Compile Time Error*) then if success then (msgErr "unexpected compile time success"; false) else (msgOk "expected compile time failure"; true) - else + else if success then (msgOk "expected compile time success"; true) else (msgErr "unexpected compile time failure"; false) in @@ -96,44 +105,36 @@ structure Tester : TESTER = val runargs = nil (*["-heap_to_live_ratio", "2.5"]*) fun rename_and_run(suffix, out_file, outok_file) = if OS.Process.isSuccess(OS.Process.system ("mv run " ^ exe_file)) then - let + let val file_label = filepath ^suffix fun test_output () = if files_equal (file^out_file, file^outok_file) then (msgOk (out_file ^ " equal to " ^ outok_file); true) - else (msgErr (out_file ^ " not equal to " ^ outok_file); false) -(* - fun test_output () = - if compare then - if equal_to_okfile (file ^ ".out") then - (msgOk "out equal to out.ok"; true) - else (msgErr "out not equal to out.ok"; false) - else (msgOk "out not compared to .ok file"; true) -*) - in + else (msgErr (file^out_file ^ " not equal to " ^ file ^ outok_file); false) + in if opt "tx" (*Time Executable*) then let val _ = msg' (" executing target program: " ^ exe_file) val {count,size,rss,data,stk,exe,real,user,sys} = MemUsage.memUsage {cmd=exe_file,args=runargs,out_file=file ^ out_file (*".out"*)} val ok = test_output() val exesize = size_of_file exe_file - val exesize_stripped = + val exesize_stripped = if OS.Process.isSuccess(OS.Process.system ("strip " ^ exe_file)) then size_of_file exe_file else (msgOk ("the command `strip " ^ exe_file ^ "' failed"); "N/A") in - TestReport.add_runtime_line{name=file_label,ok=ok,exesize=exesize, - exesize_stripped=exesize_stripped, + TestReport.add_runtime_line{name=file_label,ok=ok,exesize=exesize, + exesize_stripped=exesize_stripped, size=size,data=data, rss=rss,stk=stk,exe=exe, real=real,user=user,sys=sys} - end handle Fail s => (msgErr (exe_file ^ " failure: " ^ s); + end handle Fail s => (msgErr (exe_file ^ " failure: " ^ s); TestReport.add_runtime_bare_line(file_label,false)) else - let val res = OS.Process.system (exe_file ^ " > " ^ file ^ out_file (*".out"*)) - in - if (not(opt "ue" (*Uncaught Exception*) ) andalso OS.Process.isSuccess res) + let val res = OS.Process.system (exe_file ^ " > " ^ file ^ out_file ^ " 2>&1" (*".out"*)) + in + if (not(opt "ue" (*Uncaught Exception*) ) andalso OS.Process.isSuccess res) orelse (opt "ue" (*Uncaught Exception*) andalso not(OS.Process.isSuccess res)) then TestReport.add_runtime_bare_line(file_label,test_output()) else (msgErr (exe_file ^ " failure"); @@ -144,8 +145,8 @@ structure Tester : TESTER = TestReport.add_runtime_bare_line(filepath,false)) in msg' (" executing command `" ^ compile_command ^ "'"); - if OS.Process.isSuccess(OS.Process.system compile_command) then - (maybe_compare_complogs true; + if OS.Process.isSuccess(OS.Process.system (compile_command ^ " >> ./" ^ log)) then + (maybe_compare_complogs true; maybe_report_comptimes(); rename_and_run(" ri ",".out",".out.ok") ) @@ -166,15 +167,14 @@ structure Tester : TESTER = fun main (progname, args) = case process_args args of SOME (kitexe,testfile,flags) => - let val log = "TESTmessages" - val _ = (reset_error_counter()) + let val _ = (reset_error_counter()) handle Time.Time => (print "bad time4\n" ; raise Fail "bad") val _ = (TestReport.reset()) handle Time.Time => (print "bad time5\n" ; raise Fail "bad") in (msglog:=TextIO.openOut(log); case TestFile.parse testfile of NONE => OS.Process.failure - | SOME (testfile_string,entries) => + | SOME (testfile_string,entries) => let val entries = map (fn TestFile.SML (filepath,opt) => (filepath,opt,kitexe) | TestFile.MLB (filepath,opt) => (filepath,opt,kitexe)) entries in (app (process_entry flags) entries) @@ -215,7 +215,7 @@ structure Tester : TESTER = OS.Process.failure) in SMLofNJ.exportFn(kit_bin_kittester_path,main) *) - in () + in () end *) diff --git a/test/Makefile b/test/Makefile index 873c3c71c..ced006ca5 100644 --- a/test/Makefile +++ b/test/Makefile @@ -6,7 +6,7 @@ test_mlkit: prepare (export SML_LIB=`(cd ..; pwd)`; ../bin/kittester ../bin/mlkit all.tst) /bin/mv test_report.html test_report-native-$(DATE).html -test_mlkit_no_gc: +test_mlkit_no_gc: prepare (export SML_LIB=`(cd ..; pwd)`; ../bin/kittester ../bin/mlkit all.tst -no_gc) /bin/mv test_report.html test_report-native-nogc-$(DATE).html diff --git a/test/filesys.sml b/test/filesys.sml index 545bb911e..ed2e73b90 100644 --- a/test/filesys.sml +++ b/test/filesys.sml @@ -5,8 +5,8 @@ fun e1 seq e2 = e2; fun check b = if b then "OK" else "WRONG"; fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; -fun range (from, to) p = - let open Int +fun range (from, to) p = + let open Int in (from > to) orelse (p from) andalso (range (from+1, to) p) end; @@ -17,7 +17,7 @@ fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); fun tst s b = tst0 s (check b); fun tst' s f = tst0 s (check' f); -fun tstrange s bounds = (tst s) o range bounds +fun tstrange s bounds = (tst s) o range bounds (* test/filesys.sml PS 1995-03-23, 1996-05-01, 1998-04-06 @@ -29,10 +29,10 @@ fun tstrange s bounds = (tst s) o range bounds (* The test requires three symbolic links to be present in the current directory: testlink -> README - testcycl -> testcycl + testcycl -> testcycl testbadl -> exists.not Moreover, the file README must exist and the file exists.not not. - Also, the test requires one hard link between file hardlinkA and file hardlinkB. + Also, the test requires one hard link between file hardlinkA and file hardlinkB. *) val _ = print "\nFile filesys.sml: Testing structure FileSys...\n" @@ -40,18 +40,19 @@ val _ = print "\nFile filesys.sml: Testing structure FileSys...\n" local open FileSys (* Clean up: *) - val _ = (rmDir "testdir") handle OS.SysErr _ => (); - val _ = (rmDir "testdir2") handle OS.SysErr _ => (); + + val _ = (rmDir "testdir") handle OS.SysErr _ => (); + val _ = (rmDir "testdir2") handle OS.SysErr _ => (); val test1a = tst0 "test1a" ((mkDir "testdir" seq "OK") handle _ => "WRONG") val test1b = tst0 "test1b" ((mkDir "testdir" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") val test2 = tst' "test2" (fn _ => isDir "testdir"); - + val test3a = tst' "test3a" (fn _ => access("testdir", [A_READ, A_EXEC, A_WRITE])); -local +local val cdir = getDir(); in val test4a = tst0 "test4a" ((chDir cdir seq "OK") handle _ => "WRONG") @@ -66,7 +67,7 @@ val _ = rename{old = "testdir", new = "exists.not"}; val test5 = tst0 "test5" ((rmDir "exists.not" seq "OK") handle _ => "WRONG") -val test6a = tst0 "test6a" ((openDir "exists.not" seq "WRONG") +val test6a = tst0 "test6a" ((openDir "exists.not" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") val test6b = tst0 "test6b" ((isDir "exists.not" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") @@ -92,13 +93,13 @@ val test6l = tst' "test6l" (fn _ => not (access("exists.not", []))); val _ = mkDir "testdir"; -local +local val dstr = openDir "testdir"; in - val test7a = + val test7a = tst' "test7a" (fn _ => NONE = readDir dstr); val _ = rewindDir dstr; - val test7b = + val test7b = tst' "test7b" (fn _ => NONE = readDir dstr); val _ = closeDir dstr; val test7c = tst0 "test7c" ((readDir dstr seq "WRONG") @@ -109,9 +110,9 @@ in handle _ => "WRONG") end -val test8a = +val test8a = tst' "test8a" (fn _ => fullPath "." = getDir ()); -val test8b = +val test8b = tst' "test8b" (fn _ => fullPath "testlink" = getDir() ^ "/README"); val test8c = tst0 "test8c" ((fullPath "testcycl" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") @@ -124,42 +125,42 @@ val test8g = tst0 "test8g" ((realPath "testcycl" seq "WRONG") val test8h = tst0 "test8h" ((realPath "testbadl" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") -val test9a = - tst' "test9a" (fn _ => +val test9a = + tst' "test9a" (fn _ => setTime ("README", SOME (Time.fromReal 1E6)) = ()); -val test9b = +val test9b = tst' "test9b" (fn _ => modTime "README" = Time.fromReal 1E6); - + val test10a = tst0 "test10a" ((remove "testdir" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") -val test10b = - tst' "test10b" (fn _ => +val test10b = + tst' "test10b" (fn _ => rename{old = "testdir", new = "testdir2"} = ()); -val test10c = +val test10c = tst' "test10c" (fn _ => isDir "testdir2"); -val test11a = +val test11a = tst' "test11a" (fn _ => not (access ("testdir", []))); -val test11b = +val test11b = tst' "test11b" (fn _ => access("testlink", [])); -val test11c = +val test11c = tst' "test11c" (fn _ => not (access("testbadl", []))); -val test12a = - tst' "test12a" (fn _ => isLink "testcycl" +val test12a = + tst' "test12a" (fn _ => isLink "testcycl" andalso isLink "testlink" andalso isLink "testbadl"); -val test12b = +val test12b = tst' "test12b" (fn _ => not (isLink "testdir2" orelse isLink "README")); val test12c = tst0 "test12c" ((isLink "exists.not" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") -val test13a = +val test13a = tst' "test13a" (fn _ => readLink "testcycl" = "testcycl"); -val test13b = +val test13b = tst' "test13b" (fn _ => readLink "testlink" = "README"); -val test13c = +val test13c = tst' "test13c" (fn _ => readLink "testbadl" = "exists.not"); val test13d = tst0 "test13d" ((readLink "testdir2" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") @@ -168,23 +169,23 @@ val test13e = tst0 "test13e" ((readLink "exists.not" seq "WRONG") val test14 = tst0 "test14" ((tmpName () seq "OK")) -val test15a = - tst' "test15a" (fn _ => +val test15a = + tst' "test15a" (fn _ => fileId "." = fileId "." andalso fileId "testlink" = fileId "README" andalso fileId "." <> fileId "README"); -val test15b = +val test15b = tst' "test15b" (fn _ => compare(fileId ".", fileId ".") = EQUAL) val test15b1 = tst' "test15b1" (fn _ => compare(fileId ".", fileId "README") <> EQUAL) val test15b2 = tst' "test15b2" (fn _ => compare(fileId "testlink", fileId "README") = EQUAL) val test15b3 = - tst' "test15b3" (fn _ => - (compare(fileId ".", fileId "README") = LESS + tst' "test15b3" (fn _ => + (compare(fileId ".", fileId "README") = LESS andalso compare(fileId "README", fileId ".") = GREATER - orelse - compare(fileId ".", fileId "README") = GREATER + orelse + compare(fileId ".", fileId "README") = GREATER andalso compare(fileId "README", fileId ".") = LESS)); val test15c = tst0 "test15c" ((fileId "exists.not" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") @@ -193,7 +194,7 @@ val test15d = tst0 "test15d" ((fileId "testbadl" seq "WRONG") val test15e = tst0 "test15e" ((fileId "testcycl" seq "WRONG") handle OS.SysErr _ => "OK" | _ => "WRONG") (* Unix only: *) -val test15f = +val test15f = tst' "test15f" (fn _ => fileId "hardlinkA" = fileId "hardlinkB") val test15g = tst' "test15g" (fn _ => compare(fileId "hardlinkA", fileId "hardlinkB") = EQUAL) diff --git a/test/opaque2.sml.out.ok b/test/opaque2.sml.out.ok index e69de29bb..c56752b4a 100644 --- a/test/opaque2.sml.out.ok +++ b/test/opaque2.sml.out.ok @@ -0,0 +1 @@ +uncaught exception Match diff --git a/test/textio.sml.out.ok b/test/textio.sml.out.ok index cb25914ef..43990a0ac 100644 --- a/test/textio.sml.out.ok +++ b/test/textio.sml.out.ok @@ -6,7 +6,9 @@ test4 OK test5 OK test6 OK Two lines of output follow: -34235test7a OK +1234 <--- this should read 1234 +12345 <--- this should read 12345 +test7a OK test7b OK test7c OK test8a OK @@ -27,4 +29,5 @@ test12b OK test12c OK test12d OK Two lines of output follow: -abcdeabcde \ No newline at end of file +abcde <--- this should read abcde +abcde <--- this should read abcde diff --git a/test_dev/.gitignore b/test_dev/.gitignore new file mode 100644 index 000000000..c8ba1f3a2 --- /dev/null +++ b/test_dev/.gitignore @@ -0,0 +1,8 @@ +*.exe +*.out +*.res +MLB +*.mlbres +*.mlbexe +*.mlbout +complog.txt \ No newline at end of file diff --git a/test_dev/Initial.out.ok b/test_dev/Initial.out.ok new file mode 100644 index 000000000..8e9996702 --- /dev/null +++ b/test_dev/Initial.out.ok @@ -0,0 +1,16 @@ +Starting +Time +Timer +Real +Math +TextIO +Posix + - get + - getTi + - getT + - getT + - getT + - getT + - getN + - getNS +Done diff --git a/test_dev/Initial.sml b/test_dev/Initial.sml new file mode 100644 index 000000000..7e148c831 --- /dev/null +++ b/test_dev/Initial.sml @@ -0,0 +1,342 @@ +(* This structure declares values that must be initialised when the + * system starts executing. The purpose is to allow the clients of + * this structure to be discharged at link time; only files that are + * safe (no side effects) can be discharged at link time. ME 1998-08-21 *) + +structure Initial = + struct + infix - + * + + fun print (s:string) : unit = prim("printStringML", s) + val () = print "Starting\n" + + type int0 = int + type word0 = word (* used by WORD signature *) + + exception Fail of string + val _ = prim("sml_setFailNumber", (Fail "hat" : exn, 1 : int)) : unit; + + (* Time structure *) + val timebase : int = prim("get_time_base", 0) +(* val timebase = ~1073741820 - 4 13/04/1999, Niels*) + + (* Date structure *) + local fun localoffset_ () : real = prim("sml_localoffset", ()) + in val localoffset = localoffset_ () + val fail_asctime = Fail "asctime" + val fail_strftime = Fail "strftime" + end + + val () = print "Time\n" + + (* Timer *) + local + type tusage = {gcSec : int, gcUsec : int, + sysSec : int, sysUsec : int, + usrSec : int, usrUsec : int} + fun getrealtime_ () : {sec : int, usec : int} = + prim("sml_getrealtime", ()) + fun getrutime_ () : tusage = prim("sml_getrutime", ()) + in val initial_realtime = getrealtime_ () + val initial_rutime = getrutime_ () + end + + val () = print "Timer\n" + + (* Real structure *) + local + fun get_posInf () : real = prim ("posInfFloat", ()) + fun get_negInf () : real = prim ("negInfFloat", ()) + in + val posInf = get_posInf() + val negInf = get_negInf() + end + + val () = print "Real\n" + + (* Math structure *) + local + fun sqrt (r : real) : real = prim ("sqrtFloat", r) + fun ln' (r : real) : real = prim ("lnFloat", r) + in + val ln10 = ln' 10.0 + val NaN = sqrt ~1.0 + end + + val () = print "Math\n" + + (* Int structure. Integers are untagged (or tagged if GC is enabled), + * and there is a limit to the size of immediate integers that the Kit + * accepts. We should change the lexer such that it does not convert a + * string representation of an integer constant into an internal + * integer, as this makes the the kit dependent on the precision of + * the compiler (SML/NJ) that we use to compile the Kit. *) + + type int0 = int + val maxInt0 : int = prim("max_fixed_int", 0) + val minInt0 : int = prim("min_fixed_int", 0) + val precisionInt0 : int = prim("precision", 0) + + (* TextIO *) + val stdIn_stream : int = prim ("stdInStream", 0) + val stdOut_stream : int = prim ("stdOutStream", 0) + val stdErr_stream : int = prim ("stdErrStream", 0) + val failscan : exn = Fail "scanStream: backtracking too far" + + val () = print "TextIO\n" + + (* FileSys *) + structure FileSys = + struct + val filesys_fail : exn = Fail "FileSys" + end + + (* Process *) + val exittasks = (ref []) : (unit -> unit) list ref + val exitCalled = ref false + exception RaisedInExit + + val clearnerAtExit = (ref []) : (unit -> unit) list ref + val addedclearner = ref false + exception ClosedStream + + (* Posix *) + + structure TextIO = + struct + val bufsize = 4000 + val flushStdOut = ref (fn x => x) : (unit -> unit) ref + end + + val () = print "Posix\n" + + structure Posix_Values = + struct + fun getN s = prim("@sml_syserror", s : string) : int + fun getNS s = prim("@sml_findsignal", s : string) : int + fun getT i = prim("@sml_getTty", i : int) : word + fun getTi i = prim("@sml_getTty", i : int) : int + + val () = print " - get\n" + + structure Tty = + struct + structure V = + struct + val eof = getTi 0 + val eol = getTi 1 + val erase = getTi 2 + val intr = getTi 3 + val kill = getTi 4 + val min = getTi 5 + val quit = getTi 6 + val susp = getTi 7 + val time = getTi 8 + val start = getTi 9 + val stop = getTi 10 + val nccs = getTi 70 + + val () = print " - getTi\n" + end + structure I = + struct + val brkint = getT 11 + val icrnl = getT 12 + val ignbrk = getT 13 + val igncr = getT 14 + val ignpar = getT 15 + val inlcr = getT 16 + val inpck = getT 17 + val istrip = getT 18 + val ixoff = getT 19 + val ixon = getT 20 + val parmrk = getT 21 + val all = getT 44 + val () = print " - getT\n" + end + structure O = + struct + val opost = getT 22 + val all = opost + end + structure C = + struct + val clocal = getT 23 + val cread = getT 24 + val cs5 = getT 25 + val cs6 = getT 26 + val cs7 = getT 27 + val cs8 = getT 28 + val csize = getT 29 + val cstopb = getT 30 + val hupcl = getT 31 + val parenb = getT 32 + val parodd = getT 33 + val all = getT 45 + val () = print " - getT\n" + end + structure L = + struct + val echo = getT 34 + val echoe = getT 35 + val echok = getT 36 + val echonl = getT 37 + val icanon = getT 38 + val iexten = getT 39 + val isig = getT 40 + val noflsh = getT 41 + val tostop = getT 42 + val all = getT 46 + val () = print " - getT\n" + end + structure Speed = + struct + val b0 = getT 48 + val b50 = getT 49 + val b75 = getT 50 + val b110 = getT 51 + val b134 = getT 52 + val b150 = getT 53 + val b200 = getT 54 + val b300 = getT 55 + val b600 = getT 56 + val b1200 = getT 57 + val b1800 = getT 58 + val b2400 = getT 59 + val b4800 = getT 60 + val b9600 = getT 61 + val b19200 = getT 62 + val b38400 = getT 63 + val b57600 = getT 64 + val b115200 = getT 65 + val b230400 = getT 66 + val () = print " - getT\n" + end + end + + structure Err = + struct + val acces = getN "EACCES" + val again = getN "EAGAIN" + val badf = getN "EBADF" + val badmsg = getN "EBADMSG" + val busy = getN "EBUSY" + val canceled = getN "ECANCELED" + val child = getN "ECHILD" + val deadlk = getN "EDEADLK" + val dom = getN "EDOM" + val exist = getN "EEXIST" + val fault = getN "EFAULT" + val fbig = getN "EFBIG" + val inprogress = getN "EINPROGRESS" + val intr = getN "EINTR" + val inval = getN "EINVAL" + val io = getN "EIO" + val isdir = getN "EISDIR" + val loop = getN "ELOOP" + val mfile = getN "EMFILE" + val mlink = getN "EMLINK" + val msgsize = getN "EMSGSIZE" + val nametoolong = getN "ENAMETOOLONG" + val nfile = getN "ENFILE" + val nodev = getN "ENODEV" + val noent = getN "ENOENT" + val noexec = getN "ENOEXEC" + val nolck = getN "ENOLCK" + val nomem = getN "ENOMEM" + val nospc = getN "ENOSPC" + val nosys = getN "ENOSYS" + val notdir = getN "ENOTDIR" + val notsup = getN "ENOTSUP" + val notsock = getN "ENOTSOCK" + val notempty = getN "ENOTEMPTY" + val notty = getN "ENOTTY" + val nxio = getN "ENXIO" + val perm = getN "EPERM" + val pipe = getN "EPIPE" + val range = getN "ERANGE" + val rofs = getN "EROFS" + val spipe = getN "ESPIPE" + val srch = getN "ESRCH" + val toobig = getN "E2BIG" + val xdev = getN "EXDEV" + val () = print " - getN\n" + end + structure Signal = + struct + val abrt = getNS "SIGABRT" + val alrm = getNS "SIGALRM" + val bus = getNS "SIGBUS" + val fpe = getNS "SIGFPE" + val hup = getNS "SIGHUP" + val ill = getNS "SIGILL" + val int = getNS "SIGINT" + val kill = getNS "SIGKILL" + val pipe = getNS "SIGPIPE" + val quit = getNS "SIGQUIT" + val segv = getNS "SIGSEGV" + val term = getNS "SIGTERM" + val usr1 = getNS "SIGUSR1" + val usr2 = getNS "SIGUSR2" + val chld = getNS "SIGCHLD" + val cont = getNS "SIGCONT" + val stop = getNS "SIGSTOP" + val tstp = getNS "SIGTSTP" + val ttin = getNS "SIGTTIN" + val ttou = getNS "SIGTTOU" + val () = print " - getNS\n" + end + + structure Process = + struct + val untraced = 0wx1 + val nohang = 0wx2 + val all = untraced (* untraced *) + end + end + + structure Posix_File_Sys = + struct + val (stdin,stdout,stderr) = prim ("sml_getStdNumbers", ()) : (int * int * int) + + structure O = + struct + val append = 0wx1 + val excl = 0wx2 + val noctty = 0wx4 + val nonblock = 0wx8 + val sync = 0wx10 + val trunc = 0wx20 + val text = 0wx40 + val bin = 0wx80 + val rdonly = 0wx100 + val wronly = 0wx200 + val rdwr = 0wx400 + + val all = 0wx3F (* [append,excl,noctty,nonblock,sync,trunc] *) + end + + structure S = + struct + val irwxu = 0wx1 + val irusr = 0wx2 + val iwusr = 0wx4 + val ixusr = 0wx8 + val irwxg = 0wx10 + val irgrp = 0wx20 + val iwgrp = 0wx40 + val ixgrp = 0wx80 + val irwxo = 0wx100 + val iroth = 0wx200 + val iwoth = 0wx400 + val ixoth = 0wx800 + val isuid = 0wx1000 + val isgid = 0wx2000 + + val all = 0wx3FFF + end + end + + val () = print "Done\n" + + end diff --git a/test_dev/Makefile b/test_dev/Makefile new file mode 100644 index 000000000..2c5edb80e --- /dev/null +++ b/test_dev/Makefile @@ -0,0 +1,244 @@ +TESTFILES=int_first.sml raise_div.sml b3.sml a1.sml exn1.sml exn2.sml exn3.sml \ + exception1.sml exception3.sml exception5.sml f1.sml f2.sml fib.sml \ + fib0.sml global_region.sml hanoi.sml hello.sml if.sml immedString.sml l1.sml list_nh.sml \ + ref-int.sml ref.sml string1.sml test_dattyp.sml foldl.sml real_cmp.sml real0.sml \ + real_negabs.sml real1.sml real2.sml testdyn1-nobasis.sml ref-real.sml \ + kitkbjul9_no_basislib.sml fft_no_basislib.sml kitlife35u_no_basislib.sml \ + kitqsort_no_basislib.sml kitsimple_no_basislib.sml kittmergesort_no_basislib.sml \ + kitreynolds2_no_basislib.sml kitreynolds3_no_basislib.sml professor_game.sml \ + ccall.sml auto.sml Initial.sml string_sub.sml \ + int_overflow.sml sign.sml word_list.sml build.sml reg.sml + +#shra.sml + +#string_upd.sml string_update.sml + +#exception4.sml + +TESTFILES_MLB=a.mlb b.mlb c.mlb + +RI_RESFILES=$(TESTFILES:%.sml=%-ri.res) +GC_RESFILES=$(TESTFILES:%.sml=%-gc.res) +P_RESFILES=$(TESTFILES:%.sml=%-p.res) +GCP_RESFILES=$(TESTFILES:%.sml=%-gcp.res) + +RI_RESFILES_MLB=$(TESTFILES_MLB:%.mlb=%-ri.mlbres) +GC_RESFILES_MLB=$(TESTFILES_MLB:%.mlb=%-gc.mlbres) +P_RESFILES_MLB=$(TESTFILES_MLB:%.mlb=%-p.mlbres) +GCP_RESFILES_MLB=$(TESTFILES_MLB:%.mlb=%-gcp.mlbres) + +RESFILES_PROF=$(GCP_RESFILES) $(GCP_RESFILES_MLB) $(P_RESFILES) $(P_RESFILES_MLB) +RESFILES_ALL=$(GC_RESFILES) $(GC_RESFILES_MLB) $(RI_RESFILES) $(RI_RESFILES_MLB) + +#EXEFLAGS=-verbose_gc +#EXEFLAGS=-disable_gc -verbose_gc + +#GC_FLAGS=--no_basislib --comments_in_x64_asmcode --debug_linking -g --no_delete_target_files +GC_FLAGS=--no_basislib +RI_FLAGS=$(GC_FLAGS) -no_gc +PROF_FLAGS=$(RI_FLAGS) -prof +GC_PROF_FLAGS=$(GC_FLAGS) -prof + +MLKIT=../bin/mlkit + +.PHONY: tst +tst: + echo $(RESFILES_ALL) + +.PHONY: all +all: test + +.PHONY: runtime +runtime: + make -C ../src/Runtime clean + make -C ../src/Runtime runtimeSystemGCProf.a runtimeSystemGC.a runtimeSystemProf.a runtimeSystem.a + +%-ri.exe: %.sml + @SML_LIB=.. $(MLKIT) $(RI_FLAGS) -o $@ $< >> complog.txt + +%-ri.mlbexe: %.mlb + @SML_LIB=.. $(MLKIT) $(RI_FLAGS) -o $@ $< >> complog.txt + +%-gc.exe: %.sml + @SML_LIB=.. $(MLKIT) $(GC_FLAGS) -o $@ $< >> complog.txt + +%-gc.mlbexe: %.mlb + @SML_LIB=.. $(MLKIT) $(GC_FLAGS) -o $@ $< >> complog.txt + +%-p.exe: %.sml + @SML_LIB=.. $(MLKIT) $(PROF_FLAGS) -o $@ $< >> complog.txt + +%-p.mlbexe: %.mlb + @SML_LIB=.. $(MLKIT) $(PROF_FLAGS) -o $@ $< >> complog.txt + +%-gcp.exe: %.sml + @SML_LIB=.. $(MLKIT) $(GC_PROF_FLAGS) -o $@ $< >> complog.txt + +%-gcp.mlbexe: %.mlb + @SML_LIB=.. $(MLKIT) $(GC_PROF_FLAGS) -o $@ $< >> complog.txt + +%.mlbout: %.mlbexe + @(./$< $(EXEFLAGS) > $@ 2>&1; echo "done" >> /dev/null) + +%.out: %.exe + @(./$< $(EXEFLAGS) > $@ 2>&1; echo "done" >> /dev/null) + +%-ri.res: %-ri.out + @(diff -aq $< $*.out.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*-ri: OK" > $@ \ + ; else \ + if [ -e $*.out.ok ]; then \ + echo "Test $*-ri: *** ERR: file $< differs from $*.out.ok ***" > $@ \ + ; else \ + echo "Test $*-ri: *** ERR: file $*.out.ok does not exist ***" > $@ \ + ; fi \ + ; fi) + @cat $@ + @cat $@ >> complog.txt + +%-ri.mlbres: %-ri.mlbout + @(diff -aq $< $*.mlbout.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*-ri: OK" > $@ \ + ; else \ + if [ -e $*.mlbout.ok ]; then \ + echo "Test $*-ri: *** ERR: file $< differs from $*.mlbout.ok ***" > $@ \ + ; else \ + echo "Test $*-ri: *** ERR: file $*.mlbout.ok does not exist ***" > $@ \ + ; fi \ + ; fi) + @cat $@ + @cat $@ >> complog.txt + +%-gc.res: %-gc.out + @(diff -aq $< $*.out.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*-gc: OK" > $@ \ + ; else \ + if [ -e $*.out.ok ]; then \ + echo "Test $*-gc: *** ERR: file $< differs from $*.out.ok ***" > $@ \ + ; else \ + echo "Test $*-gc: *** ERR: file $*.out.ok does not exist ***" > $@ \ + ; fi \ + ; fi) + @cat $@ + @cat $@ >> complog.txt + +%-gc.mlbres: %-gc.mlbout + @(diff -aq $< $*.mlbout.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*-gc: OK" > $@ \ + ; else \ + if [ -e $*.mlbout.ok ]; then \ + echo "Test $*-gc: *** ERR: file $< differs from $*.mlbout.ok ***" > $@ \ + ; else \ + echo "Test $*-gc: *** ERR: file $*.mlbout.ok does not exist ***" > $@ \ + ; fi \ + ; fi) + @cat $@ + @cat $@ >> complog.txt + +%-p.res: %-p.out + @(diff -aq $< $*.out.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*-p: OK" > $@ \ + ; else \ + if [ -e $*.out.ok ]; then \ + echo "Test $*-p: *** ERR: file $< differs from $*.out.ok ***" > $@ \ + ; else \ + echo "Test $*-p: *** ERR: file $*.out.ok does not exist ***" > $@ \ + ; fi \ + ; fi) + @cat $@ + @cat $@ >> complog.txt + +%-p.mlbres: %-p.mlbout + @(diff -aq $< $*.mlbout.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*-p: OK" > $@ \ + ; else \ + if [ -e $*.mlbout.ok ]; then \ + echo "Test $*-p: *** ERR: file $< differs from $*.mlbout.ok ***" > $@ \ + ; else \ + echo "Test $*-p: *** ERR: file $*.mlbout.ok does not exist ***" > $@ \ + ; fi \ + ; fi) + @cat $@ + @cat $@ >> complog.txt + +%-gcp.res: %-gcp.out + @(diff -aq $< $*.out.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*-gcp: OK" > $@ \ + ; else \ + if [ -e $*.out.ok ]; then \ + echo "Test $*-gcp: *** ERR: file $< differs from $*.out.ok ***" > $@ \ + ; else \ + echo "Test $*-gcp: *** ERR: file $*.out.ok does not exist ***" > $@ \ + ; fi \ + ; fi) + @cat $@ + @cat $@ >> complog.txt + +%-gcp.mlbres: %-gcp.mlbout + @(diff -aq $< $*.mlbout.ok > /dev/null 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "Test $*-gcp: OK" > $@ \ + ; else \ + if [ -e $*.mlbout.ok ]; then \ + echo "Test $*-gcp: *** ERR: file $< differs from $*.mlbout.ok ***" > $@ \ + ; else \ + echo "Test $*-gcp: *** ERR: file $*.mlbout.ok does not exist ***" > $@ \ + ; fi \ + ; fi) + @cat $@ + @cat $@ >> complog.txt + +.PHONY: test +test: $(RESFILES_ALL) + @cat $(RESFILES_ALL) + @echo "-------T E S T --- R E P O R T-------" + @echo "Tests succeeded: `grep "OK" $(RESFILES_ALL) | wc -l` /`grep "Test" $(RESFILES_ALL) | wc -l`" + @echo "Test errors: `grep "ERR" $(RESFILES_ALL) | wc -l` /`grep "Test" $(RESFILES_ALL) | wc -l`" + @echo "See complog.txt" + @echo "-------------------------------------" + @exit `grep "ERR" $(RESFILES_ALL) | wc -l` + +.PHONY: test_prof +test_prof: $(RESFILES_PROF) + @cat $(RESFILES_PROF) + @echo "------- T E S T --- R E P O R T ----- P R O F I L I N G ------" + @echo "Tests succeeded: `grep "OK" $(RESFILES_PROF) | wc -l` /`grep "Test" $(RESFILES_PROF) | wc -l`" + @echo "Test errors: `grep "ERR" $(RESFILES_PROF) | wc -l` /`grep "Test" $(RESFILES_PROF) | wc -l`" + @echo "See complog.txt" + @echo "--------------------------------------------------------------" + @exit `grep "ERR" $(RESFILES_PROF) | wc -l` + +.PHONY: clean +clean: + rm -rf MLB *~ *.exe *.res *.out *.mlbexe *.mlbout *.mlbres run *.pdf *.ps *.rp complog.txt + +.PHONY: prof +prof: kitlife35u_no_basislib.pdf + +%-prof.exe: %.sml + SML_LIB=.. $(MLKIT) $(PROF_FLAGS) -o $*-prof.exe $< + +%.rp: %-prof.exe + ./$< -microsec 1000 -verbose -file $@ + +%.ps: %.rp + ../bin/rp2ps -source $< -region $@ + +%.pdf: %.ps + ps2pdf $< $@ + +# avoid deletion of exe-files and out-files +dummy1: $(TESTFILES:%.sml=%-ri.exe) $(TESTFILES:%.sml=%-gc.exe) $(TESTFILES:%.sml=%-p.exe) $(TESTFILES:%.sml=%-gcp.exe) + +dummy2: $(TESTFILES_MLB:%.mlb=%-ri.mlbexe) $(TESTFILES_MLB:%.mlb=%-gc.mlbexe) $(TESTFILES_MLB:%.mlb=%-p.mlbexe) $(TESTFILES_MLB:%.mlb=%-gcp.mlbexe) + +dummy3: $(TESTFILES:%.sml=%-ri.out) $(TESTFILES:%.sml=%-gc.out) $(TESTFILES:%.sml=%-p.out) $(TESTFILES:%.sml=%-gcp.out) + +dummy3: $(TESTFILES_MLB:%.mlb=%-ri.mlbout) $(TESTFILES_MLB:%.mlb=%-gc.mlbout) $(TESTFILES_MLB:%.mlb=%-p.mlbout) $(TESTFILES_MLB:%.mlb=%-gcp.mlbout) diff --git a/test_dev/README_KAM.md b/test_dev/README_KAM.md new file mode 100644 index 000000000..8220fc26f --- /dev/null +++ b/test_dev/README_KAM.md @@ -0,0 +1,43 @@ +Programs that work with the KAM backend: + + a.pm ok + b.pm ok + exn1.sml ok + exn2.sml ok + exn3.sml ok + exn4.sml ok + exception1.sml ok + exception2.sml ok + exception3.sml ok + exception4.sml ok + exception5.sml ok + f1.sml ok + f2.sml ok + fft_no_basislib.sml + fib.sml ok + fib0.sml ok + foldl.sml ok + global_region.sml ok + hanoi.sml ok + hello.sml ok + if.sml ok + immedString.sml ok + kitkbjul9_no_basislib.sml oversætter men udskriver intet når det køres! + kitlife35u_no_basislib.sml oversætter men udskriver intet når det køres! + kitqsort_no_basislib.sml + kitreynolds2_no_basislib.sml + kitreynolds3_no_basislib.sml + kitsimple_no_basislib.sml + kittmergesort_no_basislib.sml + l1.sml ok + list_nh.sml ok + listpair.sml + professor_game.sml oversætter men udskriver intet når det køres! + real1.sml + ref-int.sml + ref-real.sml + ref.sml + string1.sml + test_dattyp.sml + testdyn1.sml + testdyn2.sml diff --git a/test_dev/README_X64.md b/test_dev/README_X64.md new file mode 100644 index 000000000..9109127b6 --- /dev/null +++ b/test_dev/README_X64.md @@ -0,0 +1,50 @@ +## Programs that work with the X64 backend: + + int_first.sml ok + raise_div.sml ok + b3.sml ok + a1.sml ok + a.mlb ok + b.mlb ok + exn1.sml ok + exn2.sml ok + exn3.sml ok + exn4.sml ok + exception1.sml ok + exception3.sml ok + exception4.sml ok + exception5.sml ok + f1.sml ok + f2.sml ok + fib.sml ok + fib0.sml ok + global_region.sml ok + hanoi.sml ok + hello.sml ok + if.sml ok + immedString.sml ok + l1.sml ok + list_nh.sml ok + ref-int.sml ok + ref.sml ok + string1.sml ok + test_dattyp.sml ok + foldl.sml ok + testdyn1-nobasis.sml ok + real0.sml ok + real1.sml ok + real2.sml ok + ref-real.sml ok + fft_no_basislib.sml ok + kitkbjul9_no_basislib.sml ok + kitlife35u_no_basislib.sml ok + kitqsort_no_basislib.sml ok + kitreynolds2_no_basislib.sml ok + kitreynolds3_no_basislib.sml ok + kitsimple_no_basislib.sml ok + kittmergesort_no_basislib.sml ok + professor_game.sml ok + + testdyn2.sml + exception2.sml + listpair.sml diff --git a/test_dev/a.mlb b/test_dev/a.mlb new file mode 100644 index 000000000..e902056b3 --- /dev/null +++ b/test_dev/a.mlb @@ -0,0 +1,2 @@ +a1.sml +a2.sml diff --git a/test_dev/a.mlbout.ok b/test_dev/a.mlbout.ok new file mode 100644 index 000000000..ea9e3cd62 --- /dev/null +++ b/test_dev/a.mlbout.ok @@ -0,0 +1,2 @@ +Hello world +This is also a string diff --git a/test_dev/a1.out.ok b/test_dev/a1.out.ok new file mode 100644 index 000000000..54bf7edac --- /dev/null +++ b/test_dev/a1.out.ok @@ -0,0 +1 @@ +Hello \ No newline at end of file diff --git a/test_dev/a1.sml b/test_dev/a1.sml index d8dec291f..09a4d0365 100644 --- a/test_dev/a1.sml +++ b/test_dev/a1.sml @@ -1,4 +1,4 @@ -fun print (s:string) : unit = prim("printStringML", "printStringML", s) +fun print (s:string) : unit = prim("printStringML", s) local val _ = print "Hello " in diff --git a/test_dev/a2.sml b/test_dev/a2.sml index 5cb70d216..d0efad71a 100644 --- a/test_dev/a2.sml +++ b/test_dev/a2.sml @@ -1,4 +1,4 @@ -local +local val _ = print "world\n" val a = "This is also a string\n" val _ = print a diff --git a/test_dev/auto.out.ok b/test_dev/auto.out.ok new file mode 100644 index 000000000..5eb123e03 --- /dev/null +++ b/test_dev/auto.out.ok @@ -0,0 +1 @@ +Num: 23 diff --git a/test_dev/auto.sml b/test_dev/auto.sml new file mode 100644 index 000000000..ae0561bde --- /dev/null +++ b/test_dev/auto.sml @@ -0,0 +1,10 @@ + +fun runtime_test0 (a1:int,a2:int,a3:int) : int = + prim("@runtime_test0", (a1,a2,a3)) + +fun print (s:string) : unit = prim("printStringML", s) +fun printNum (n:int) : unit = prim("printNum", n) + +val x = runtime_test0 (1,2,3) + +val () = printNum x diff --git a/test_dev/b.mlb b/test_dev/b.mlb new file mode 100644 index 000000000..9e3b5d793 --- /dev/null +++ b/test_dev/b.mlb @@ -0,0 +1,2 @@ +b1.sml +b2.sml diff --git a/test_dev/b.mlbout.ok b/test_dev/b.mlbout.ok new file mode 100644 index 000000000..c1b8f29a1 --- /dev/null +++ b/test_dev/b.mlbout.ok @@ -0,0 +1,2 @@ +Hi +HelloHej Med dig \ No newline at end of file diff --git a/test_dev/b2.sml b/test_dev/b2.sml index 00a84814c..ebd3d04da 100644 --- a/test_dev/b2.sml +++ b/test_dev/b2.sml @@ -1,9 +1,9 @@ local - fun print (s:string) : unit = prim("printStringML", "printStringML", s) - val _ = print a - val _ = (print (#1 b); print " "; print (#2 b)) + fun print (s:string) : unit = prim("printStringML", s) + val () = print "Hi\n" + val () = print a + val () = (print (#1 b); print " "; print (#2 b)) in end - diff --git a/test_dev/b3.out.ok b/test_dev/b3.out.ok new file mode 100644 index 000000000..f50660ec6 --- /dev/null +++ b/test_dev/b3.out.ok @@ -0,0 +1 @@ +Hej Med dig \ No newline at end of file diff --git a/test_dev/b3.sml b/test_dev/b3.sml new file mode 100644 index 000000000..8c147c59a --- /dev/null +++ b/test_dev/b3.sml @@ -0,0 +1,8 @@ +local + val b = ("Hej", "Med dig") +fun print (s:string) : unit = prim("printStringML", s) +in +val () = print (#1 b) +val () = print " " +val () = print (#2 b) +end diff --git a/test_dev/build.out.ok b/test_dev/build.out.ok new file mode 100644 index 000000000..831b9e3a0 --- /dev/null +++ b/test_dev/build.out.ok @@ -0,0 +1,12 @@ +Hi there +Num: 1010 +Num: 1009 +Num: 1008 +Num: 1007 +Num: 1006 +Num: 1005 +Num: 1004 +Num: 1003 +Num: 1002 +Num: 1001 +Num: 1000 diff --git a/test_dev/build.sml b/test_dev/build.sml new file mode 100644 index 000000000..44bebd641 --- /dev/null +++ b/test_dev/build.sml @@ -0,0 +1,38 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun exnName (e: exn) : string = prim("exnNameML", e) (* exomorphic by copying *) + +fun !(x: 'a ref): 'a = prim ("!", x) +fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) +fun not true = false | not false = true +fun a <> b = not (a = b) +fun print (s:string) : unit = prim("printStringML", s) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) + +val () = print "Hi there\n" + +fun build (n,acc) = + if n = 0 then acc + else build(n-1,("Hi",n)::acc) + +fun len (nil,acc) = acc + | len (x::xs,acc) = len(xs,acc+1) + +fun printNum (n:int):unit = prim("printNum",n) + +val r : (string * int) list ref = ref nil + +fun loop n = if n < 0 then () + else let val x = build (n+1000,nil) + val () = r := x + val () = printNum(len (x,0)) + in loop (n-1) + end + +val () = loop 10 diff --git a/test_dev/c.mlb b/test_dev/c.mlb new file mode 100644 index 000000000..316e46adf --- /dev/null +++ b/test_dev/c.mlb @@ -0,0 +1,2 @@ +c1.sml +c2.sml diff --git a/test_dev/c.mlbout.ok b/test_dev/c.mlbout.ok new file mode 100644 index 000000000..70c379b63 --- /dev/null +++ b/test_dev/c.mlbout.ok @@ -0,0 +1 @@ +Hello world \ No newline at end of file diff --git a/test_dev/c1.sml b/test_dev/c1.sml new file mode 100644 index 000000000..7b6c72b9e --- /dev/null +++ b/test_dev/c1.sml @@ -0,0 +1 @@ +val a = "Hello " diff --git a/test_dev/c2.sml b/test_dev/c2.sml new file mode 100644 index 000000000..b67ae0915 --- /dev/null +++ b/test_dev/c2.sml @@ -0,0 +1,14 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun print (s:string) : unit = prim("printStringML", s) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) + +val b = "world" +val c = a ^ b + +val () = print c diff --git a/test_dev/ccall.out.ok b/test_dev/ccall.out.ok new file mode 100644 index 000000000..ed90fae1d --- /dev/null +++ b/test_dev/ccall.out.ok @@ -0,0 +1 @@ +Num: 1096 diff --git a/test_dev/ccall.sml b/test_dev/ccall.sml new file mode 100644 index 000000000..e59986f2f --- /dev/null +++ b/test_dev/ccall.sml @@ -0,0 +1,11 @@ + +fun runtime_test1 (a1:int,a2:int,a3:int,a4:int,a5:int, + a6:int,a7:int,a8:int,a9:int,a10:int) : int = + prim("runtime_test1", (a1,a2,a3,a4,a5,a6,a7,a8,a9,a10)) + +fun print (s:string) : unit = prim("printStringML", s) +fun printNum (n:int) : unit = prim("printNum", n) + +val x = runtime_test1 (1,2,3,4,5,6,7,8,9,10) + +val () = printNum x diff --git a/test_dev/empty.sml b/test_dev/empty.sml new file mode 100644 index 000000000..8a8395e1e --- /dev/null +++ b/test_dev/empty.sml @@ -0,0 +1 @@ +(* the empty program *) diff --git a/test_dev/exception1.out.ok b/test_dev/exception1.out.ok new file mode 100644 index 000000000..cda2d30d8 --- /dev/null +++ b/test_dev/exception1.out.ok @@ -0,0 +1 @@ +E raised, ok diff --git a/test_dev/exception1.sml b/test_dev/exception1.sml index 47d6ab564..1dd33f1b3 100644 --- a/test_dev/exception1.sml +++ b/test_dev/exception1.sml @@ -5,12 +5,12 @@ infix 3 := o type 'a ref = 'a ref - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) + fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) - fun print (s:string) : unit = prim("printStringML", "printStringML", s) - fun printNum (n:int):unit = prim("printNum","printNum",n) + fun print (s:string) : unit = prim("printStringML", s) + fun printNum (n:int):unit = prim("printNum",n) -val x = +val x = let exception E val z = (if (2=2) then (raise E) else print "E not raised, error\n") @@ -23,11 +23,11 @@ val x = exception G of int exception G' of int - val x = 2 + val x = 2 val y = 3 - val q = - (if (2=2) then raise G'(x + y) else y - x) + val q = + (if (2=2) then raise G'(x + y) else y - x) handle G' x => (print "G' Raised\n"; x) | G x => (print "G Raised\n"; x+2) val _ = printNum q*) diff --git a/test_dev/exception2.sml b/test_dev/exception2.sml index 10d0edf4d..fd903d959 100644 --- a/test_dev/exception2.sml +++ b/test_dev/exception2.sml @@ -2,26 +2,24 @@ infix 6 + - infixr 5 :: infix 4 = <> > >= < <= infix 3 := o -type 'a ref = 'a ref -fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) -fun print (s:string) : unit = prim("printStringML", "printStringML", s) -fun printNum (n:int):unit = prim("printNum","printNum",n) +fun print (s:string) : unit = prim("printStringML", s) -val x = +val x = let - exception E - exception E' of int - exception E'' - fun f (E,x) = print x - | f (E' 1,x) = print x - | f (E'',x) = print x - | f (_,x) = print x + exception E + exception A of int + exception B + fun f (E,x) = print x + | f (A 1,x) = print x + | f (B,x) = print x + | f (_,x) = print x val _ = f(E,"Test OK\n") - val _ = f(E' 1,"Test OK\n") - val _ = f(E'',"Test OK\n") - val _ = f(E' 2,"Test OK\n") -in - 2 -end; + val _ = f(A 1,"Test OK\n") + val _ = f(B,"Test OK\n") + val _ = f(A 2,"Test OK\n") + in + 2 + end diff --git a/test_dev/exception3.out.ok b/test_dev/exception3.out.ok new file mode 100644 index 000000000..4ae9d74a4 --- /dev/null +++ b/test_dev/exception3.out.ok @@ -0,0 +1 @@ +OK-Something else... diff --git a/test_dev/exception3.sml b/test_dev/exception3.sml index 17b6c3671..ad18a58ab 100644 --- a/test_dev/exception3.sml +++ b/test_dev/exception3.sml @@ -4,20 +4,20 @@ infix 4 = <> > >= < <= infix 3 := o type 'a ref = 'a ref -fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) -fun print (s:string) : unit = prim("printStringML", "printStringML", s) -fun printNum (n:int):unit = prim("printNum","printNum",n) +fun print (s:string) : unit = prim("printStringML", s) +fun printNum (n:int):unit = prim("printNum",n) -local +local exception E of int -in +in exception F exception G - val y = + val y = case G of - E x => (print "E raised: "; printNum x; print "\n") - | F => print "F raised\n" - | _ => print "OK-Something else is raised\n" + E x => (print "E matched: "; printNum x; print "\n") + | F => print "F matched\n" + | _ => print "OK-Something else...\n" end; diff --git a/test_dev/exception4.out.ok b/test_dev/exception4.out.ok new file mode 100644 index 000000000..fcc1b0b00 --- /dev/null +++ b/test_dev/exception4.out.ok @@ -0,0 +1,6 @@ +Ok - In handle BIND0 +Ok - In handle BIND1 +Ok, - no error... +OK - In handle MATCH0 +Ok, - Match no error... +OK if uncaught exception Match diff --git a/test_dev/exception4.sml b/test_dev/exception4.sml index c3b8e5dcc..43ad46211 100644 --- a/test_dev/exception4.sml +++ b/test_dev/exception4.sml @@ -6,13 +6,13 @@ local infix 3 := o type 'a ref = 'a ref - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) + fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) - fun print (s:string) : unit = prim("printStringML", "printStringML", s) - fun printNum (n:int):unit = prim("printNum","printNum",n) + fun print (s:string) : unit = prim("printStringML", s) + fun printNum (n:int):unit = prim("printNum",n) in (* end of prelude *) - + datatype t = A | B of int val _ = (raise Bind) handle Bind => (print "Ok - In handle BIND0\n") @@ -22,20 +22,20 @@ in (* end of prelude *) in 0 end handle Bind => (print "Ok - In handle BIND1\n"; 10) - - val _ = case a + + val _ = case a of 0 => print "Not good - error...\n" - | 10 => print "Ok, - no error...\n" + | 10 => print "Ok, - no error...\n" | _ => print "Weird - error...\n" val _ = (raise Match) handle Match => (print "OK - In handle MATCH0\n") - val _ = - (case a + val _ = + (case a of 0 => print "Not good - error...\n") handle Match => print "Ok, - Match no error...\n" val _ = print "OK if uncaught exception Match\n" val _ = raise Match -end \ No newline at end of file +end diff --git a/test_dev/exception5.out.ok b/test_dev/exception5.out.ok new file mode 100644 index 000000000..8de1c58e5 --- /dev/null +++ b/test_dev/exception5.out.ok @@ -0,0 +1,9 @@ +Num: 1 +hej +Testing generative exceptions: +Enter f with x=Num: 1 + +Enter f with x=Num: 0 + +In handle _ +Ok - exn - generative... diff --git a/test_dev/exception5.sml b/test_dev/exception5.sml index 4a08bfc93..f56620601 100644 --- a/test_dev/exception5.sml +++ b/test_dev/exception5.sml @@ -4,16 +4,16 @@ infix 4 = <> > >= < <= infix 3 := o type 'a ref = 'a ref -fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) -fun print (s:string) : unit = prim("printStringML", "printStringML", s) -fun printNum (n:int):unit = prim("printNum","printNum",n) +fun print (s:string) : unit = prim("printStringML", s) +fun printNum (n:int):unit = prim("printNum",n) -fun error b s = - (if b then +fun error b s = + (if b then (print "Ok - "; print s) - else + else (print "Error - "; print s); print "...\n") @@ -33,9 +33,9 @@ val _ = print "Enter f with x="; printNum x; print "\n"; - if x < 1 then + if x < 1 then raise E - else + else ((f (x-1)) handle E => (print "In handle E\n"; 7)) (* should not handle this.. *) end in diff --git a/test_dev/exn1.out.ok b/test_dev/exn1.out.ok new file mode 100644 index 000000000..5a91a7f3b --- /dev/null +++ b/test_dev/exn1.out.ok @@ -0,0 +1 @@ +uncaught exception E diff --git a/test_dev/exn2.out.ok b/test_dev/exn2.out.ok new file mode 100644 index 000000000..57e64e148 --- /dev/null +++ b/test_dev/exn2.out.ok @@ -0,0 +1 @@ +**9** \ No newline at end of file diff --git a/test_dev/exn2.sml b/test_dev/exn2.sml index 50c93fbbc..b062c3e3f 100644 --- a/test_dev/exn2.sml +++ b/test_dev/exn2.sml @@ -1,7 +1,7 @@ exception E -fun print (s:string) : unit = prim("printStringML", "printStringML", s) +fun print (s:string) : unit = prim("printStringML", s) val a : string = ("**5**"; raise E) handle _ => "**9**" -val _ = print a \ No newline at end of file +val _ = print a diff --git a/test_dev/exn3.out.ok b/test_dev/exn3.out.ok new file mode 100644 index 000000000..c85c81899 --- /dev/null +++ b/test_dev/exn3.out.ok @@ -0,0 +1 @@ +**ok** \ No newline at end of file diff --git a/test_dev/exn3.sml b/test_dev/exn3.sml index 1d0f54e6a..f3f31bb96 100644 --- a/test_dev/exn3.sml +++ b/test_dev/exn3.sml @@ -2,10 +2,10 @@ exception K exception E exception B -fun print (s:string) : unit = prim("printStringML", "printStringML", s) +fun print (s:string) : unit = prim("printStringML", s) val a : string = ("**wrong**"; raise E) handle K => "**also wrong**" | E => "**ok**" | B => "**also also wrong**" -val _ = print a \ No newline at end of file +val _ = print a diff --git a/test_dev/exn4.out.ok b/test_dev/exn4.out.ok new file mode 100644 index 000000000..09c0d5ed9 --- /dev/null +++ b/test_dev/exn4.out.ok @@ -0,0 +1,6 @@ +Div +Match +Bind +Overflow +ThisIsAnException +***Success*** diff --git a/test_dev/exn4.sml b/test_dev/exn4.sml index 17a9b5eec..f2fe9bc88 100644 --- a/test_dev/exn4.sml +++ b/test_dev/exn4.sml @@ -1,6 +1,6 @@ -fun print (s:string) : unit = prim("printStringML", "printStringML", s) -fun exnName (e: exn) : string = prim("exnNameML", "exnNameProfilingML", e) (* exomorphic by copying *) +fun print (s:string) : unit = prim("printStringML", s) +fun exnName (e: exn) : string = prim("exnNameML", e) (* exomorphic by copying *) exception ThisIsAnException infix :: @@ -11,7 +11,7 @@ fun pr_exn e = (print(exnName e); print "\n") val _ = app pr_exn [Div,Match,Bind,Overflow,ThisIsAnException] -val _ = (raise Bind) - handle Match => print "***Error***\n" | Bind => print "***Success***\n" +val _ = (raise Bind) + handle Match => print "***Error***\n" | Bind => print "***Success***\n" -val _ = raise Div \ No newline at end of file +val _ = raise Div diff --git a/test_dev/f1.out.ok b/test_dev/f1.out.ok new file mode 100644 index 000000000..7c0b7d260 --- /dev/null +++ b/test_dev/f1.out.ok @@ -0,0 +1,11 @@ +Num: 10 +Num: 9 +Num: 8 +Num: 7 +Num: 6 +Num: 5 +Num: 4 +Num: 3 +Num: 2 +Num: 1 +Num: 42 diff --git a/test_dev/f1.sml b/test_dev/f1.sml index 3a07979c4..d5f55bbff 100644 --- a/test_dev/f1.sml +++ b/test_dev/f1.sml @@ -1,10 +1,10 @@ let infix - infix 3 := o - fun !(x: 'a ref): 'a = prim ("!", "!", x) - fun print (s:string) : unit = prim("printStringML", "printStringML", s) + fun !(x: 'a ref): 'a = prim ("!", x) + fun print (s:string) : unit = prim("printStringML", s) - fun printNum (i:int) : unit = prim("printNum", "printNum", i) + fun printNum (i:int) : unit = prim("printNum", i) val r = ref 42 val free = !r fun f 0 = printNum free diff --git a/test_dev/f2.out.ok b/test_dev/f2.out.ok new file mode 100644 index 000000000..0b9e1a3f5 --- /dev/null +++ b/test_dev/f2.out.ok @@ -0,0 +1,3 @@ +Num: -1 +Num: 0 +Num: 1 diff --git a/test_dev/f2.sml b/test_dev/f2.sml index 2347fe426..39b3d6e36 100644 --- a/test_dev/f2.sml +++ b/test_dev/f2.sml @@ -2,10 +2,10 @@ let infix - infix 3 := o infixr 5 :: @ - fun !(x: 'a ref): 'a = prim ("!", "!", x) - fun print (s:string) : unit = prim("printStringML", "printStringML", s) + fun !(x: 'a ref): 'a = prim ("!", x) + fun print (s:string) : unit = prim("printStringML", s) - fun printNum (i:int) : unit = prim("printNum", "printNum", i) + fun printNum (i:int) : unit = prim("printNum", i) fun app f [] = () | app f (x::xs) = (f x; app f xs) diff --git a/test_dev/fft_no_basislib.out.ok b/test_dev/fft_no_basislib.out.ok new file mode 100644 index 000000000..6e35fd58e --- /dev/null +++ b/test_dev/fft_no_basislib.out.ok @@ -0,0 +1,4 @@ +Fft'ing... +Num: 65536.00 +Num: -25785591.33 +Done diff --git a/test_dev/fft_no_basislib.sml b/test_dev/fft_no_basislib.sml index cf516c93c..d6da232b8 100644 --- a/test_dev/fft_no_basislib.sml +++ b/test_dev/fft_no_basislib.sml @@ -1,6 +1,4 @@ -(*fft.sml*) - -(*by Torben Mogensen (torbenm@diku.dk)*) +(* fft by Torben Mogensen (torbenm@diku.dk) *) infix 7 * / div mod infix 6 + - ^ @@ -9,41 +7,41 @@ infix 4 = <> > >= < <= infix 3 := o infix 0 before - fun !(x: 'a ref): 'a = prim ("!", "!", x) - fun (x: 'a ref) := (y: 'a): unit = prim (":=", ":=", (x, y)) +fun !(x: 'a ref): 'a = prim ("!", x) +fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) - fun not true = false - | not false = true +fun not true = false + | not false = true - fun a <> b = not (a = b) +fun a <> b = not (a = b) - fun print (s:string) : unit = prim("printStringML", "printStringML", s) - fun printReal (r:real) : unit = prim("printReal", "printReal", r) - fun real (x : int) : real = prim ("realInt", "realInt", x) - fun floor (x : real) : int = prim ("floorFloat", "floorFloat", x) (* may raise Overflow *) - fun ceil (x : real) : int = prim ("ceilFloat", "ceilFloat", x) (* may raise Overflow *) - fun trunc (x : real) : int = prim ("truncFloat", "truncFloat", x) (* may raise Overflow *) +fun print (s:string) : unit = prim("printStringML", s) +fun printReal (r:real) : unit = prim("printReal", r) +fun real (x : int) : real = prim("realInt", x) +fun floor (x : real) : int = prim("floorFloat", x) (* may raise Overflow *) +fun ceil (x : real) : int = prim("ceilFloat", x) (* may raise Overflow *) +fun trunc (x : real) : int = prim("truncFloat", x) (* may raise Overflow *) - val op mod : (int * int) -> int = op mod -fun (a:real) / (b:real) : real = prim ("divFloat", "divFloat", (a,b)) -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun concat (ss : string list) : string = prim ("implodeStringML", "implodeStringProfilingML", ss) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) +val op mod : (int * int) -> int = op mod +fun (a:real) / (b:real) : real = prim("divFloat", (a,b)) +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) fun str (c : char) : string = implode [c] -fun size (s:string): int = prim ("sizeStringML", "sizeStringML", s) +fun size (s : string) : int = prim ("__bytetable_size", s) - local - fun append [] ys = ys - | append (x::xs) ys = x :: append xs ys - in - fun xs @ ys = append xs ys - end +local + fun append [] ys = ys + | append (x::xs) ys = x :: append xs ys +in +fun xs @ ys = append xs ys +end val pi = 3.14159265358979 -fun pr (s : string) : unit = print(s) +fun pr (s : string) : unit = print s exception Impossible fun impossible s = impossible0 (s ^ "\n") and impossible0 s = (pr ("\nimpossible: " ^ s); raise Impossible) @@ -70,43 +68,51 @@ fun odds [] = [] | odds (x::y::l) = y :: odds l | odds _ = impossible "odds" - fun cos (r : real) : real = prim ("cosFloat", "cosFloat", r) - fun sin (r : real) : real = prim ("sinFloat", "sinFloat", r) +fun cos (r : real) : real = prim ("cosFloat", r) +fun sin (r : real) : real = prim ("sinFloat", r) fun fmul (c,pin,[]) = [] | fmul (c,pin,(a::b)) - = ~*((cos(c),sin(c)), a) :: fmul (c+pin,pin,b) + = ~*((cos(c),sin(c)), a) :: fmul (c+pin,pin,b) fun cp [] = [] | cp (a::b) = a :: cp b fun fft ([(a,b)], 1) = [(a+0.0,b+0.0)] | fft (x, n2) - = let val n = n2 div 2 - val a = fft (evens x, n) - val cb = fmul (0.0,pi/(real n),fft (odds x, n)) - in + = let val n = n2 div 2 + val a = fft (evens x, n) + val cb = fmul (0.0,pi/(real n),fft (odds x, n)) + in let val l1 = zipWith ~+ (a,cb) val l2 = zipWith ~- (a,cb) in resetRegions a; resetRegions cb; l1 @ l2 end - end + end local val a = 16807.0 and m = 2147483678.0 in - fun nextrand seed = - let val t = a*seed - in t - m * real(floor (t/m)) end +fun nextrand seed = + let val t = a*seed + in t - m * real(floor (t/m)) end end - fun mkList(tr as (seed,0,acc)) = tr | mkList(seed,n,acc) = mkList(nextrand seed, n-1, seed::acc) val n = 256 * 256 -fun run () = (pr "\nfft by Torben Mogensen (torbenm@diku.dk)\n\nfft'ing... "; +fun len ([],acc) = acc + | len (_ :: xs, acc) = len (xs,acc+1) + +fun sumdiff ([],acc) = acc + | sumdiff ((x:real,y) :: xs, acc) = sumdiff (xs,acc+(x-y)/1000000.0) + +fun run () = (pr "Fft'ing...\n"; let val r = fft (zip (#3(mkList(7.0,n,[])), - #3(mkList(8.0,n,[]))), n) in - pr " done\n" end); + #3(mkList(8.0,n,[]))), n) + in printReal (real (len (r,0))) + ; printReal (sumdiff (r,0.0)) + ; pr "Done\n" + end); -run () +val () = run () diff --git a/test_dev/fib.out.ok b/test_dev/fib.out.ok new file mode 100644 index 000000000..d052be956 --- /dev/null +++ b/test_dev/fib.out.ok @@ -0,0 +1,357 @@ +Before fib +In FIB +Num: 10 +In FIB +Num: 8 +In FIB +Num: 6 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 5 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 7 +In FIB +Num: 5 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 6 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 5 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 9 +In FIB +Num: 7 +In FIB +Num: 5 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 6 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 5 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 8 +In FIB +Num: 6 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 5 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 7 +In FIB +Num: 5 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 6 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 5 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 4 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +In FIB +Num: 3 +In FIB +Num: 1 +In FIB +Num: 2 +In FIB +Num: 0 +In FIB +Num: 1 +Num: 89 +After fib diff --git a/test_dev/fib.sml b/test_dev/fib.sml index ce57c70f5..915742987 100644 --- a/test_dev/fib.sml +++ b/test_dev/fib.sml @@ -5,23 +5,23 @@ infix > local - fun neq(x,y) = if xy then false else true - fun eq(x,y) = prim ("__equal_int","__equal_int",(x,y)) - fun printNum (i:int) : unit = prim("printNum", "printNum", i) + fun print (s:string) : unit = prim("printStringML", s) + fun neq (x,y) = if xy then false else true + fun printNum (i:int) : unit = prim("printNum", i) fun fib x = let -(* val _ = prim ("printString","printString","In FIB\n") - val _ = printNum x *) + val _ = print "In FIB\n" + val _ = printNum x in - if neq(x,0) orelse neq(x,1) then - 1 - else + if neq(x,0) orelse neq(x,1) then + 1 + else fib(x-2) + fib(x-1) end (* fun fib x = if eq(x,0) orelse eq(x,1) then 1 else fib(x-2)+fib(x-1)*) in -(* val _ = prim ("printString","printString","Before fib\n")*) + val _ = print "Before fib\n" val _ = printNum(fib 10) -(* val _ = prim ("printString","printString","After fib\n")*) + val _ = print "After fib\n" end diff --git a/test_dev/fib0.out.ok b/test_dev/fib0.out.ok new file mode 100644 index 000000000..416c179fb --- /dev/null +++ b/test_dev/fib0.out.ok @@ -0,0 +1 @@ +Num: 1346269 diff --git a/test_dev/fib0.sml b/test_dev/fib0.sml index ec582d924..25112a9c6 100644 --- a/test_dev/fib0.sml +++ b/test_dev/fib0.sml @@ -1,9 +1,9 @@ infix - + -fun printNum (i:int) : unit = prim("printNum", "printNum", i) +fun printNum (i:int) : unit = prim("printNum", i) fun fib 0 = 1 | fib 1 = 1 | fib n = fib(n-1) + fib(n-2) -val _ = printNum(fib 30) \ No newline at end of file +val _ = printNum(fib 30) (* 1346269 *) diff --git a/test_dev/foldl.out.ok b/test_dev/foldl.out.ok new file mode 100644 index 000000000..13f6fc2dd --- /dev/null +++ b/test_dev/foldl.out.ok @@ -0,0 +1,5 @@ +Before fold +Efter fold +Num: 55 +Num: 55 +hej diff --git a/test_dev/global_region.out.ok b/test_dev/global_region.out.ok new file mode 100644 index 000000000..e69de29bb diff --git a/test_dev/hanoi.out.ok b/test_dev/hanoi.out.ok new file mode 100644 index 000000000..5df75d84d --- /dev/null +++ b/test_dev/hanoi.out.ok @@ -0,0 +1,3071 @@ +Hello +move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 2 +to Num: 1 + + move Num: 2 +to Num: 3 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + move Num: 3 +to Num: 1 + + move Num: 2 +to Num: 1 + + move Num: 3 +to Num: 2 + + move Num: 1 +to Num: 3 + + move Num: 1 +to Num: 2 + + move Num: 3 +to Num: 2 + + Hello again diff --git a/test_dev/hanoi.sml b/test_dev/hanoi.sml index 957975956..f3e5beffa 100644 --- a/test_dev/hanoi.sml +++ b/test_dev/hanoi.sml @@ -9,7 +9,7 @@ let fun neq(x,y) = if xy then false else true - fun show_move(i,j) = + fun show_move(i,j) = (out_str "move "; printNum i; out_str "to "; @@ -18,11 +18,11 @@ let fun hanoi(n, from, to, via)= if neq(n,0) then () - else (hanoi(n-1, from, via, to); + else (hanoi(n-1, from, via, to); show_move(from,to); hanoi(n-1, via, to, from)) val _ = out_str "Hello\n" - val _ = hanoi(1000,1,2,3); + val _ = hanoi(10,1,2,3); val _ = out_str "Hello again\n" in () diff --git a/test_dev/hello.out.ok b/test_dev/hello.out.ok new file mode 100644 index 000000000..68300b856 --- /dev/null +++ b/test_dev/hello.out.ok @@ -0,0 +1 @@ +It works! diff --git a/test_dev/hello.sml b/test_dev/hello.sml index 5ca94f0ea..cdefd6a01 100644 --- a/test_dev/hello.sml +++ b/test_dev/hello.sml @@ -1,16 +1,16 @@ let -fun print (s:string) : unit = prim("printStringML", "printStringML", s) +fun print (s:string) : unit = prim("printStringML", s) in print "It works!\n" end (* -infix ^ +infix ^ fun (s : string) ^ (s' : string) : string = prim ("concatString", "concatStringProfiling", (s, s')) -(*fun myfun (x, y, z) = +(*fun myfun (x, y, z) = let val _ = print y - val a1 = z ^ y + val a1 = z ^ y val _ = print a1 in a1 ^ x end*) @@ -20,4 +20,4 @@ fun myfun2 (a,b,c,d,e,f,g) = print (a^b^c^d^e^f^g) (*val s = myfun ("3", "2", "1")*) val s2 = myfun2("1","2","3","4","5","6","7") -*) \ No newline at end of file +*) diff --git a/test_dev/if.out.ok b/test_dev/if.out.ok new file mode 100644 index 000000000..5ef648a88 --- /dev/null +++ b/test_dev/if.out.ok @@ -0,0 +1 @@ +It works! \ No newline at end of file diff --git a/test_dev/if.sml b/test_dev/if.sml index d04de9073..47551eeec 100644 --- a/test_dev/if.sml +++ b/test_dev/if.sml @@ -4,7 +4,7 @@ infix <= infix < infix > infix >= -fun print (s:string) : unit = prim("printStringML", "printStringML", s) +fun print (s:string) : unit = prim("printStringML", s) in if 3<=3 andalso 2<4 andalso 2>1 andalso 4>=4 then print "It works!" diff --git a/test_dev/immedString.out.ok b/test_dev/immedString.out.ok new file mode 100644 index 000000000..0e6b8163d --- /dev/null +++ b/test_dev/immedString.out.ok @@ -0,0 +1 @@ +It works \ No newline at end of file diff --git a/test_dev/immedString.sml b/test_dev/immedString.sml index 3c84e7fe7..eba7009da 100644 --- a/test_dev/immedString.sml +++ b/test_dev/immedString.sml @@ -4,7 +4,7 @@ (* Works only if inline functions are disabled. *) local - fun print (s:string) : unit = prim("printStringML", "printStringML", s) + fun print (s:string) : unit = prim("printStringML", s) fun f () = "It works" val _ = print (f ()) diff --git a/test_dev/int_first.out.ok b/test_dev/int_first.out.ok new file mode 100644 index 000000000..9bf090e44 --- /dev/null +++ b/test_dev/int_first.out.ok @@ -0,0 +1,3 @@ +Hi there +Hello there +Div it is! diff --git a/test_dev/int_first.sml b/test_dev/int_first.sml new file mode 100644 index 000000000..1daf038b2 --- /dev/null +++ b/test_dev/int_first.sml @@ -0,0 +1,24 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun exnName (e: exn) : string = prim("exnNameML", e) (* exomorphic by copying *) + +fun !(x: 'a ref): 'a = prim ("!", x) +fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) +fun not true = false | not false = true +fun a <> b = not (a = b) +fun print (s:string) : unit = prim("printStringML", s) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) + +val () = print "Hi there\n" + +val s = "Hello " ^ "there\n" + +val () = print s + +val () = print (exnName Div ^ " it is!\n") diff --git a/test_dev/int_overflow.out.ok b/test_dev/int_overflow.out.ok new file mode 100644 index 000000000..9b8733726 --- /dev/null +++ b/test_dev/int_overflow.out.ok @@ -0,0 +1,5 @@ +OK (+) +OK (-) +OK (*) +OK (*) +OK (~) diff --git a/test_dev/int_overflow.sml b/test_dev/int_overflow.sml new file mode 100644 index 000000000..3ca30de5f --- /dev/null +++ b/test_dev/int_overflow.sml @@ -0,0 +1,19 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun print (s:string) : unit = prim("printStringML", s) + +val maxInt = 2147483647 : int32 +val minInt = ~2147483648 : int32 + +val () = (maxInt + 1; print "ERR\n") handle Overflow => print "OK (+)\n" +val () = (minInt - 1; print "ERR\n") handle Overflow => print "OK (-)\n" + +val () = (maxInt * 2; print "ERR\n") handle Overflow => print "OK (*)\n" +val () = (minInt * 2; print "ERR\n") handle Overflow => print "OK (*)\n" + +val () = (~ minInt; print "ERR\n") handle Overflow => print "OK (~)\n" diff --git a/test_dev/kitkbjul9_no_basislib.out.ok b/test_dev/kitkbjul9_no_basislib.out.ok new file mode 100644 index 000000000..2f0b461e4 --- /dev/null +++ b/test_dev/kitkbjul9_no_basislib.out.ok @@ -0,0 +1,819 @@ +1 : U*v1 = v1 +2 : I(v1)*v1 = U +3 : (v3*v2)*v1 = v3*(v2*v1) +4 : A*B = B*A +5 : C*C = U +6 : I(A) = C*(A*I(C)) +7 : C*(B*I(C)) = B +8 : I(v2)*(v2*v1) = v1 +9 : A*(B*v1) = B*(A*v1) +10 : C*(C*v1) = v1 +11 : C*(A*(I(C)*A)) = U +12 : C*(B*(I(C)*v1)) = B*v1 +13 : I(U)*v1 = v1 +14 : I(I(v1))*U = v1 +15 : I(v3*v2)*(v3*(v2*v1)) = v1 +16 : C*(A*(I(C)*(B*A))) = B +17 : I(C)*U = C +18 : C*(A*(I(C)*(A*v1))) = v1 +19 : I(C)*B = B*I(C) +20 : I(I(v2))*v1 = v2*v1 +Rule 14 deleted +21 : v1*U = v1 +Rule 17 deleted +22 : I(C) = C +Rule 19 deleted +Rule 18 deleted +Rule 16 deleted +Rule 12 deleted +Rule 11 deleted +Rule 7 deleted +23 : C*B = B*C +24 : C*(A*(C*(A*v1))) = v1 +25 : C*(A*(C*(B*A))) = B +26 : C*(B*(C*v1)) = B*v1 +27 : C*(A*(C*A)) = U +28 : C*(B*C) = B +29 : C*(A*(C*(B*(A*v1)))) = B*v1 +30 : I(I(v2*v1)*v2) = v1 +31 : I(v2*I(v1))*v2 = v1 +32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 +33 : I(v1*A)*(v1*(B*A)) = B +34 : I(v1*C)*v1 = C +35 : I(v3*I(v2))*(v3*v1) = v2*v1 +36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 +37 : I(v2*C)*(v2*v1) = C*v1 +38 : v1*I(v1) = U +39 : I(C*(A*C))*v1 = A*v1 +40 : v2*(I(v2)*v1) = v1 +41 : I(U) = U +Rule 13 deleted +42 : I(I(v1)) = v1 +Rule 20 deleted +43 : C*(B*v1) = B*(C*v1) +Rule 29 deleted +Rule 28 deleted +Rule 26 deleted +Rule 25 deleted +44 : A*(C*(A*v1)) = C*v1 +Rule 24 deleted +45 : A*(C*A) = C +Rule 27 deleted +46 : v2*(I(v1*v2)*v1) = U +47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 +48 : I(I(B*A)*A) = B +49 : v3*(I(v2*v3)*(v2*v1)) = v1 +50 : I(I(v2)*I(v1)) = v1*v2 +51 : I(I(B*(A*v1))*A) = B*v1 +52 : I(I(v1)*C) = C*v1 +53 : I(v2*I(v1*v2)) = v1 +54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 +55 : I(v1*(C*(A*C)))*v1 = A +56 : v2*I(I(v1)*v2) = v1 +57 : I(v3*(I(v2*v1)*v2))*v3 = v1 +58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 +59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B +60 : I(v2*(v1*C))*(v2*v1) = C +61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 +62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 +63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 +64 : I(v4*(I(v3*v2)*v3))*(v4*v1) = v2*v1 +65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 +66 : I(I(B)*A)*A = B +67 : I(A*A)*(B*(A*A)) = B +68 : v1*(I(A*v1)*(B*A)) = B +69 : I(I(v1*A)*(v1*B))*B = A +70 : v1*I(C*v1) = C +71 : I(A*I(v1))*(B*A) = v1*B +72 : I(C*I(v1)) = v1*C +73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 +74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) +75 : v3*(I(I(v2)*v3)*v1) = v2*v1 +76 : I(I(B*I(v1))*A)*(v1*A) = B +77 : I(v1*A)*(v1*(B*(B*A))) = B*B +78 : I(I(B)*A)*(A*v1) = B*v1 +79 : I(A*A)*(B*(A*(A*v1))) = B*v1 +80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) +81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 +82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 +83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 +84 : I(A*C)*(B*A) = B*C +85 : I(A*C)*(B*(A*v1)) = B*(C*v1) +86 : v2*(I(C*v2)*v1) = C*v1 +87 : I(I(B*C)*A)*(C*A) = B +88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 +89 : v2*(v1*I(v2*v1)) = U +90 : B*(A*I(B)) = A +91 : I(v2*v1)*v2 = I(v1) +Rule 64 deleted +Rule 57 deleted +Rule 55 deleted +Rule 46 deleted +Rule 34 deleted +Rule 31 deleted +Rule 30 deleted +92 : I(C*(A*C)) = A +Rule 39 deleted +93 : I(v3*(v2*v1))*(v3*v2) = I(v1) +Rule 60 deleted +Rule 54 deleted +Rule 47 deleted +94 : I(v2*I(v1)) = v1*I(v2) +Rule 83 deleted +Rule 76 deleted +Rule 74 deleted +Rule 72 deleted +Rule 71 deleted +Rule 53 deleted +Rule 50 deleted +Rule 35 deleted +95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 +96 : I(v1*(I(B)*A))*(v1*A) = B +97 : I(v1*A)*(v1*B) = B*(C*(A*C)) +Rule 82 deleted +Rule 69 deleted +98 : I(v1*C) = C*I(v1) +Rule 88 deleted +Rule 87 deleted +Rule 85 deleted +Rule 84 deleted +Rule 52 deleted +Rule 37 deleted +99 : v3*(v2*(I(v3*v2)*v1)) = v1 +100 : B*(A*(I(B)*v1)) = A*v1 +101 : I(v3*v2)*(v3*v1) = I(v2)*v1 +Rule 97 deleted +Rule 96 deleted +Rule 95 deleted +Rule 93 deleted +Rule 80 deleted +Rule 77 deleted +Rule 73 deleted +Rule 65 deleted +Rule 63 deleted +Rule 62 deleted +Rule 61 deleted +Rule 59 deleted +Rule 58 deleted +Rule 49 deleted +Rule 36 deleted +Rule 33 deleted +Rule 32 deleted +Rule 15 deleted +102 : B*(C*I(B)) = C +103 : B*(C*(I(B)*v1)) = C*v1 +104 : B*(I(B*A)*A) = U +105 : B*(I(B*A)*(A*v1)) = v1 +106 : I(B*A)*A = I(B) +Rule 104 deleted +Rule 48 deleted +107 : B*(v1*(I(B*(A*v1))*A)) = U +108 : I(I(B*(B*A))*A) = B*B +109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 +110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) +111 : I(I(B)*A) = B*(C*(A*C)) +Rule 78 deleted +Rule 66 deleted +112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) +Rule 110 deleted +Rule 108 deleted +Rule 51 deleted +113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 +114 : v1*I(C*(A*(C*v1))) = A +115 : I(I(v2)*v1) = I(v1)*v2 +Rule 113 deleted +Rule 112 deleted +Rule 111 deleted +Rule 75 deleted +Rule 56 deleted +116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B +117 : I(A*v1)*(B*A) = I(v1)*B +Rule 116 deleted +Rule 68 deleted +118 : v2*(v1*I(C*(v2*v1))) = C +119 : I(C*v1) = I(v1)*C +Rule 118 deleted +Rule 114 deleted +Rule 92 deleted +Rule 86 deleted +Rule 70 deleted +120 : v1*(I(A*(C*v1))*C) = A +121 : I(A*A)*(B*(B*(A*A))) = B*B +122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) +123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) +Rule 79 deleted +Rule 67 deleted +124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 +125 : v1*(I(A*v1)*(B*(B*A))) = B*B +126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) +Rule 124 deleted +Rule 123 deleted +Rule 81 deleted +127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U +128 : v2*I(v1*v2) = I(v1) +Rule 89 deleted +129 : A*I(B) = I(B)*A +Rule 90 deleted +130 : I(v2*v1) = I(v1)*I(v2) +Rule 128 deleted +Rule 127 deleted +Rule 126 deleted +Rule 125 deleted +Rule 122 deleted +Rule 121 deleted +Rule 120 deleted +Rule 119 deleted +Rule 117 deleted +Rule 115 deleted +Rule 109 deleted +Rule 107 deleted +Rule 106 deleted +Rule 105 deleted +Rule 101 deleted +Rule 99 deleted +Rule 98 deleted +Rule 94 deleted +Rule 91 deleted +131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 +132 : B*(C*(A*(C*(I(B)*A)))) = U +133 : C*(A*(C*(I(B)*A))) = I(B) +Rule 132 deleted +134 : A*(I(B)*v1) = I(B)*(A*v1) +Rule 100 deleted +135 : C*I(B) = I(B)*C +Rule 102 deleted +136 : C*(I(B)*v1) = I(B)*(C*v1) +Rule 133 deleted +Rule 131 deleted +Rule 103 deleted +Canonical set found : +1 : U*v1 = v1 +2 : I(v1)*v1 = U +3 : (v3*v2)*v1 = v3*(v2*v1) +4 : A*B = B*A +5 : C*C = U +6 : I(A) = C*(A*C) +8 : I(v2)*(v2*v1) = v1 +9 : A*(B*v1) = B*(A*v1) +10 : C*(C*v1) = v1 +21 : v1*U = v1 +22 : I(C) = C +23 : C*B = B*C +38 : v1*I(v1) = U +40 : v2*(I(v2)*v1) = v1 +41 : I(U) = U +42 : I(I(v1)) = v1 +43 : C*(B*v1) = B*(C*v1) +44 : A*(C*(A*v1)) = C*v1 +45 : A*(C*A) = C +129 : A*I(B) = I(B)*A +130 : I(v2*v1) = I(v1)*I(v2) +134 : A*(I(B)*v1) = I(B)*(A*v1) +135 : C*I(B) = I(B)*C +136 : C*(I(B)*v1) = I(B)*(C*v1) +1 : U*v1 = v1 +2 : I(v1)*v1 = U +3 : (v3*v2)*v1 = v3*(v2*v1) +4 : A*B = B*A +5 : C*C = U +6 : I(A) = C*(A*I(C)) +7 : C*(B*I(C)) = B +8 : I(v2)*(v2*v1) = v1 +9 : A*(B*v1) = B*(A*v1) +10 : C*(C*v1) = v1 +11 : C*(A*(I(C)*A)) = U +12 : C*(B*(I(C)*v1)) = B*v1 +13 : I(U)*v1 = v1 +14 : I(I(v1))*U = v1 +15 : I(v3*v2)*(v3*(v2*v1)) = v1 +16 : C*(A*(I(C)*(B*A))) = B +17 : I(C)*U = C +18 : C*(A*(I(C)*(A*v1))) = v1 +19 : I(C)*B = B*I(C) +20 : I(I(v2))*v1 = v2*v1 +Rule 14 deleted +21 : v1*U = v1 +Rule 17 deleted +22 : I(C) = C +Rule 19 deleted +Rule 18 deleted +Rule 16 deleted +Rule 12 deleted +Rule 11 deleted +Rule 7 deleted +23 : C*B = B*C +24 : C*(A*(C*(A*v1))) = v1 +25 : C*(A*(C*(B*A))) = B +26 : C*(B*(C*v1)) = B*v1 +27 : C*(A*(C*A)) = U +28 : C*(B*C) = B +29 : C*(A*(C*(B*(A*v1)))) = B*v1 +30 : I(I(v2*v1)*v2) = v1 +31 : I(v2*I(v1))*v2 = v1 +32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 +33 : I(v1*A)*(v1*(B*A)) = B +34 : I(v1*C)*v1 = C +35 : I(v3*I(v2))*(v3*v1) = v2*v1 +36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 +37 : I(v2*C)*(v2*v1) = C*v1 +38 : v1*I(v1) = U +39 : I(C*(A*C))*v1 = A*v1 +40 : v2*(I(v2)*v1) = v1 +41 : I(U) = U +Rule 13 deleted +42 : I(I(v1)) = v1 +Rule 20 deleted +43 : C*(B*v1) = B*(C*v1) +Rule 29 deleted +Rule 28 deleted +Rule 26 deleted +Rule 25 deleted +44 : A*(C*(A*v1)) = C*v1 +Rule 24 deleted +45 : A*(C*A) = C +Rule 27 deleted +46 : v2*(I(v1*v2)*v1) = U +47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 +48 : I(I(B*A)*A) = B +49 : v3*(I(v2*v3)*(v2*v1)) = v1 +50 : I(I(v2)*I(v1)) = v1*v2 +51 : I(I(B*(A*v1))*A) = B*v1 +52 : I(I(v1)*C) = C*v1 +53 : I(v2*I(v1*v2)) = v1 +54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 +55 : I(v1*(C*(A*C)))*v1 = A +56 : v2*I(I(v1)*v2) = v1 +57 : I(v3*(I(v2*v1)*v2))*v3 = v1 +58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 +59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B +60 : I(v2*(v1*C))*(v2*v1) = C +61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 +62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 +63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 +64 : I(v4*(I(v3*v2)*v3))*(v4*v1) = v2*v1 +65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 +66 : I(I(B)*A)*A = B +67 : I(A*A)*(B*(A*A)) = B +68 : v1*(I(A*v1)*(B*A)) = B +69 : I(I(v1*A)*(v1*B))*B = A +70 : v1*I(C*v1) = C +71 : I(A*I(v1))*(B*A) = v1*B +72 : I(C*I(v1)) = v1*C +73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 +74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) +75 : v3*(I(I(v2)*v3)*v1) = v2*v1 +76 : I(I(B*I(v1))*A)*(v1*A) = B +77 : I(v1*A)*(v1*(B*(B*A))) = B*B +78 : I(I(B)*A)*(A*v1) = B*v1 +79 : I(A*A)*(B*(A*(A*v1))) = B*v1 +80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) +81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 +82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 +83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 +84 : I(A*C)*(B*A) = B*C +85 : I(A*C)*(B*(A*v1)) = B*(C*v1) +86 : v2*(I(C*v2)*v1) = C*v1 +87 : I(I(B*C)*A)*(C*A) = B +88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 +89 : v2*(v1*I(v2*v1)) = U +90 : B*(A*I(B)) = A +91 : I(v2*v1)*v2 = I(v1) +Rule 64 deleted +Rule 57 deleted +Rule 55 deleted +Rule 46 deleted +Rule 34 deleted +Rule 31 deleted +Rule 30 deleted +92 : I(C*(A*C)) = A +Rule 39 deleted +93 : I(v3*(v2*v1))*(v3*v2) = I(v1) +Rule 60 deleted +Rule 54 deleted +Rule 47 deleted +94 : I(v2*I(v1)) = v1*I(v2) +Rule 83 deleted +Rule 76 deleted +Rule 74 deleted +Rule 72 deleted +Rule 71 deleted +Rule 53 deleted +Rule 50 deleted +Rule 35 deleted +95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 +96 : I(v1*(I(B)*A))*(v1*A) = B +97 : I(v1*A)*(v1*B) = B*(C*(A*C)) +Rule 82 deleted +Rule 69 deleted +98 : I(v1*C) = C*I(v1) +Rule 88 deleted +Rule 87 deleted +Rule 85 deleted +Rule 84 deleted +Rule 52 deleted +Rule 37 deleted +99 : v3*(v2*(I(v3*v2)*v1)) = v1 +100 : B*(A*(I(B)*v1)) = A*v1 +101 : I(v3*v2)*(v3*v1) = I(v2)*v1 +Rule 97 deleted +Rule 96 deleted +Rule 95 deleted +Rule 93 deleted +Rule 80 deleted +Rule 77 deleted +Rule 73 deleted +Rule 65 deleted +Rule 63 deleted +Rule 62 deleted +Rule 61 deleted +Rule 59 deleted +Rule 58 deleted +Rule 49 deleted +Rule 36 deleted +Rule 33 deleted +Rule 32 deleted +Rule 15 deleted +102 : B*(C*I(B)) = C +103 : B*(C*(I(B)*v1)) = C*v1 +104 : B*(I(B*A)*A) = U +105 : B*(I(B*A)*(A*v1)) = v1 +106 : I(B*A)*A = I(B) +Rule 104 deleted +Rule 48 deleted +107 : B*(v1*(I(B*(A*v1))*A)) = U +108 : I(I(B*(B*A))*A) = B*B +109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 +110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) +111 : I(I(B)*A) = B*(C*(A*C)) +Rule 78 deleted +Rule 66 deleted +112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) +Rule 110 deleted +Rule 108 deleted +Rule 51 deleted +113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 +114 : v1*I(C*(A*(C*v1))) = A +115 : I(I(v2)*v1) = I(v1)*v2 +Rule 113 deleted +Rule 112 deleted +Rule 111 deleted +Rule 75 deleted +Rule 56 deleted +116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B +117 : I(A*v1)*(B*A) = I(v1)*B +Rule 116 deleted +Rule 68 deleted +118 : v2*(v1*I(C*(v2*v1))) = C +119 : I(C*v1) = I(v1)*C +Rule 118 deleted +Rule 114 deleted +Rule 92 deleted +Rule 86 deleted +Rule 70 deleted +120 : v1*(I(A*(C*v1))*C) = A +121 : I(A*A)*(B*(B*(A*A))) = B*B +122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) +123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) +Rule 79 deleted +Rule 67 deleted +124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 +125 : v1*(I(A*v1)*(B*(B*A))) = B*B +126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) +Rule 124 deleted +Rule 123 deleted +Rule 81 deleted +127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U +128 : v2*I(v1*v2) = I(v1) +Rule 89 deleted +129 : A*I(B) = I(B)*A +Rule 90 deleted +130 : I(v2*v1) = I(v1)*I(v2) +Rule 128 deleted +Rule 127 deleted +Rule 126 deleted +Rule 125 deleted +Rule 122 deleted +Rule 121 deleted +Rule 120 deleted +Rule 119 deleted +Rule 117 deleted +Rule 115 deleted +Rule 109 deleted +Rule 107 deleted +Rule 106 deleted +Rule 105 deleted +Rule 101 deleted +Rule 99 deleted +Rule 98 deleted +Rule 94 deleted +Rule 91 deleted +131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 +132 : B*(C*(A*(C*(I(B)*A)))) = U +133 : C*(A*(C*(I(B)*A))) = I(B) +Rule 132 deleted +134 : A*(I(B)*v1) = I(B)*(A*v1) +Rule 100 deleted +135 : C*I(B) = I(B)*C +Rule 102 deleted +136 : C*(I(B)*v1) = I(B)*(C*v1) +Rule 133 deleted +Rule 131 deleted +Rule 103 deleted +Canonical set found : +1 : U*v1 = v1 +2 : I(v1)*v1 = U +3 : (v3*v2)*v1 = v3*(v2*v1) +4 : A*B = B*A +5 : C*C = U +6 : I(A) = C*(A*C) +8 : I(v2)*(v2*v1) = v1 +9 : A*(B*v1) = B*(A*v1) +10 : C*(C*v1) = v1 +21 : v1*U = v1 +22 : I(C) = C +23 : C*B = B*C +38 : v1*I(v1) = U +40 : v2*(I(v2)*v1) = v1 +41 : I(U) = U +42 : I(I(v1)) = v1 +43 : C*(B*v1) = B*(C*v1) +44 : A*(C*(A*v1)) = C*v1 +45 : A*(C*A) = C +129 : A*I(B) = I(B)*A +130 : I(v2*v1) = I(v1)*I(v2) +134 : A*(I(B)*v1) = I(B)*(A*v1) +135 : C*I(B) = I(B)*C +136 : C*(I(B)*v1) = I(B)*(C*v1) +1 : U*v1 = v1 +2 : I(v1)*v1 = U +3 : (v3*v2)*v1 = v3*(v2*v1) +4 : A*B = B*A +5 : C*C = U +6 : I(A) = C*(A*I(C)) +7 : C*(B*I(C)) = B +8 : I(v2)*(v2*v1) = v1 +9 : A*(B*v1) = B*(A*v1) +10 : C*(C*v1) = v1 +11 : C*(A*(I(C)*A)) = U +12 : C*(B*(I(C)*v1)) = B*v1 +13 : I(U)*v1 = v1 +14 : I(I(v1))*U = v1 +15 : I(v3*v2)*(v3*(v2*v1)) = v1 +16 : C*(A*(I(C)*(B*A))) = B +17 : I(C)*U = C +18 : C*(A*(I(C)*(A*v1))) = v1 +19 : I(C)*B = B*I(C) +20 : I(I(v2))*v1 = v2*v1 +Rule 14 deleted +21 : v1*U = v1 +Rule 17 deleted +22 : I(C) = C +Rule 19 deleted +Rule 18 deleted +Rule 16 deleted +Rule 12 deleted +Rule 11 deleted +Rule 7 deleted +23 : C*B = B*C +24 : C*(A*(C*(A*v1))) = v1 +25 : C*(A*(C*(B*A))) = B +26 : C*(B*(C*v1)) = B*v1 +27 : C*(A*(C*A)) = U +28 : C*(B*C) = B +29 : C*(A*(C*(B*(A*v1)))) = B*v1 +30 : I(I(v2*v1)*v2) = v1 +31 : I(v2*I(v1))*v2 = v1 +32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 +33 : I(v1*A)*(v1*(B*A)) = B +34 : I(v1*C)*v1 = C +35 : I(v3*I(v2))*(v3*v1) = v2*v1 +36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 +37 : I(v2*C)*(v2*v1) = C*v1 +38 : v1*I(v1) = U +39 : I(C*(A*C))*v1 = A*v1 +40 : v2*(I(v2)*v1) = v1 +41 : I(U) = U +Rule 13 deleted +42 : I(I(v1)) = v1 +Rule 20 deleted +43 : C*(B*v1) = B*(C*v1) +Rule 29 deleted +Rule 28 deleted +Rule 26 deleted +Rule 25 deleted +44 : A*(C*(A*v1)) = C*v1 +Rule 24 deleted +45 : A*(C*A) = C +Rule 27 deleted +46 : v2*(I(v1*v2)*v1) = U +47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 +48 : I(I(B*A)*A) = B +49 : v3*(I(v2*v3)*(v2*v1)) = v1 +50 : I(I(v2)*I(v1)) = v1*v2 +51 : I(I(B*(A*v1))*A) = B*v1 +52 : I(I(v1)*C) = C*v1 +53 : I(v2*I(v1*v2)) = v1 +54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 +55 : I(v1*(C*(A*C)))*v1 = A +56 : v2*I(I(v1)*v2) = v1 +57 : I(v3*(I(v2*v1)*v2))*v3 = v1 +58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 +59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B +60 : I(v2*(v1*C))*(v2*v1) = C +61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 +62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 +63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 +64 : I(v4*(I(v3*v2)*v3))*(v4*v1) = v2*v1 +65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 +66 : I(I(B)*A)*A = B +67 : I(A*A)*(B*(A*A)) = B +68 : v1*(I(A*v1)*(B*A)) = B +69 : I(I(v1*A)*(v1*B))*B = A +70 : v1*I(C*v1) = C +71 : I(A*I(v1))*(B*A) = v1*B +72 : I(C*I(v1)) = v1*C +73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 +74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) +75 : v3*(I(I(v2)*v3)*v1) = v2*v1 +76 : I(I(B*I(v1))*A)*(v1*A) = B +77 : I(v1*A)*(v1*(B*(B*A))) = B*B +78 : I(I(B)*A)*(A*v1) = B*v1 +79 : I(A*A)*(B*(A*(A*v1))) = B*v1 +80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) +81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 +82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 +83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 +84 : I(A*C)*(B*A) = B*C +85 : I(A*C)*(B*(A*v1)) = B*(C*v1) +86 : v2*(I(C*v2)*v1) = C*v1 +87 : I(I(B*C)*A)*(C*A) = B +88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 +89 : v2*(v1*I(v2*v1)) = U +90 : B*(A*I(B)) = A +91 : I(v2*v1)*v2 = I(v1) +Rule 64 deleted +Rule 57 deleted +Rule 55 deleted +Rule 46 deleted +Rule 34 deleted +Rule 31 deleted +Rule 30 deleted +92 : I(C*(A*C)) = A +Rule 39 deleted +93 : I(v3*(v2*v1))*(v3*v2) = I(v1) +Rule 60 deleted +Rule 54 deleted +Rule 47 deleted +94 : I(v2*I(v1)) = v1*I(v2) +Rule 83 deleted +Rule 76 deleted +Rule 74 deleted +Rule 72 deleted +Rule 71 deleted +Rule 53 deleted +Rule 50 deleted +Rule 35 deleted +95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 +96 : I(v1*(I(B)*A))*(v1*A) = B +97 : I(v1*A)*(v1*B) = B*(C*(A*C)) +Rule 82 deleted +Rule 69 deleted +98 : I(v1*C) = C*I(v1) +Rule 88 deleted +Rule 87 deleted +Rule 85 deleted +Rule 84 deleted +Rule 52 deleted +Rule 37 deleted +99 : v3*(v2*(I(v3*v2)*v1)) = v1 +100 : B*(A*(I(B)*v1)) = A*v1 +101 : I(v3*v2)*(v3*v1) = I(v2)*v1 +Rule 97 deleted +Rule 96 deleted +Rule 95 deleted +Rule 93 deleted +Rule 80 deleted +Rule 77 deleted +Rule 73 deleted +Rule 65 deleted +Rule 63 deleted +Rule 62 deleted +Rule 61 deleted +Rule 59 deleted +Rule 58 deleted +Rule 49 deleted +Rule 36 deleted +Rule 33 deleted +Rule 32 deleted +Rule 15 deleted +102 : B*(C*I(B)) = C +103 : B*(C*(I(B)*v1)) = C*v1 +104 : B*(I(B*A)*A) = U +105 : B*(I(B*A)*(A*v1)) = v1 +106 : I(B*A)*A = I(B) +Rule 104 deleted +Rule 48 deleted +107 : B*(v1*(I(B*(A*v1))*A)) = U +108 : I(I(B*(B*A))*A) = B*B +109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 +110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) +111 : I(I(B)*A) = B*(C*(A*C)) +Rule 78 deleted +Rule 66 deleted +112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) +Rule 110 deleted +Rule 108 deleted +Rule 51 deleted +113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 +114 : v1*I(C*(A*(C*v1))) = A +115 : I(I(v2)*v1) = I(v1)*v2 +Rule 113 deleted +Rule 112 deleted +Rule 111 deleted +Rule 75 deleted +Rule 56 deleted +116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B +117 : I(A*v1)*(B*A) = I(v1)*B +Rule 116 deleted +Rule 68 deleted +118 : v2*(v1*I(C*(v2*v1))) = C +119 : I(C*v1) = I(v1)*C +Rule 118 deleted +Rule 114 deleted +Rule 92 deleted +Rule 86 deleted +Rule 70 deleted +120 : v1*(I(A*(C*v1))*C) = A +121 : I(A*A)*(B*(B*(A*A))) = B*B +122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) +123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) +Rule 79 deleted +Rule 67 deleted +124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 +125 : v1*(I(A*v1)*(B*(B*A))) = B*B +126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) +Rule 124 deleted +Rule 123 deleted +Rule 81 deleted +127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U +128 : v2*I(v1*v2) = I(v1) +Rule 89 deleted +129 : A*I(B) = I(B)*A +Rule 90 deleted +130 : I(v2*v1) = I(v1)*I(v2) +Rule 128 deleted +Rule 127 deleted +Rule 126 deleted +Rule 125 deleted +Rule 122 deleted +Rule 121 deleted +Rule 120 deleted +Rule 119 deleted +Rule 117 deleted +Rule 115 deleted +Rule 109 deleted +Rule 107 deleted +Rule 106 deleted +Rule 105 deleted +Rule 101 deleted +Rule 99 deleted +Rule 98 deleted +Rule 94 deleted +Rule 91 deleted +131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 +132 : B*(C*(A*(C*(I(B)*A)))) = U +133 : C*(A*(C*(I(B)*A))) = I(B) +Rule 132 deleted +134 : A*(I(B)*v1) = I(B)*(A*v1) +Rule 100 deleted +135 : C*I(B) = I(B)*C +Rule 102 deleted +136 : C*(I(B)*v1) = I(B)*(C*v1) +Rule 133 deleted +Rule 131 deleted +Rule 103 deleted +Canonical set found : +1 : U*v1 = v1 +2 : I(v1)*v1 = U +3 : (v3*v2)*v1 = v3*(v2*v1) +4 : A*B = B*A +5 : C*C = U +6 : I(A) = C*(A*C) +8 : I(v2)*(v2*v1) = v1 +9 : A*(B*v1) = B*(A*v1) +10 : C*(C*v1) = v1 +21 : v1*U = v1 +22 : I(C) = C +23 : C*B = B*C +38 : v1*I(v1) = U +40 : v2*(I(v2)*v1) = v1 +41 : I(U) = U +42 : I(I(v1)) = v1 +43 : C*(B*v1) = B*(C*v1) +44 : A*(C*(A*v1)) = C*v1 +45 : A*(C*A) = C +129 : A*I(B) = I(B)*A +130 : I(v2*v1) = I(v1)*I(v2) +134 : A*(I(B)*v1) = I(B)*(A*v1) +135 : C*I(B) = I(B)*C +136 : C*(I(B)*v1) = I(B)*(C*v1) diff --git a/test_dev/kitkbjul9_no_basislib.sml b/test_dev/kitkbjul9_no_basislib.sml index 4538b15bc..f87d3030e 100644 --- a/test_dev/kitkbjul9_no_basislib.sml +++ b/test_dev/kitkbjul9_no_basislib.sml @@ -1,8 +1,8 @@ (*kitkbjul9.sml*) (* kitknuth-bendixnewcopy.sml - - This is a revised version of knuth-bendix.sml in which + + This is a revised version of knuth-bendix.sml in which (a) val has been converted to fun for function values (b) exceptions that carry values have been avoided (c) functions have been moved around to pass fewer of them @@ -32,29 +32,29 @@ infix 0 before exception Domain exception Div = Div exception Chr - exception Fail of string + exception Fail of string -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun concat (ss : string list) : string = prim ("implodeStringML", "implodeStringProfilingML", ss) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) fun str (c : char) : string = implode [c] -fun size (s:string): int = prim ("sizeStringML", "sizeStringML", s) -fun chr (i : int) : char = prim ("chrCharML", "chrCharML", (i, Chr)) -fun ord (c : char) : int = prim ("id", "id", c) -fun print (x:string):unit = prim("printStringML","printStringML",x) - fun append [] ys = ys - | append (x::xs) ys = x :: append xs ys - fun xs @ ys = append xs ys +fun size (s : string) : int = prim ("__bytetable_size", s) +fun chr (i : int) : char = prim ("chrCharML", (i, Chr)) +fun ord (c : char) : int = prim ("id", c) +fun print (x:string):unit = prim("printStringML", x) +fun append [] ys = ys + | append (x::xs) ys = x :: append xs ys +fun xs @ ys = append xs ys -fun eq_integer (x: int, y: int): bool = prim ("=", "=", (x, y)) -fun eq_string (x: string, y: string): bool = prim("=", "=", (x, y)) +fun eq_integer (x: int, y: int): bool = prim ("=", (x, y)) +fun eq_string (x: string, y: string): bool = prim("=", (x, y)) fun map f [] = [] - | map f (x::xs) = f x :: map f xs + | map f (x::xs) = f x :: map f xs -(* +(* signature KB = sig datatype term = Var of int | Term of string * term list @@ -68,146 +68,116 @@ signature KB = ('a * ('b * (term * term))) list -> unit include BMARK end; -*) -(* -structure Main : KB = - struct *) - fun length l = let - fun j(k, nil) = k - | j(k, a::x) = j(k+1,x) - in - j(0,l) - end - fun op @ (nil, l) = l - | op @ (a::r, l) = a :: (r@l) - fun rev l = let - fun f (nil, h) = h - | f (a::r, h) = f(r, a::h) - in - f(l,nil) - end - fun app f = let - fun app_rec [] = () - | app_rec (a::L) = (f a; app_rec L) - in - app_rec - end (* - fun map f = let - fun map_rec [] = [] - | map_rec (a::L) = f a :: map_rec L - in - map_rec - end +structure Main : KB = + struct *) +fun length l = let + fun j(k, nil) = k + | j(k, a::x) = j(k+1,x) +in + j(0,l) +end -(******* Quelques definitions du prelude CAML **************) +fun op @ (nil, l) = l + | op @ (a::r, l) = a :: (r@l) - exception Failure of string - exception FailItList2 - exception FailTryFind - exception FailFind - exception FailChange - exception FailReplace - exception FailMatching - exception FailUnify - exception FailPretty - exception Fail - exception FailMrewrite1 - exception FailRemEQ - exception FailMultExt - exception FailLexExt - exception FailKbComplettion +fun rev l = + let fun f (nil, h) = h + | f (a::r, h) = f(r, a::h) + in f(l,nil) + end - fun failwith s = raise(Failure s) +fun app f = + let fun app_rec [] = () + | app_rec (a::L) = (f a; app_rec L) + in app_rec + end - fun fst (x,y) = x - and snd (x,y) = y +(******* Quelques definitions du prelude CAML **************) +exception Failure of string +exception FailItList2 +exception FailTryFind +exception FailFind +exception FailChange +exception FailReplace +exception FailMatching +exception FailUnify +exception FailPretty +exception Fail +exception FailMrewrite1 +exception FailRemEQ +exception FailMultExt +exception FailLexExt +exception FailKbComplettion + +fun failwith s = raise(Failure s) + +fun fst (x,y) = x +and snd (x,y) = y -(* -fun it_list f = - let fun it_rec a [] = a - | it_rec a (b::L) = it_rec (f a b) L - in it_rec - end -*) fun it_list f a [] = a | it_list f a (b::L) = it_list f (f a b) L fun it_list2 f = - let fun it_rec a [] [] = a - | it_rec a (a1::L1) (a2::L2) = it_rec (f a (a1,a2)) L1 L2 - | it_rec _ _ _ = raise FailItList2 - in it_rec + let fun it_rec a [] [] = a + | it_rec a (a1::L1) (a2::L2) = it_rec (f a (a1,a2)) L1 L2 + | it_rec _ _ _ = raise FailItList2 + in it_rec end fun exists p = - let fun exists_rec [] = false - | exists_rec (a::L) = (p a) orelse (exists_rec L) - in exists_rec - end + let fun exists_rec [] = false + | exists_rec (a::L) = (p a) orelse (exists_rec L) + in exists_rec + end fun for_all p = - let fun for_all_rec [] = true - | for_all_rec (a::L) = (p a) andalso (for_all_rec L) - in for_all_rec - end + let fun for_all_rec [] = true + | for_all_rec (a::L) = (p a) andalso (for_all_rec L) + in for_all_rec + end -fun rev_append [] L = L +fun rev_append [] L = L | rev_append (x::L1) L2 = rev_append L1 (x::L2) fun try_find f = - let fun try_find_rec [] = raise FailTryFind - | try_find_rec (a::L) = (f a) handle _ => try_find_rec L - in try_find_rec - end + let fun try_find_rec [] = raise FailTryFind + | try_find_rec (a::L) = (f a) handle _ => try_find_rec L + in try_find_rec + end fun partition p = - let fun part_rec [] = ([],[]) - | part_rec (a::L) = + let fun part_rec [] = ([],[]) + | part_rec (a::L) = let val (pos,neg) = part_rec L in if p a then ((a::pos), neg) else (pos, (a::neg)) end - in part_rec - end + in part_rec + end (* 3- Les ensembles et les listes d'association *) -(* -fun mem eq a = - let fun mem_rec [] = false - | mem_rec (b::L) = (eq(a,b)) orelse mem_rec L - in mem_rec - end -*) fun mem eq a []= false | mem eq a (b::L) = eq(a,b) orelse mem eq a L fun union eq L1 L2 = - let fun union_rec [] = L2 - | union_rec (a::L) = + let fun union_rec [] = L2 + | union_rec (a::L) = if mem eq a L2 then union_rec L else a :: union_rec L - in union_rec L1 - end - -(* -fun mem_assoc eq a = - let fun mem_rec [] = false - | mem_rec ((b,_)::L) = (eq(a,b)) orelse mem_rec L - in mem_rec - end -*) + in union_rec L1 + end fun mem_assoc eq a [] = false | mem_assoc eq a ((b,_)::L) = eq(a,b) orelse mem_assoc eq a L fun assoc eq a = - let fun assoc_rec [] = raise FailFind - | assoc_rec ((b,d)::L) = if eq(a,b) then d else assoc_rec L - in assoc_rec - end + let fun assoc_rec [] = raise FailFind + | assoc_rec ((b,d)::L) = if eq(a,b) then d else assoc_rec L + in assoc_rec + end (* 4- Les sorties *) @@ -216,7 +186,6 @@ fun assoc eq a = fun print_string (x:string):unit = print x (* val print_num = Integer.print; *) -(* Lars *) local fun digit n = chr(ord #"0" + n) fun digits(n,acc) = @@ -228,30 +197,25 @@ in end (* fun print_newline () = String.print "\n"; *) -(* Lars *) fun print_newline () = print "\n" (* fun message s = (String.print s; String.print "\n"); *) -(* Lars *) fun message s = (print s; print "\n") (* 5- Les ensembles *) fun union eq L1 = - let fun union_rec [] = L1 - | union_rec (a::L) = if mem eq a L1 then union_rec L else a :: union_rec L - in union_rec - end + let fun union_rec [] = L1 + | union_rec (a::L) = if mem eq a L1 then union_rec L else a :: union_rec L + in union_rec + end (****************** Term manipulations *****************) - datatype term = Var of int | Term of string * term list -(* Lars, from now on: seek on eq_X to see what I have modified *) - fun map' f ([]:term list) : term list = [] | map' f (term::terms) = f term :: map' f terms @@ -259,113 +223,104 @@ fun copy_term (Var n) = Var (n+0) | copy_term (Term(s, l)) = Term(s, map' copy_term l) fun eq_term x = - (fn (Var i1, Var i2) => - eq_integer(i1,i2) - | (Term(s1,ts1),Term(s2,ts2)) => - eq_string(s1,s2) andalso (eq_term_list(ts1,ts2)) - | _ => false) x + (fn (Var i1, Var i2) => + eq_integer(i1,i2) + | (Term(s1,ts1),Term(s2,ts2)) => + eq_string(s1,s2) andalso (eq_term_list(ts1,ts2)) + | _ => false) x and eq_term_list x = - (fn ([],[]) => true - | (t1::ts1,t2::ts2) => eq_term(t1,t2) andalso eq_term_list(ts1,ts2) - | _ => false) x + (fn ([],[]) => true + | (t1::ts1,t2::ts2) => eq_term(t1,t2) andalso eq_term_list(ts1,ts2) + | _ => false) x fun vars (Var n) = [n] | vars (Term(_,L)) = vars_of_list L and vars_of_list [] = [] | vars_of_list (t::r) = union eq_integer (vars t) (vars_of_list r) -(* -fun substitute subst = - let fun subst_rec (Term(oper,sons)) = Term(oper, map subst_rec sons) - | subst_rec (t as (Var n)) = (assoc eq_integer n subst) handle _ => t - in subst_rec - end -*) fun substitute subst (t as Term(oper,[])) = t | substitute subst (Term(oper,sons)) = Term(oper, map (substitute subst) sons) | substitute subst (t as (Var n)) = (assoc eq_integer n subst) handle _ => t fun change f = - let fun change_rec (h::t) n = if eq_integer(n,1) then f h :: t - else h :: change_rec t (n-1) - | change_rec _ _ = raise FailChange - in change_rec - end + let fun change_rec (h::t) n = if eq_integer(n,1) then f h :: t + else h :: change_rec t (n-1) + | change_rec _ _ = raise FailChange + in change_rec + end (* Term replacement replace M u N => M[u<-N] *) -fun replace M u N = - let fun reprec (_, []) = N - | reprec (Term(oper,sons), (n::u)) = - Term(oper, change (fn P => reprec(P,u)) sons n) - | reprec _ = raise FailReplace - in reprec(M,u) - end +fun replace M u N = + let fun reprec (_, []) = N + | reprec (Term(oper,sons), (n::u)) = + Term(oper, change (fn P => reprec(P,u)) sons n) + | reprec _ = raise FailReplace + in reprec(M,u) + end (* matching = - : (term -> term -> subst) *) fun matching term1 term2 = - let fun match_rec subst (Var v, M) = - if mem_assoc eq_integer v subst then - if eq_term(M,assoc eq_integer v subst) then subst else raise FailMatching - else - (v,M) :: subst - | match_rec subst (Term(op1,sons1), Term(op2,sons2)) = - if eq_string(op1,op2) then it_list2 match_rec subst sons1 sons2 - else raise FailMatching - | match_rec _ _ = raise FailMatching - in match_rec [] (term1,term2) - end + let fun match_rec subst (Var v, M) = + if mem_assoc eq_integer v subst then + if eq_term(M,assoc eq_integer v subst) then subst else raise FailMatching + else + (v,M) :: subst + | match_rec subst (Term(op1,sons1), Term(op2,sons2)) = + if eq_string(op1,op2) then it_list2 match_rec subst sons1 sons2 + else raise FailMatching + | match_rec _ _ = raise FailMatching + in match_rec [] (term1,term2) + end (* A naive unification algorithm *) -fun compsubst subst1 subst2 = - (map (fn (v,t) => (v, substitute subst1 t)) subst2) @ subst1 +fun compsubst subst1 subst2 = + (map (fn (v,t) => (v, substitute subst1 t)) subst2) @ subst1 fun occurs n = - let fun occur_rec (Var m) = eq_integer(m,n) - | occur_rec (Term(_,sons)) = exists occur_rec sons - in occur_rec - end + let fun occur_rec (Var m) = eq_integer(m,n) + | occur_rec (Term(_,sons)) = exists occur_rec sons + in occur_rec + end fun unify ((term1 as (Var n1)), term2) = - if eq_term(term1,term2) then [] - else if occurs n1 term2 then raise FailUnify - else [(n1,term2)] + if eq_term(term1,term2) then [] + else if occurs n1 term2 then raise FailUnify + else [(n1,term2)] | unify (term1, Var n2) = - if occurs n2 term1 then raise FailUnify - else [(n2,term1)] + if occurs n2 term1 then raise FailUnify + else [(n2,term1)] | unify (Term(op1,sons1), Term(op2,sons2)) = - if eq_string(op1,op2) then - it_list2 (fn s => fn (t1,t2) => compsubst (unify(substitute s t1, - substitute s t2)) s) - [] sons1 sons2 - else raise FailUnify + if eq_string(op1,op2) then + it_list2 (fn s => fn (t1,t2) => compsubst (unify(substitute s t1, + substitute s t2)) s) + [] sons1 sons2 + else raise FailUnify (* We need to print terms with variables independently from input terms - obtained by parsing. We give arbitrary names v1,v2,... to their variables. *) + * obtained by parsing. We give arbitrary names v1,v2,... to their variables. *) val INFIXES = ["+","*"] fun pretty_term (Var n) = - (print_string "v"; print_num n) + (print_string "v"; print_num n) | pretty_term (Term (oper,sons)) = - if mem eq_string oper INFIXES then - case sons of - [s1,s2] => - (pretty_close s1; print_string oper; pretty_close s2) - | _ => - raise FailPretty (* "pretty_term : infix arity <> 2"*) - else - (print_string oper; - case sons of - [] => () - | t::lt =>(print_string "("; + if mem eq_string oper INFIXES then + case sons of + [s1,s2] => (pretty_close s1; print_string oper; pretty_close s2) + | _ => raise FailPretty (* "pretty_term : infix arity <> 2"*) + else + (print_string oper; + case sons of + [] => () + | t::lt => (print_string "("; pretty_term t; app (fn t => (print_string ","; pretty_term t)) lt; print_string ")")) and pretty_close (M as Term(oper, _)) = - if mem eq_string oper INFIXES then - (print_string "("; pretty_term M; print_string ")") - else pretty_term M + if mem eq_string oper INFIXES then + (print_string "("; pretty_term M; print_string ")") + else pretty_term M | pretty_close M = pretty_term M (****************** Equation manipulations *************) @@ -373,24 +328,24 @@ and pretty_close (M as Term(oper, _)) = (* standardizes an equation so its variables are 1,2,... *) fun mk_rule M N = - let val all_vars = union eq_integer (vars M) (vars N) - val (k,subst) = - it_list (fn (i,sigma) => fn v => (i+1,(v,Var(i))::sigma)) - (1,[]) all_vars - in (k-1, (substitute subst M, substitute subst N)) - end + let val all_vars = union eq_integer (vars M) (vars N) + val (k,subst) = + it_list (fn (i,sigma) => fn v => (i+1,(v,Var(i))::sigma)) + (1,[]) all_vars + in (k-1, (substitute subst M, substitute subst N)) + end (* checks that rules are numbered in sequence and returns their number *) fun check_rules x = - it_list (fn n => fn (k,_) => - if eq_integer(k,n+1) then k - else raise Fail (*failwith "Rule numbers not in sequence"*) - ) 0 x + it_list (fn n => fn (k,_) => + if eq_integer(k,n+1) then k + else raise Fail (*failwith "Rule numbers not in sequence"*) + ) 0 x fun pretty_rule (k,(n,(M,N))) = - (print_num k; print_string " : "; - pretty_term M; print_string " = "; pretty_term N; - print_newline()) + (print_num k; print_string " : "; + pretty_term M; print_string " = "; pretty_term N; + print_newline()) fun pretty_rules l = app pretty_rule l @@ -402,45 +357,48 @@ fun copy_rules [] = [] (* Top-level rewriting. Let eq:L=R be an equation, M be a term such that L<=M. With sigma = matching L M, we define the image of M by eq as sigma(R) *) fun reduce L M = - substitute (matching L M) + substitute (matching L M) (* A more efficient version of can (rewrite1 (L,R)) for R arbitrary *) fun reducible L = - let fun redrec M = - (matching L M; true) - handle _ => - case M of Term(_,sons) => exists redrec sons - | _ => false - in redrec - end + let fun redrec M = + (matching L M; true) + handle _ => + case M of Term(_,sons) => exists redrec sons + | _ => false + in redrec + end (* mreduce : rules -> term -> term *) fun mreduce rules M = - let fun redex (_,(_,(L,R))) = reduce L M R in try_find redex rules end + let fun redex (_,(_,(L,R))) = reduce L M R + in try_find redex rules + end (* One step of rewriting in leftmost-outermost strategy, with multiple rules *) (* fails if no redex is found *) (* mrewrite1 : rules -> term -> term *) fun mrewrite1 rules = - let fun rewrec M = - (mreduce rules M) handle _ => - let fun tryrec [] = raise FailMrewrite1 (*failwith "mrewrite1"*) - | tryrec (son::rest) = - (rewrec son :: rest) handle _ => son :: tryrec rest - in case M of - Term(f, sons) => Term(f, tryrec sons) - | _ => raise FailMrewrite1 (*failwith "mrewrite1"*) - end - in rewrec - end + let fun rewrec M = + (mreduce rules M) + handle _ => + let fun tryrec [] = raise FailMrewrite1 (*failwith "mrewrite1"*) + | tryrec (son::rest) = + (rewrec son :: rest) handle _ => son :: tryrec rest + in case M of + Term(f, sons) => Term(f, tryrec sons) + | _ => raise FailMrewrite1 (*failwith "mrewrite1"*) + end + in rewrec + end (* Iterating rewrite1. Returns a normal form. May loop forever *) (* mrewrite_all : rules -> term -> term *) fun mrewrite_all rules M = - let fun rew_loop M = - rew_loop(mrewrite1 rules M) handle _ => M - in rew_loop M - end + let fun rew_loop M = + rew_loop(mrewrite1 rules M) handle _ => M + in rew_loop M + end (* pretty_term (mrewrite_all Group_rules M where M,_=<>);; @@ -452,8 +410,7 @@ pretty_term (mrewrite_all Group_rules M where M,_=<>);; datatype ordering = Greater | Equal | NotGE - -fun eq_ordering (Greater,Greater) = true (*lars *) +fun eq_ordering (Greater,Greater) = true | eq_ordering (Equal,Equal) = true | eq_ordering (NotGE,NotGE) = true | eq_ordering _ = false @@ -463,42 +420,45 @@ and gt_ord order pair = case order pair of Greater => true | _ => false and eq_ord order pair = case order pair of Equal => true | _ => false fun rem_eq equiv = - let fun remrec x [] = raise FailRemEQ (*failwith "rem_eq"*) - | remrec x (y::l) = if equiv (x,y) then l else y :: remrec x l - in remrec - end + let fun remrec x [] = raise FailRemEQ + | remrec x (y::l) = if equiv (x,y) then l else y :: remrec x l + in remrec + end fun diff_eq equiv (x,y) = - let fun diffrec (p as ([],_)) = p - | diffrec ((h::t), y) = - diffrec (t,rem_eq equiv h y) handle _ => - let val (x',y') = diffrec (t,y) in (h::x',y') end - in if length x > length y then diffrec(y,x) else diffrec(x,y) - end + let fun diffrec (p as ([],_)) = p + | diffrec ((h::t), y) = + diffrec (t,rem_eq equiv h y) + handle _ => + let val (x',y') = diffrec (t,y) + in (h::x',y') + end + in if length x > length y then diffrec(y,x) else diffrec(x,y) + end (* multiset extension of order *) fun mult_ext order (Term(_,sons1), Term(_,sons2)) = - (case diff_eq (eq_ord order) (sons1,sons2) of - ([],[]) => Equal - | (l1,l2) => - if for_all (fn N => exists (fn M => eq_ordering(order (M,N),Greater)) l1) l2 - then Greater else NotGE) + (case diff_eq (eq_ord order) (sons1,sons2) of + ([],[]) => Equal + | (l1,l2) => + if for_all (fn N => exists (fn M => eq_ordering(order (M,N),Greater)) l1) l2 + then Greater else NotGE) | mult_ext order (_, _) = raise FailMultExt (*failwith "mult_ext"*) (* lexicographic extension of order *) fun lex_ext order ((M as Term(_,sons1)), (N as Term(_,sons2))) = - let fun lexrec ([] , []) = Equal - | lexrec ([] , _ ) = NotGE - | lexrec ( _ , []) = Greater - | lexrec (x1::l1, x2::l2) = - case order (x1,x2) of - Greater => if for_all (fn N' => gt_ord order (M,N')) l2 - then Greater else NotGE - | Equal => lexrec (l1,l2) - | NotGE => if exists (fn M' => ge_ord order (M',N)) l1 + let fun lexrec ([] , []) = Equal + | lexrec ([] , _ ) = NotGE + | lexrec ( _ , []) = Greater + | lexrec (x1::l1, x2::l2) = + case order (x1,x2) of + Greater => if for_all (fn N' => gt_ord order (M,N')) l2 then Greater else NotGE - in lexrec (sons1, sons2) - end + | Equal => lexrec (l1,l2) + | NotGE => if exists (fn M' => ge_ord order (M',N)) l1 + then Greater else NotGE + in lexrec (sons1, sons2) + end | lex_ext order _ = raise FailLexExt (*failwith "lex_ext"*) (* recursive path ordering *) @@ -509,25 +469,25 @@ fun Group_rules() = [ Term("*", [Var 1, Term("*", [Var 2, Var 3])]))))] fun Geom_rules() = [ - (1,(1,(Term ("*",[(Term ("U",[])), (Var 1)]),(Var 1)))), - (2,(1,(Term ("*",[(Term ("I",[(Var 1)])), (Var 1)]),(Term ("U",[]))))), - (3,(3,(Term ("*",[(Term ("*",[(Var 1), (Var 2)])), (Var 3)]), - (Term ("*",[(Var 1), (Term ("*",[(Var 2), (Var 3)]))]))))), - (4,(0,(Term ("*",[(Term ("A",[])), (Term ("B",[]))]), - (Term ("*",[(Term ("B",[])), (Term ("A",[]))]))))), - (5,(0,(Term ("*",[(Term ("C",[])), (Term ("C",[]))]),(Term ("U",[]))))), - (6,(0, - (Term - ("*", - [(Term ("C",[])), - (Term ("*",[(Term ("A",[])), (Term ("I",[(Term ("C",[]))]))]))]), - (Term ("I",[(Term ("A",[]))]))))), - (7,(0, - (Term - ("*", - [(Term ("C",[])), - (Term ("*",[(Term ("B",[])), (Term ("I",[(Term ("C",[]))]))]))]), - (Term ("B",[]))))) + (1,(1,(Term ("*",[(Term ("U",[])), (Var 1)]),(Var 1)))), + (2,(1,(Term ("*",[(Term ("I",[(Var 1)])), (Var 1)]),(Term ("U",[]))))), + (3,(3,(Term ("*",[(Term ("*",[(Var 1), (Var 2)])), (Var 3)]), + (Term ("*",[(Var 1), (Term ("*",[(Var 2), (Var 3)]))]))))), + (4,(0,(Term ("*",[(Term ("A",[])), (Term ("B",[]))]), + (Term ("*",[(Term ("B",[])), (Term ("A",[]))]))))), + (5,(0,(Term ("*",[(Term ("C",[])), (Term ("C",[]))]),(Term ("U",[]))))), + (6,(0, + (Term + ("*", + [(Term ("C",[])), + (Term ("*",[(Term ("A",[])), (Term ("I",[(Term ("C",[]))]))]))]), + (Term ("I",[(Term ("A",[]))]))))), + (7,(0, + (Term + ("*", + [(Term ("C",[])), + (Term ("*",[(Term ("B",[])), (Term ("I",[(Term ("C",[]))]))]))]), + (Term ("B",[]))))) ] fun Group_rank "U" = 0 @@ -539,40 +499,40 @@ fun Group_rank "U" = 0 | Group_rank _ = 100 (*added, to avoid non-exhaustive patter (mads) *) fun Group_precedence op1 op2 = - let val r1 = Group_rank op1 - val r2 = Group_rank op2 - in - if eq_integer(r1,r2) then Equal else - if r1 > r2 then Greater else NotGE - end + let val r1 = Group_rank op1 + val r2 = Group_rank op2 + in + if eq_integer(r1,r2) then Equal else + if r1 > r2 then Greater else NotGE + end fun rpo () = - let fun rporec (M,N) = - if eq_term(M,N) then Equal else - case M of - Var m => NotGE - | Term(op1,sons1) => - case N of - Var n => - if occurs n M then Greater else NotGE - | Term(op2,sons2) => - case (Group_precedence op1 op2) of - Greater => + let fun rporec (M,N) = + if eq_term(M,N) then Equal else + case M of + Var m => NotGE + | Term(op1,sons1) => + case N of + Var n => + if occurs n M then Greater else NotGE + | Term(op2,sons2) => + case (Group_precedence op1 op2) of + Greater => if for_all (fn N' => gt_ord rporec (M,N')) sons2 then Greater else NotGE - | Equal => + | Equal => lex_ext rporec (M,N) - | NotGE => + | NotGE => if exists (fn M' => ge_ord rporec (M',N)) sons1 then Greater else NotGE - in rporec - end + in rporec + end fun Group_order x = rpo () x fun greater pair = - case Group_order pair of Greater => true | _ => false + case Group_order pair of Greater => true | _ => false (****************** Critical pairs *********************) @@ -580,23 +540,22 @@ fun greater pair = with principal unifier sig *) fun super M = - let fun suprec (N as Term(_,sons)) = - let fun collate (pairs,n) son = - (pairs @ map (fn (u,sigma) => (n::u,sigma)) (suprec son), n+1) - val insides : (int list * (int*term)list)list = (*type constraint added (mads)*) - fst (it_list collate ([],1) sons) - in ([], unify(M,N)) :: insides handle _ => insides - end - | suprec _ = [] - in suprec - end - + let fun suprec (N as Term(_,sons)) = + let fun collate (pairs,n) son = + (pairs @ map (fn (u,sigma) => (n::u,sigma)) (suprec son), n+1) + val insides : (int list * (int*term)list)list = (*type constraint added (mads)*) + fst (it_list collate ([],1) sons) + in ([], unify(M,N)) :: insides handle _ => insides + end + | suprec _ = [] + in suprec + end (******************** Ex : -let (M,_) = <> +let (M,_) = <> and (N,_) = <> in super M N;; ==> [[1],[2,Term ("B",[])]; x <- B [2],[2,Term ("A",[]); 1,Term ("B",[])]] x <- A y <- B @@ -606,47 +565,47 @@ and (N,_) = <> in super M N;; (* super_strict : term -> term -> (num list & subst) list *) fun super_strict M (Term(_,sons)) = - let fun collate (pairs,n) son = - (pairs @ map (fn (u,sigma) => (n::u,sigma)) (super M son), n+1) - in fst (it_list collate ([],1) sons) end + let fun collate (pairs,n) son = + (pairs @ map (fn (u,sigma) => (n::u,sigma)) (super M son), n+1) + in fst (it_list collate ([],1) sons) end | super_strict _ _ = [] (* Critical pairs of L1=R1 with L2=R2 *) (* critical_pairs : term_pair -> term_pair -> term_pair list *) fun critical_pairs (L1,R1) (L2,R2) = - let fun mk_pair (u,sigma) = - (substitute sigma (replace L2 u R1), substitute sigma R2) in - map mk_pair (super L1 L2) - end + let fun mk_pair (u,sigma) = + (substitute sigma (replace L2 u R1), substitute sigma R2) in + map mk_pair (super L1 L2) + end (* Strict critical pairs of L1=R1 with L2=R2 *) (* strict_critical_pairs : term_pair -> term_pair -> term_pair list *) fun strict_critical_pairs (* r1908 *) (L1,R1) (L2,R2) = - let fun mk_pair (u,sigma) = - (substitute sigma (replace L2 u R1), substitute sigma R2) in (* these applications of substitute put terms attop *) - map mk_pair (super_strict L1 L2) - end + let fun mk_pair (u,sigma) = + (substitute sigma (replace L2 u R1), substitute sigma R2) in (* these applications of substitute put terms attop *) + map mk_pair (super_strict L1 L2) + end (* All critical pairs of eq1 with eq2 *) fun mutual_critical_pairs eq1 eq2 = - (strict_critical_pairs eq1 eq2) @ (critical_pairs eq2 eq1) + (strict_critical_pairs eq1 eq2) @ (critical_pairs eq2 eq1) (* Renaming of variables *) fun rename n (t1,t2) = - let fun ren_rec (Var k) = Var(k+n) - | ren_rec (Term(oper,sons)) = Term(oper, map ren_rec sons) - in (ren_rec t1, ren_rec t2) - end + let fun ren_rec (Var k) = Var(k+n) + | ren_rec (Term(oper,sons)) = Term(oper, map ren_rec sons) + in (ren_rec t1, ren_rec t2) + end (************************ Completion ******************************) fun deletion_message (k,_) = - (print_string "Rule ";print_num k; message " deleted") + (print_string "Rule ";print_num k; message " deleted") (* Generate failure message *) fun non_orientable (M,N) = - (pretty_term M; print_string " = "; pretty_term N; print_newline()) + (pretty_term M; print_string " = "; pretty_term N; print_newline()) fun copy_termpairlist [] = [] | copy_termpairlist ((M,N)::rest) = (copy_term M, copy_term N):: copy_termpairlist rest @@ -655,103 +614,99 @@ fun copy_int_pair(x,y) = (x+0, y+0) fun copy_int_pair_list l = map copy_int_pair l fun copy_int (x) = x+0 - - fun copy_arg(interm:bool, n, rules, failures, p, eps) = - (interm, n, copy_rules rules, copy_termpairlist failures, copy_int_pair p, copy_termpairlist eps) + (interm, n+0, copy_rules rules, copy_termpairlist failures, copy_int_pair p, copy_termpairlist eps) (* Improved Knuth-Bendix completion procedure *) (* kb_completion : num -> rules -> term_pair list -> (num & num) -> term_pair list -> rules *) fun kb_completion (* [r2225] *)(arg as (done,n, rules, list, (k,l), eps)) = - let fun kbrec (* [r2272] *) count n rules = - let fun normal_form x = mrewrite_all rules x - fun get_rule k = assoc eq_integer k rules - fun process failures = - let fun processf (k,l) = - let fun processkl [] = - if k (true, n, rules, [], (k,l), failures) (* successful completion *) - | _ => (message "Non-orientable equations :"; - app non_orientable failures; - raise FailKbComplettion (*failwith "kb_completion"*) )) - | processkl ((M,N)::eqs) = - let val M' = normal_form M - val N' = normal_form N - fun enter_rule(left,right) = - let val new_rule = (n+1, mk_rule left right) in - (pretty_rule new_rule; - let fun left_reducible (_,(_,(L,_))) = reducible left L - val (redl,irredl) = partition left_reducible rules - in (app deletion_message redl; - let fun right_reduce (m,(_,(L,R))) = - (m,mk_rule L (mrewrite_all (new_rule::rules) R)); - val irreds = map right_reduce irredl - val eqs' = map (fn (_,(_,pair)) => pair) redl - in if count>0 - then (kbrec (count-1) ((n+1)) ((new_rule::irreds)) [] ((k,l)) - ((eqs @ eqs' @ failures)) - ) - else (false,n+1, new_rule::irreds, [], (k,l), (eqs @ eqs' @ failures)) - end) - end) + let fun kbrec (* [r2272] *) count n rules = + let fun normal_form x = mrewrite_all rules x + fun get_rule k = assoc eq_integer k rules + fun process failures = + let fun processf (k,l) = + let fun processkl [] = + if k (true, n, rules, [], (k,l), failures) (* successful completion *) + | _ => (message "Non-orientable equations :"; + app non_orientable failures; + raise FailKbComplettion (*failwith "kb_completion"*) )) + | processkl ((M,N)::eqs) = + let val M' = normal_form M + val N' = normal_form N + fun enter_rule(left,right) = + let val new_rule = (n+1, mk_rule left right) in + (pretty_rule new_rule; + let fun left_reducible (_,(_,(L,_))) = reducible left L + val (redl,irredl) = partition left_reducible rules + in (app deletion_message redl; + let fun right_reduce (m,(_,(L,R))) = + (m,mk_rule L (mrewrite_all (new_rule::rules) R)); + val irreds = map right_reduce irredl + val eqs' = map (fn (_,(_,pair)) => pair) redl + in if count>0 + then (kbrec (count-1) ((n+1)) ((new_rule::irreds)) [] ((k,l)) + ((eqs @ eqs' @ failures)) + ) + else (false,n+1, new_rule::irreds, [], (k,l), (eqs @ eqs' @ failures)) + end) + end) + end + in if eq_term(M',N') then processkl eqs else + if greater(M',N') then enter_rule( M', N') + else + if greater(N',M') then enter_rule( N', M') + else + (process ( ((M', N')::failures)) ( (k,l)) ( eqs)) + end + in processkl + end + and next_criticals (k,l) = + (let val (v,el) = get_rule l in + if eq_integer(k,l) then + processf (k,l) (strict_critical_pairs el (rename v el)) + else + (let val (_,ek) = get_rule k in + processf (k,l) (mutual_critical_pairs el (rename v ek)) + end + handle FailFind (*rule k deleted*) => + next_criticals (k+1,l)) + end + handle FailFind (*rule l deleted*) => + next_criticals (1,l+1)) + in processf end - in if eq_term(M',N') then processkl eqs else - if greater(M',N') then enter_rule( M', N') - else - if greater(N',M') then enter_rule( N', M') - else - (process ( ((M', N')::failures)) ( (k,l)) ( eqs)) - end - in processkl + in process end - and next_criticals (k,l) = - (let val (v,el) = get_rule l in - if eq_integer(k,l) then - processf (k,l) (strict_critical_pairs el (rename v el)) - else - (let val (_,ek) = get_rule k in - processf (k,l) (mutual_critical_pairs el (rename v ek)) - end - handle FailFind (*rule k deleted*) => - next_criticals (k+1,l)) - end - handle FailFind (*rule l deleted*) => - next_criticals (1,l+1)) - in processf - end - in process - end - fun kb_outer (* [r2517] *)(arg as (_, n, rules, failures, (k,l), other_failures)) = - case kbrec 1 n rules failures (k,l) other_failures of - result as (true,_, result_rules,_,_,_) => if false then arg else result - | arg0 as (false, n', rules', failures', (k',l'), eqs') => - kb_outer(let val arg1 = copy_arg arg0 - in resetRegions arg0; - copy_arg(arg1) - end - ) - - - in (fn (_,_,x,_,_,_) => x)(kb_outer(arg)) - end + fun kb_outer (* [r2517] *)(arg as (_, n, rules, failures, (k,l), other_failures)) = + case kbrec 1 n rules failures (k,l) other_failures of + result as (true,_, result_rules,_,_,_) => if false then arg else result + | arg0 as (false, n', rules', failures', (k',l'), eqs') => + kb_outer(let val arg1 = copy_arg arg0 + in resetRegions arg0; + copy_arg(arg1) + end + ) + + in (fn (_,_,x,_,_,_) => x)(kb_outer(arg)) + end -fun kb_complete complete_rules (* the terms in the complete_rules are global *) rules = +fun kb_complete complete_rules (* the terms in the complete_rules are global *) rules = let val n = check_rules complete_rules val eqs = map (fn (_,(_,pair)) => pair) rules (* letregion r2656 *) - val completed_rules = - (* the copying in the line below is to avoid that kb_completion is called with attop modes *) - kb_completion(false,n+0, copy_rules complete_rules, [], (n+0,n+0), copy_termpairlist eqs) + val completed_rules = + (* the copying in the line below is to avoid that kb_completion is called with attop modes *) + kb_completion(false,n+0, copy_rules complete_rules, [], (n+0,n+0), copy_termpairlist eqs) in (message "Canonical set found :"; pretty_rules (rev completed_rules); (* end r2683 *) ()) end - fun doit() = kb_complete [] (* terms in list global *) (Geom_rules()) fun testit _ = () diff --git a/test_dev/kitlife35u_no_basislib.out.ok b/test_dev/kitlife35u_no_basislib.out.ok new file mode 100644 index 000000000..29a2b3b45 --- /dev/null +++ b/test_dev/kitlife35u_no_basislib.out.ok @@ -0,0 +1,534 @@ +Before glider +Before bail +Before genB +Before testit +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +starting printing + + + + + + 00 00 + 00 00 + + + + + 00 + 0 0 + 0 +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +starting printing + + + + + + 00 00 + 00 00 + + + + + 00 + 0 0 + 0 diff --git a/test_dev/kitlife35u_no_basislib.sml b/test_dev/kitlife35u_no_basislib.sml index 6e71fc68e..8c9e374b4 100644 --- a/test_dev/kitlife35u_no_basislib.sml +++ b/test_dev/kitlife35u_no_basislib.sml @@ -14,277 +14,272 @@ infix 3 := o infix 0 before - type unit = unit - type exn = exn - type 'a ref = 'a ref - - exception Bind = Bind - exception Match = Match - exception Subscript - exception Size - exception Overflow = Overflow - exception Domain - exception Div = Div - exception Chr - exception Fail of string - -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun concat (ss : string list) : string = prim ("implodeStringML", "implodeStringProfilingML", ss) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) +type unit = unit +type exn = exn +type 'a ref = 'a ref + +exception Bind = Bind +exception Match = Match +exception Subscript +exception Size +exception Overflow = Overflow +exception Domain +exception Div = Div +exception Chr +exception Fail of string + +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) fun str (c : char) : string = implode [c] -fun size (s:string): int = prim ("sizeStringML", "sizeStringML", s) -fun chr (i : int) : char = prim ("chrCharML", "chrCharML", (i, Chr)) -fun ord (c : char) : int = prim ("id", "id", c) -fun print (x:string):unit = prim("printStringML","printStringML",x) - fun append [] ys = ys - | append (x::xs) ys = x :: append xs ys - fun xs @ ys = append xs ys +fun size (s : string) : int = prim ("__bytetable_size", s) +fun chr (i : int) : char = prim ("chrCharML", (i, Chr)) +fun ord (c : char) : int = prim ("id", c) +fun print (x:string):unit = prim("printStringML",x) +fun append [] ys = ys + | append (x::xs) ys = x :: append xs ys +fun xs @ ys = append xs ys fun not true = false - | not false = true + | not false = true fun (f o g) x = f(g x) - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) -fun eq_integer (x: int, y: int): bool = prim ("=", "=", (x, y)) -fun eq_string (x: string, y: string): bool = prim("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) +fun eq_integer (x: int, y: int): bool = prim ("=", (x, y)) +fun eq_string (x: string, y: string): bool = prim("=", (x, y)) fun map f [] = [] - | map f (x::xs) = f x :: map f xs + | map f (x::xs) = f x :: map f xs fun revAcc [] ys = ys | revAcc (x::xs) ys = revAcc xs (x::ys) fun rev xs = revAcc xs [] -(* -fun eq_integer (x: int, y: int): bool = x = y -fun eq_string (x: string, y: string): bool = x = y -*) -fun eq_integer_curry(x)(y:int) =eq_integer(x,y) fun eq_int_pair_curry (x,x')(y,y'): bool = - eq_integer(x,y) andalso eq_integer(x',y') + eq_integer(x,y) andalso eq_integer(x',y') fun app f [] = () | app f (x::xs) = (f x; app f xs) - fun map f [] = [] - | map f (a::x) = f a :: map f x - - fun map_rec(f, []) = [] - | map_rec(f, x::xs) = f x:: map_rec(f, xs) - - exception ex_undefined of string - fun error str = raise ex_undefined str - - fun accumulate f a [] = a (* this now has no escaping regions, although still an escaping arrow effect*) - | accumulate f a (b::x) = accumulate f (f a b) x +fun map f [] = [] + | map f (a::x) = f a :: map f x - fun accumulate' (f, a, []) = a - | accumulate' (f, a, b::x) = accumulate'(f, f(a,b), x) +fun map_rec(f, []) = [] + | map_rec(f, x::xs) = f x:: map_rec(f, xs) - fun filter p l= - rev (accumulate (fn x => fn a => if p a then a::x else x) [] l) - (*builds an intermediate list; the regions of this list - are now made local (unlike in escape.sml) *) +exception ex_undefined of string +fun error str = raise ex_undefined str +fun accumulate f a [] = a (* this now has no escaping regions, although still an escaping arrow effect*) + | accumulate f a (b::x) = accumulate f (f a b) x - fun equal a b = a=b +fun accumulate' (f, a, []) = a + | accumulate' (f, a, b::x) = accumulate'(f, f(a,b), x) - fun exists p [] = false - | exists p (a::x) = if p a then true else exists p x +fun filter p l= + rev (accumulate (fn x => fn a => if p a then a::x else x) [] l) +(*builds an intermediate list; the regions of this list + are now made local (unlike in escape.sml) *) - fun exists' (p, []) = false - | exists' (p, (a::x)) = p a orelse exists'(p,x) +fun equal a b = a=b +fun exists p [] = false + | exists p (a::x) = if p a then true else exists p x - fun member eq x a = exists' (eq a, x) +fun exists' (p, []) = false + | exists' (p, (a::x)) = p a orelse exists'(p,x) - fun C f x y = f y x +fun member eq x a = exists' (eq a, x) - fun cons a x = a::x +fun C f x y = f y x +fun cons a x = a::x - fun revonto x y = accumulate' ((fn (x,y) => y::x), x, y) +fun revonto x y = accumulate' ((fn (x,y) => y::x), x, y) - fun copy_int n = n+0 +fun copy_int n = n+0 - fun length x = copy_int(let fun count (n, a) = n+1 in accumulate'(count, 0, x) end) - (* eta expanded*) +fun length x = copy_int(let fun count (n, a) = n+1 in accumulate'(count, 0, x) end) +(* eta expanded*) - fun repeat f = let (* rptf moved into inner let *) - fun check n = if n<0 then error "repeat<0" else n - in fn x => fn y => let fun rptf n x = if n=0 then x else rptf(n-1)(f x) - in rptf (check x) y - end - end +fun repeat f = + let (* rptf moved into inner let *) + fun check n = if n<0 then error "repeat<0" else n + in fn x => fn y => let fun rptf n x = if n=0 then x else rptf(n-1)(f x) + in rptf (check x) y + end + end - fun copy n x = repeat (cons x) n [] +fun copy n x = repeat (cons x) n [] - fun spaces n = implode (copy n #" ") +fun spaces n = implode (copy n #" ") - fun copy_list[] = [] - | copy_list((x,y)::rest) = (x+0,y+0):: copy_list rest +fun copy_list[] = [] + | copy_list((x,y)::rest) = (x+0,y+0):: copy_list rest - fun lexless(a2,b2)(a1:int,b1:int) = - if a2 0 -| x::xs => 1 + length xs + [] => 0 + | x::xs => 1 + length xs fun copy [] = [] | copy (x::xs) = x :: copy xs -fun take(i,l) = +fun take(i,l) = case l of [] => [] - | x::xs=> if i>0 then x::take(i-1,xs) else nil + | x::xs=> if i>0 then x::take(i-1,xs) else nil fun drop(i,l) = case l of [] => [] - | x::xs => if i>0 then drop(i-1,xs) else l + | x::xs => if i>0 then drop(i-1,xs) else l fun merge(lp as (left, right)) = case left of [] => right - | x::xs => (case right of - [] => left - | y::ys => if lexless x y then x::merge(xs, right) - else if lexless y x then y:: merge(left,ys) - else (*x=y*) merge(xs, right) - ) + | x::xs => (case right of + [] => left + | y::ys => if lexless x y then x::merge(xs, right) + else if lexless y x then y:: merge(left,ys) + else (*x=y*) merge(xs, right) + ) fun tmergesort l = - case l of [] => [] - | x::xs => (case xs of []=> l - | _ => let val k = length l div 2 - in merge(copy (tmergesort(take(k,l))), - copy (tmergesort(drop(k,l)))) - end - ) + case l of [] => [] + | x::xs => (case xs of []=> l + | _ => let val k = length l div 2 + in merge(copy (tmergesort(take(k,l))), + copy (tmergesort(drop(k,l)))) + end + ) fun lexordset x = tmergesort x - fun collect f list = - let fun accumf sofar [] = sofar - | accumf sofar (a::x) = accumf (revonto sofar (f a)) x - in accumf [] list (* note: this worked without changes!*) - end - - fun occurs3 x = - (* finds coords which occur exactly 3 times in coordlist x *) - let fun f (q) = - case q of (_,_,_,_,[]) => q - | ( xover, x3, x2, x1, (a::x)) => - if member eq_int_pair_curry xover a then f( xover, x3, x2, x1, x) else - if member eq_int_pair_curry x3 a then f ((a::xover), x3, x2, x1, x) else - if member eq_int_pair_curry x2 a then f (xover, (a::x3), x2, x1, x) else - if member eq_int_pair_curry x1 a then f (xover, x3, (a::x2), x1, x) else - f (xover, x3, x2, (a::x1), x) - fun diff x y = filter (fn x => not(member eq_int_pair_curry y x)) x (* unfolded o *) - val (xover, x3, _, _, _) = f ([],[],[],[],x) - in diff x3 xover end - - fun copy_string s= s(*implode(explode s)*) - fun copy_bool true = true - | copy_bool false = false - - fun neighbours (i,j) = [(i-1,j-1),(i-1,j),(i-1,j+1), - (i,j-1),(i,j+1), - (i+1,j-1),(i+1,j),(i+1,j+1)] - - - abstype generation = GEN of (int*int) list - with - fun copy (GEN l) = GEN( copy_list l) - fun alive (GEN livecoords) = livecoords - and mkgen coordlist = GEN (lexordset coordlist) - and mk_nextgen_fn gen = - if true then - let val living = alive gen - fun isalive x = copy_bool(member eq_int_pair_curry living x) (* eta *) - fun liveneighbours x = length( filter isalive ( neighbours x)) (*eta*) - fun twoorthree n = eq_integer(n,2) orelse eq_integer(n,3) - val survivors = copy_list(filter (twoorthree o liveneighbours) living) - val newnbrlist = copy_list(collect (fn z => filter (fn x => not( isalive x)) ( neighbours z)) living) (* unfolded o twice*) - val newborn = copy_list(occurs3 newnbrlist) - in mkgen (survivors @ newborn) end - else gen - end - - - local val xstart = 0 and ystart = 0 - fun markafter n string = (let val r = string ^ spaces n ^ "0" in r end) - fun plotfrom (x,y) (* current position *) - str (* current line being prepared -- a string *) - ((x1,y1)::more) (* coordinates to be plotted *) - = if eq_integer(x,x1) - then (* same line so extend str and continue from y1+1 *) (plotfrom(x,y1+1)(markafter(y1-y)str)more) - else (* flush current line and start a new line *) ( - str :: plotfrom(x+1,ystart)""((x1,y1)::more)) - | plotfrom (x,y) str [] = ([str]) - fun good (x,y) = x>=xstart andalso y>=ystart - in fun plot coordlist = let - - -val r1 = filter good coordlist - -val r2 = copy_list(r1) - -val r3 = plotfrom(xstart,ystart) "" (r2) - -val r = map_rec(copy_string,(r3)) -in r end +fun collect f list = + let fun accumf sofar [] = sofar + | accumf sofar (a::x) = accumf (revonto sofar (f a)) x + in accumf [] list (* note: this worked without changes!*) + end + +fun occurs3 x = + (* finds coords which occur exactly 3 times in coordlist x *) + let fun f (q) = + case q of + (_,_,_,_,[]) => q + | ( xover, x3, x2, x1, (a::x)) => + if member eq_int_pair_curry xover a then f( xover, x3, x2, x1, x) else + if member eq_int_pair_curry x3 a then f ((a::xover), x3, x2, x1, x) else + if member eq_int_pair_curry x2 a then f (xover, (a::x3), x2, x1, x) else + if member eq_int_pair_curry x1 a then f (xover, x3, (a::x2), x1, x) else + f (xover, x3, x2, (a::x1), x) + fun diff x y = filter (fn x => not(member eq_int_pair_curry y x)) x (* unfolded o *) + val (xover, x3, _, _, _) = f ([],[],[],[],x) + in diff x3 xover end +fun copy_string s = s ^ "" +fun copy_bool true = true + | copy_bool false = false + +fun neighbours (i,j) = [(i-1,j-1),(i-1,j),(i-1,j+1), + (i,j-1),(i,j+1), + (i+1,j-1),(i+1,j),(i+1,j+1)] + + +abstype generation = GEN of (int*int) list + with +fun copy (GEN l) = GEN( copy_list l) +fun alive (GEN livecoords) = livecoords +and mkgen coordlist = GEN (lexordset coordlist) +and mk_nextgen_fn gen = + if true then + let val living = alive gen + fun isalive x = copy_bool(member eq_int_pair_curry living x) (* eta *) + fun liveneighbours x = length( filter isalive ( neighbours x)) (*eta*) + fun twoorthree n = eq_integer(n,2) orelse eq_integer(n,3) + val survivors = copy_list(filter (twoorthree o liveneighbours) living) + val newnbrlist = copy_list(collect (fn z => filter (fn x => not( isalive x)) + ( neighbours z)) living) (* unfolded o twice*) + val newborn = copy_list(occurs3 newnbrlist) + in mkgen (survivors @ newborn) end + else gen +end + - infix 6 at - fun coordlist at (x:int,y:int) = let fun move(a,b) = (a+x,b+y) - in map move coordlist end - fun rotate x = map (fn (x:int,y:int) => (y,~x)) x (* eta converted*) +local val xstart = 0 and ystart = 0 + fun markafter n string = (let val r = string ^ spaces n ^ "0" in r end) + fun plotfrom (x,y) (* current position *) + str (* current line being prepared -- a string *) + ((x1,y1)::more) (* coordinates to be plotted *) + = if eq_integer(x,x1) + then (* same line so extend str and continue from y1+1 *) (plotfrom(x,y1+1)(markafter(y1-y)str)more) + else (* flush current line and start a new line *) ( + str :: plotfrom(x+1,ystart)""((x1,y1)::more)) + | plotfrom (x,y) str [] = ([str]) + fun good (x,y) = x>=xstart andalso y>=ystart +in fun plot coordlist = let + + + val r1 = filter good coordlist + + val r2 = copy_list(r1) + + val r3 = plotfrom(xstart,ystart) "" (r2) + + val r = map_rec(copy_string,(r3)) + in r end +end + + +infix 6 at +fun coordlist at (x:int,y:int) = let fun move(a,b) = (a+x,b+y) + in map move coordlist end +fun rotate x = map (fn (x:int,y:int) => (y,~x)) x (* eta converted*) val _ = print "Before glider\n" - val glider = [(0,0),(0,2),(1,1),(1,2),(2,1)] +val glider = [(0,0),(0,2),(1,1),(1,2),(2,1)] val _ = print "Before bail\n" - val bail = [(0,0),(0,1),(1,0),(1,1)] - fun barberpole n = - let fun f i = if eq_integer(i,n) then (n+n-1,n+n)::(n+n,n+n)::nil - else (i+i,i+i+1)::(i+i+2,i+i+1)::f(i+1) - in (0,0)::(1,0):: f 0 - end +val bail = [(0,0),(0,1),(1,0),(1,1)] +fun barberpole n = + let fun f i = if eq_integer(i,n) then (n+n-1,n+n)::(n+n,n+n)::nil + else (i+i,i+i+1)::(i+i+2,i+i+1)::f(i+1) + in (0,0)::(1,0):: f 0 + end val _ = print "Before genB\n" - val genB = mkgen(glider at (2,2) @ bail at (2,12) - @ rotate (barberpole 4) at (5,20)) +val genB = mkgen(glider at (2,2) @ bail at (2,12) + @ rotate (barberpole 4) at (5,20)) - fun copy_whole_arg (p, g) = (copy_int p, copy g) +fun copy_whole_arg (p, g) = (copy_int p, copy g) - fun nthgen'(p as(0,g)) = p - | nthgen'(p as(i,g)) = (print ".\n"; - nthgen' (copy_whole_arg(let val arg = (i-1,mk_nextgen_fn g) - val arg' = copy_whole_arg arg - in resetRegions arg; - arg' - end))) +fun nthgen'(p as(0,g)) = p + | nthgen'(p as(i,g)) = (print ".\n"; + nthgen' (copy_whole_arg(let val arg = (i-1,mk_nextgen_fn g) + val arg' = copy_whole_arg arg + in resetRegions arg; + arg' + end))) - fun gun() = mkgen (* turned into function *) - [(2,20),(3,19),(3,21),(4,18),(4,22),(4,23),(4,32),(5,7),(5,8),(5,18), - (5,22),(5,23),(5,29),(5,30),(5,31),(5,32),(5,36),(6,7),(6,8),(6,18), - (6,22),(6,23),(6,28),(6,29),(6,30),(6,31),(6,36),(7,19),(7,21),(7,28), - (7,31),(7,40),(7,41),(8,20),(8,28),(8,29),(8,30),(8,31),(8,40),(8,41), - (9,29),(9,30),(9,31),(9,32)] +fun gun() = mkgen (* turned into function *) + [(2,20),(3,19),(3,21),(4,18),(4,22),(4,23),(4,32),(5,7),(5,8),(5,18), + (5,22),(5,23),(5,29),(5,30),(5,31),(5,32),(5,36),(6,7),(6,8),(6,18), + (6,22),(6,23),(6,28),(6,29),(6,30),(6,31),(6,36),(7,19),(7,21),(7,28), + (7,31),(7,40),(7,41),(8,20),(8,28),(8,29),(8,30),(8,31),(8,40),(8,41), + (9,29),(9,30),(9,31),(9,32)] - fun iter n = #2(nthgen'(n+0,gun())) +fun iter n = #2(nthgen'(n+0,gun())) - fun pr x = print x +fun pr x = print x - fun show(x) = (pr "starting printing\n"; - app (fn s => (pr s; pr "\n"))(plot(alive x)); - () +fun show(x) = (pr "starting printing\n"; + app (fn s => (pr s; pr "\n"))(plot(alive x)); + () ) (* had to uncurry show, as iter 50 gave attop also made it return a different unit *) - - fun testit _ = show(iter 250) (* inserted call of iter *) -val _ = print "Before testit\n" - val _ = (testit ();testit ()); + +fun testit _ = show(iter 250) (* inserted call of iter *) +val _ = print "Before testit\n" +val _ = (testit ();testit ()) in - val done = "done"; + val done = "done" end - diff --git a/test_dev/kitqsort_no_basislib.out.ok b/test_dev/kitqsort_no_basislib.out.ok new file mode 100644 index 000000000..e1786c8cc --- /dev/null +++ b/test_dev/kitqsort_no_basislib.out.ok @@ -0,0 +1 @@ +Ok! diff --git a/test_dev/kitqsort_no_basislib.sml b/test_dev/kitqsort_no_basislib.sml index 85be61d41..85dd946ef 100644 --- a/test_dev/kitqsort_no_basislib.sml +++ b/test_dev/kitqsort_no_basislib.sml @@ -3,7 +3,7 @@ (* quicksort-random.sml * * Input....: Random list (pseudo-random integers) - * Optimised: 'arg as ...' in quickSort'() and partition(). + * Optimised: 'arg as ...' in quickSort'() and partition(). * Copying left-parts after partitioning inside quickSort'(). * `Bertelsen transformation' of argument to tail-recursive * call to quickSort'(). @@ -33,7 +33,7 @@ infix 0 before exception Domain exception Div = Div exception Chr - exception Fail of string + exception Fail of string fun (a:real) / (b:real) : real = prim ("divFloat", (a,b)) fun implode (chars : char list) : string = prim ("implodeCharsML", chars) @@ -52,11 +52,12 @@ fun real (x : int) : real = prim ("realInt", x) fun floor (x : real) : int = prim ("floorFloat", x) (* may raise Overflow *) fun not true = false - | not false = true + | not false = true fun (f o g) x = f(g x) - fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) -val _ = +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) + +val _ = let fun map f nil = nil | map f (x :: L) = f x :: map f L @@ -74,15 +75,15 @@ fun app f [] = () (* Quicksort -- Paulson p. 98 and answer to exercise 3.29 *) (* Optimised for the Kit with Regions *) -(* NOTE: - * This is the most space efficient version of quicksort with the current +(* NOTE: + * This is the most space efficient version of quicksort with the current * storage mode analysis (implemented in 25q); copyList() will be called "sat" - * inside partition() and the `innermost' recursive call to quickSort'() will - * be "atbot" for the regions holding right'. Unfortunately, calling + * inside partition() and the `innermost' recursive call to quickSort'() will + * be "atbot" for the regions holding right'. Unfortunately, calling * copyList() after (the `innermost' recursive call to) quickSort'() means * that we keep the regions holding the `original list' live during the * call to quickSort'(). This should not be necessary, since a::bs will be - * copied (i.e. partitioned) into to left and right parts, but rules 28 and 26 + * copied (i.e. partitioned) into to left and right parts, but rules 28 and 26 * in the region analysis are a bit too conservative in this case... *) @@ -96,13 +97,13 @@ fun app f [] = () fun quickSort' (arg as ([], sorted)) = arg | quickSort' ([a], sorted) = ([], a::sorted) | quickSort' (a::bs, sorted) = (* "a" is the pivot *) - let + let fun partition (arg as (_, _, []: elem list)) = arg | partition (left, right, x::xr) = if x<=a then partition(x::left, right, xr) else partition(left, x::right, xr) val arg' = - let val (left', right) = + let val (left', right) = let val (left, right, _) = partition([], [], bs) in (*forceResetting bs;*) (copyList left, right) @@ -128,7 +129,7 @@ fun app f [] = () fun nextRand seed = let val t = a*seed - in + in t - m*real(floor(t/m)) end @@ -136,7 +137,7 @@ fun app f [] = () | randomList' (i, seed, res) = let val res' = min+floor(seed*w) :: res (* NOTE: It is significant to use seed for - * calculating res' before calling nextRand()... + * calculating res' before calling nextRand()... *) in randomList'(i-1, nextRand seed, res') @@ -152,5 +153,5 @@ fun app f [] = () in if isSorted (quickSort(randomList 25000)) then say("Ok!\n") - else say("Oops...\n") + else say("Oops...\n") end diff --git a/test_dev/kitreynolds2_no_basislib.out.ok b/test_dev/kitreynolds2_no_basislib.out.ok new file mode 100644 index 000000000..c508d5366 --- /dev/null +++ b/test_dev/kitreynolds2_no_basislib.out.ok @@ -0,0 +1 @@ +false diff --git a/test_dev/kitreynolds2_no_basislib.sml b/test_dev/kitreynolds2_no_basislib.sml index 9d1634913..fab454aa2 100644 --- a/test_dev/kitreynolds2_no_basislib.sml +++ b/test_dev/kitreynolds2_no_basislib.sml @@ -8,47 +8,46 @@ infix 3 := o infix 0 before - type unit = unit - type exn = exn - type 'a ref = 'a ref - - exception Bind = Bind - exception Match = Match - exception Subscript - exception Size - exception Overflow = Overflow - exception Domain - exception Div = Div - exception Chr - exception Fail of string - -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun concat (ss : string list) : string = prim ("implodeStringML", "implodeStringProfilingML", ss) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) +type unit = unit +type exn = exn +type 'a ref = 'a ref + +exception Bind = Bind +exception Match = Match +exception Subscript +exception Size +exception Overflow = Overflow +exception Domain +exception Div = Div +exception Chr +exception Fail of string + +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) fun str (c : char) : string = implode [c] -fun size (s:string): int = prim ("sizeStringML", "sizeStringML", s) -fun chr (i : int) : char = prim ("chrCharML", "chrCharML", (i, Chr)) -fun ord (c : char) : int = prim ("id", "id", c) -fun print (x:string):unit = prim("printStringML","printStringML",x) - fun append [] ys = ys - | append (x::xs) ys = x :: append xs ys - fun xs @ ys = append xs ys +fun size (s : string) : int = prim ("__bytetable_size", s) +fun chr (i : int) : char = prim ("chrCharML", (i, Chr)) +fun ord (c : char) : int = prim ("id", c) +fun print (x:string):unit = prim("printStringML",x) +fun append [] ys = ys + | append (x::xs) ys = x :: append xs ys +fun xs @ ys = append xs ys fun not true = false - | not false = true + | not false = true fun (f o g) x = f(g x) - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) -fun eq_integer (x: int, y: int): bool = prim ("=", "=", (x, y)) -fun eq_string (x: string, y: string): bool = prim("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) +fun eq_integer (x: int, y: int): bool = prim ("=", (x, y)) +fun eq_string (x: string, y: string): bool = prim("=", (x, y)) fun map f [] = [] - | map f (x::xs) = f x :: map f xs + | map f (x::xs) = f x :: map f xs fun revAcc [] ys = ys - | revAcc (x::xs) ys = revAcc xs (x::ys) + | revAcc (x::xs) ys = revAcc xs (x::ys) fun rev xs = revAcc xs [] - fun digit n = chr(ord #"0" + n) fun digits(n,acc) = if n >=0 andalso n<=9 then digit n:: acc @@ -68,18 +67,17 @@ fun foldR f b [] = b fun curry f x y = f(x,y) -datatype 'a Option = None | Some of 'a - +datatype 'a Option = None | Some of 'a -datatype 'a tree = - Lf +datatype 'a tree = + Lf | Br of 'a * 'a tree * 'a tree fun max(i:int, j) = if i>j then i else j fun search p Lf = false - | search p (Br(x,t1,t2)) = + | search p (Br(x,t1,t2)) = if p x then true - else search (fn y => y=x orelse p y) t1 orelse + else search (fn y => y=x orelse p y) t1 orelse search (fn y => y=x orelse p y) t2 fun mk_tree 0 = Lf @@ -88,4 +86,3 @@ fun mk_tree 0 = Lf end val it = if search (fn _ => false) (mk_tree 20) then print "true\n" else print "false\n" - diff --git a/test_dev/kitreynolds3_no_basislib.out.ok b/test_dev/kitreynolds3_no_basislib.out.ok new file mode 100644 index 000000000..c508d5366 --- /dev/null +++ b/test_dev/kitreynolds3_no_basislib.out.ok @@ -0,0 +1 @@ +false diff --git a/test_dev/kitreynolds3_no_basislib.sml b/test_dev/kitreynolds3_no_basislib.sml index 7cd5220d0..4e3d649bc 100644 --- a/test_dev/kitreynolds3_no_basislib.sml +++ b/test_dev/kitreynolds3_no_basislib.sml @@ -7,48 +7,46 @@ infix 4 = <> > >= < <= infix 3 := o infix 0 before - - type unit = unit - type exn = exn - type 'a ref = 'a ref - - exception Bind = Bind - exception Match = Match - exception Subscript - exception Size - exception Overflow = Overflow - exception Domain - exception Div = Div - exception Chr - exception Fail of string - -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun concat (ss : string list) : string = prim ("implodeStringML", "implodeStringProfilingML", ss) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) +type unit = unit +type exn = exn +type 'a ref = 'a ref + +exception Bind = Bind +exception Match = Match +exception Subscript +exception Size +exception Overflow = Overflow +exception Domain +exception Div = Div +exception Chr +exception Fail of string + +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) fun str (c : char) : string = implode [c] -fun size (s:string): int = prim ("sizeStringML", "sizeStringML", s) -fun chr (i : int) : char = prim ("chrCharML", "chrCharML", (i, Chr)) -fun ord (c : char) : int = prim ("id", "id", c) -fun print (x:string):unit = prim("printStringML","printStringML",x) - fun append [] ys = ys - | append (x::xs) ys = x :: append xs ys - fun xs @ ys = append xs ys +fun size (s : string) : int = prim ("__bytetable_size", s) +fun chr (i : int) : char = prim ("chrCharML", (i, Chr)) +fun ord (c : char) : int = prim ("id", c) +fun print (x:string):unit = prim("printStringML", x) +fun append [] ys = ys + | append (x::xs) ys = x :: append xs ys +fun xs @ ys = append xs ys fun not true = false - | not false = true + | not false = true fun (f o g) x = f(g x) - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) -fun eq_integer (x: int, y: int): bool = prim ("=", "=", (x, y)) -fun eq_string (x: string, y: string): bool = prim("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) +fun eq_integer (x: int, y: int): bool = prim ("=", (x, y)) +fun eq_string (x: string, y: string): bool = prim("=", (x, y)) fun map f [] = [] | map f (x::xs) = f x :: map f xs fun revAcc [] ys = ys - | revAcc (x::xs) ys = revAcc xs (x::ys) + | revAcc (x::xs) ys = revAcc xs (x::ys) fun rev xs = revAcc xs [] - fun digit n = chr(ord #"0" + n) fun digits(n,acc) = if n >=0 andalso n<=9 then digit n:: acc @@ -68,8 +66,7 @@ fun foldR f b [] = b fun curry f x y = f(x,y) -datatype 'a Option = None | Some of 'a - +datatype 'a Option = None | Some of 'a datatype 'a tree = Lf | Br of 'a * 'a tree * 'a tree @@ -78,15 +75,14 @@ fun member(x,[]) = false | member(x,x'::rest) = x=x' orelse member(x, rest) fun search p Lf = false - | search p (Br(x,t1,t2)) = - if member(x,p) then true - else search (x::p) t1 orelse - search (x::p) t2 + | search p (Br(x,t1,t2)) = + if member(x,p) then true + else search (x::p) t1 orelse search (x::p) t2 fun mk_tree 0 = Lf | mk_tree n = let val t = mk_tree(n-1) in Br(n,t,t) end -val it = if search [] (mk_tree 20) - then print "true\n" - else print "false\n"; +val it = if search [] (mk_tree 10) + then print "true\n" + else print "false\n" diff --git a/test_dev/kitsimple_no_basislib.out.ok b/test_dev/kitsimple_no_basislib.out.ok new file mode 100644 index 000000000..7038a0267 --- /dev/null +++ b/test_dev/kitsimple_no_basislib.out.ok @@ -0,0 +1,22 @@ +.done make_velocity +done make_position +done make_area_density_volume +done make_viscosity +done make_temperature + make_sigma:deltat = + done make_sigma + done make_cc + done make_gamma + done make_ab + done make_theta + done make_gamma + done make_ab + done make_theta +done compute_heat_conduction +done make_pressure +done make_energy +done compute_energy_error +done compute_time_step + +3072 +~61403 diff --git a/test_dev/kitsimple_no_basislib.sml b/test_dev/kitsimple_no_basislib.sml index be29f01bf..43359a9ce 100644 --- a/test_dev/kitsimple_no_basislib.sml +++ b/test_dev/kitsimple_no_basislib.sml @@ -8,73 +8,70 @@ infix 3 := o infix 0 before - type unit = unit - type exn = exn - type 'a ref = 'a ref - - exception Bind = Bind - exception Match = Match - exception Subscript - exception Size - exception Overflow = Overflow - exception Domain - exception Div = Div - exception Chr - exception Fail of string - - fun !(x: 'a ref): 'a = prim ("!", "!", x) - fun (x: 'a ref) := (y: 'a): unit = prim (":=", ":=", (x, y)) -fun (a:real) / (b:real) : real = prim ("divFloat", "divFloat", (a,b)) - fun sqrt (r : real) : real = prim ("sqrtFloat", "sqrtFloat", r) - fun sin (r : real) : real = prim ("sinFloat", "sinFloat", r) - fun cos (r : real) : real = prim ("cosFloat", "cosFloat", r) - fun tan r = sin r / cos r - fun atan (r : real) : real = prim ("atanFloat", "atanFloat", r) - fun asin (a : real) : real = prim ("asinFloat", "asinFloat", a) - fun acos (a : real) : real = prim ("acosFloat", "acosFloat", a) - fun atan2 (y : real, x : real) : real = prim ("atan2Float", "atan2Float", (y,x)) - fun exp (r : real) : real = prim ("expFloat", "expFloat", r) - fun pow (x : real, y : real) : real = prim ("powFloat", "powFloat", (x,y)) - fun real (x : int) : real = prim ("realInt", "realInt", x) - fun floor (x : real) : int = prim ("floorFloat", "floorFloat", x) (* may raise Overflow *) -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun concat (ss : string list) : string = prim ("implodeStringML", "implodeStringProfilingML", ss) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) +type unit = unit +type exn = exn +type 'a ref = 'a ref + +exception Bind = Bind +exception Match = Match +exception Subscript +exception Size +exception Overflow = Overflow +exception Domain +exception Div = Div +exception Chr +exception Fail of string + +fun !(x: 'a ref): 'a = prim ("!", x) +fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) +fun (a:real) / (b:real) : real = prim ("divFloat", (a,b)) +fun sqrt (r : real) : real = prim ("sqrtFloat", r) +fun sin (r : real) : real = prim ("sinFloat", r) +fun cos (r : real) : real = prim ("cosFloat", r) +fun tan r = sin r / cos r +fun atan (r : real) : real = prim ("atanFloat", r) +fun asin (a : real) : real = prim ("asinFloat", a) +fun acos (a : real) : real = prim ("acosFloat", a) +fun atan2 (y : real, x : real) : real = prim ("atan2Float", (y,x)) +fun exp (r : real) : real = prim ("expFloat", r) +fun pow (x : real, y : real) : real = prim ("powFloat", (x,y)) +fun real (x : int) : real = prim ("realInt", x) +fun floor (x : real) : int = prim ("floorFloat", x) (* may raise Overflow *) +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) fun str (c : char) : string = implode [c] -fun size (s:string): int = prim ("sizeStringML", "sizeStringML", s) -fun chr (i : int) : char = prim ("chrCharML", "chrCharML", (i, Chr)) -fun ord (c : char) : int = prim ("id", "id", c) -fun print (x:string):unit = prim("printStringML","printStringML",x) - fun append [] ys = ys - | append (x::xs) ys = x :: append xs ys - fun xs @ ys = append xs ys +fun size (s : string) : int = prim ("__bytetable_size", s) +fun chr (i : int) : char = prim ("chrCharML", (i, Chr)) +fun ord (c : char) : int = prim ("id", c) +fun print (x:string):unit = prim("printStringML",x) +fun append [] ys = ys + | append (x::xs) ys = x :: append xs ys +fun xs @ ys = append xs ys fun not true = false - | not false = true + | not false = true fun (f o g) x = f(g x) - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) -fun eq_integer (x: int, y: int): bool = prim ("=", "=", (x, y)) -fun eq_string (x: string, y: string): bool = prim("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) +fun eq_integer (x: int, y: int): bool = prim ("=", (x, y)) +fun eq_string (x: string, y: string): bool = prim("=", (x, y)) fun map f [] = [] - | map f (x::xs) = f x :: map f xs + | map f (x::xs) = f x :: map f xs fun revAcc [] ys = ys - | revAcc (x::xs) ys = revAcc xs (x::ys) + | revAcc (x::xs) ys = revAcc xs (x::ys) fun rev xs = revAcc xs [] -(*exception Overflow*) - fun digit n = chr(ord #"0" + n) fun digits(n,acc) = if n >=0 andalso n<=9 then digit n:: acc else digits (n div 10, digit(n mod 10) :: acc) -fun int_to_string(n) = +fun int_to_string(n) = if n<0 then implode(#"~"::digits(~n,[])) else implode(digits(n,[])) - exception Hd fun hd [] = raise Hd | hd (x::xs) = x @@ -84,36 +81,36 @@ structure Array = (* Interface as in SML/NJ *) struct *) - infix sub +infix sub - type 'a array = 'a ref list +type 'a array = 'a ref list - exception Size +exception Size - exception Subscript +exception Subscript - fun tabulate' (i,f) = - let fun tab j = if j < i then f j :: tab (j+1) else nil - in if i < 0 then raise Size else (tab 0) - end +fun tabulate' (i,f) = + let fun tab j = if j < i then f j :: tab (j+1) else nil + in if i < 0 then raise Size else (tab 0) + end - fun array (n, x) = tabulate' (n, fn _ => ref x) +fun array (n, x) = tabulate' (n, fn _ => ref x) - fun arrayoflist l = map ref l +fun arrayoflist l = map ref l - fun tabulate (n, f) = tabulate' (n, fn x => ref(f x)) +fun tabulate (n, f) = tabulate' (n, fn x => ref(f x)) - fun sub'(nil,i) = raise Subscript - | sub' (a::r,i) = if i > 0 then sub' (r,i-1) - else if i < 0 then raise Subscript - else a +fun sub'(nil,i) = raise Subscript + | sub' (a::r,i) = if i > 0 then sub' (r,i-1) + else if i < 0 then raise Subscript + else a - fun op sub (a, i) = !(sub'(a,i)) +fun op sub (a, i) = !(sub'(a,i)) - fun update (a, i, v) = sub'(a, i) := v +fun update (a, i, v) = sub'(a, i) := v - fun length [] = 0 - | length (x::xs) = 1 + length xs +fun length [] = 0 + | length (x::xs) = 1 + length xs (* end (* Array *) @@ -166,7 +163,7 @@ fun nthtail ([],_) = raise NthTail fun exists p [] = false | exists p (x::xs) = p x orelse exists p xs -(* +(* end; (* List *) *) @@ -193,7 +190,7 @@ structure Array2 : sig type 'a array2 = {size : (int*int), value : 'a array} exception Subscript = Subscript fun index22 ((i1:int,i2:int),(s1,s2)) = - if i1>=0 andalso i1=0 andalso i2=0 andalso i1=0 andalso i20 andalso endd>=start then + if delta>0 andalso endd>=start then let fun f x = if x > endd then () else (body x; f(x+delta)) in f start end @@ -245,20 +242,20 @@ fun from(n,m) = if n>m then [] else n::from(n+1,m) fun flatten [] = [] | flatten (x::xs) = x @ flatten xs fun pow(x:real,y:int) = if y=0 then 1.0 else x * pow(x,y-1) -fun array2(bounds as ((l1,u1),(l2,u2)),v) = +fun array2(bounds as ((l1,u1),(l2,u2)),v) = (array22((u1-l1+1, u2-l2+1),v), bounds) -fun sub2((A,((lb1:int,ub1:int),(lb2:int,ub2:int))),(k,l)) = - sub22(A, (k-lb1, l-lb2)) +fun sub2((A,((lb1:int,ub1:int),(lb2:int,ub2:int))),(k,l)) = + sub22(A, (k-lb1, l-lb2)) fun update2((A,((lb1,_),(lb2,_))),(k,l), v) = update22(A,(k-lb1,l-lb2),v) fun bounds2(_,b) = b fun printarray2 (A as (M:real array2,((l1,u1),(l2,u2)))) = for {from=l1,step=1,to=u1} (fn i => (print "["; - for {from=l2,step=1,to=u2-1} (fn j => + for {from=l2,step=1,to=u2-1} (fn j => print ( (* makestring(sub2(A,(i,j))) ^ *) ", ")); print ( (* makestring (sub2(A,(i,u2))) ^ *) "]\n"))) fun array1((l,u),v) = (array(u-l+1,v),(l,u)) -fun sub1((A,(l:int,u:int)),i:int) = (op sub)(A,i-l) +fun sub1((A,(l:int,u:int)),i:int) = (op sub)(A,i-l) fun update1((A,(l,_)),i,v) = update(A,i-l,v) fun bounds1(_,b) = b @@ -267,31 +264,31 @@ fun bounds1(_,b) = b *) val grid_size = ((2,grid_max), (2,grid_max)) -fun north (k,l) = (k-1,l) -fun south (k,l) = (k+1,l) +fun north (k,l) = (k-1,l) +fun south (k,l) = (k+1,l) fun east (k,l) = (k,l+1) fun west (k,l) = (k,l-1) val northeast = north o east val southeast = south o east -val northwest = north o west +val northwest = north o west val southwest = south o west type dir = int * int -> int * int -val farnorth : dir = north o north +val farnorth : dir = north o north val farsouth : dir = south o south -val fareast : dir = east o east +val fareast : dir = east o east val farwest : dir = west o west fun zone_A(k,l) = (k,l) fun zone_B(k,l) = (k+1,l) -fun zone_C(k,l) = (k+1,l+1) +fun zone_C(k,l) = (k+1,l+1) fun zone_D(k,l) = (k,l+1) -val zone_corner_northeast = north +val zone_corner_northeast = north val zone_corner_northwest = northwest fun zone_corner_southeast zone = zone val zone_corner_southwest = west @@ -318,18 +315,18 @@ fun for_interior_zones f = for {from=lmin+1, step=1, to=lmax} (fn l => f (k,l))) fun map_interior_nodes f = - flatten(map (fn k => (map (fn l => f (k,l)) + flatten(map (fn k => (map (fn l => f (k,l)) (from(lmin,lmax)))) (from(kmin,kmax))) fun map_interior_zones f = - flatten(map (fn k => (map (fn l => f (k,l)) + flatten(map (fn k => (map (fn l => f (k,l)) (from(lmin+1,lmax)))) (from(kmin+1,kmax))) fun for_north_ward_interior_zones f = for {from=kmax, step= ~1, to=kmin+1} (fn k => for {from=lmin+1, step=1, to=lmax} (fn l => f (k,l))) -fun for_west_ward_interior_zones f = +fun for_west_ward_interior_zones f = for {from=kmin+1, step=1, to=kmax} (fn k => for {from=lmax, step= ~1, to=lmin+1} (fn l => f (k,l))) @@ -341,7 +338,7 @@ fun for_west_zones f = for {from=kmin+1, step=1, to=kmax+1}(fn k => f (k,lmin)) type 'a reflect_dir = int * int -> {size: int * int, value: 'a ref list} * ((int * int) * (int * int)) -> 'a - + fun reflect dir node A = sub2(A, dir node) val reflect_north : real reflect_dir = reflect north val reflect_south : real reflect_dir = reflect south @@ -352,7 +349,7 @@ fun for_north_nodes f = for {from=lmin, step=1, to=lmax-1} (fn l => f (kmin-1,l)) fun for_south_nodes f = for {from=lmin, step=1, to=lmax-1} (fn l => f (kmax+1,l)) -fun for_east_nodes f = +fun for_east_nodes f = for {from=kmin, step=1, to=kmax-1} (fn k => f (k,lmax+1)) fun for_west_nodes f = for {from=kmin, step=1, to=kmax-1} (fn k => f (k,lmin-1)) @@ -436,7 +433,7 @@ fun make_position_matrix interior_function = val zb = zx - zax + omega*zyx in (rb, zb) end - + fun reflect_node (x_dir, y_dir, a_dir, node) = let val rx = reflect x_dir node r' val zx = reflect x_dir node z' @@ -455,7 +452,7 @@ fun make_position_matrix interior_function = for_west_nodes (fn n => u2(reflect_node(east, southeast, fareast, n)) n); u2 (reflect_node(south, southwest, farsouth, west_of_north_east)) west_of_north_east; - u2 (reflect_node(north, northwest, farnorth, west_of_south_east)) + u2 (reflect_node(north, northwest, farnorth, west_of_south_east)) west_of_south_east; u2 (reflect_node(west, northwest, farwest, north_of_south_east)) north_of_south_east; @@ -468,7 +465,7 @@ fun make_position_matrix interior_function = u2 (reflect_node(southeast, south, farsouth, north_west_corner)) north_west_corner; u2 (reflect_node(northeast, east, fareast, south_west_corner)) - south_west_corner; + south_west_corner; (r',z') end @@ -529,23 +526,23 @@ fun make_velocity((u,w),(r,z),p,q,alpha,rho,delta_t: real) = fun make_position ((r,z),delta_t:real,(u',w')) = - let fun interior_position node = - (sub2(r,node) + delta_t*sub2(u',node), + let fun interior_position node = + (sub2(r,node) + delta_t*sub2(u',node), sub2(z,node) + delta_t*sub2(w',node)) in make_position_matrix interior_position end - + fun make_area_density_volume(rho, s, x') = let val alpha' = array2(dimension_all_zones, 0.0) val s' = array2(dimension_all_zones, 0.0) val rho' = array2(dimension_all_zones, 0.0) - fun interior_area zone = + fun interior_area zone = let val (area, vol) = zone_area_vol (x', zone) val density = sub2(rho,zone)*sub2(s,zone) / vol in (area,vol,density) end - fun reflect_area_vol_density reflect_function = + fun reflect_area_vol_density reflect_function = (reflect_function alpha',reflect_function s',reflect_function rho') fun update_asr (zone,(a,s,r)) = (update2(alpha',zone,a); update2(s',zone,s); @@ -561,27 +558,27 @@ fun make_area_density_volume(rho, s, x') = for_west_zones (fn zone => r_area_vol_den(reflect_east, zone)); for_north_zones (fn zone => r_area_vol_den(reflect_south, zone)); (alpha', rho', s') - end + end (* * Artifical Viscosity (page 11) *) -fun make_viscosity(p,(u',w'),(r',z'), alpha',rho') = +fun make_viscosity(p,(u',w'),(r',z'), alpha',rho') = let fun interior_viscosity zone = - let fun upper_del f = - 0.5 * ((sub2(f,zone_corner_southeast zone) - + let fun upper_del f = + 0.5 * ((sub2(f,zone_corner_southeast zone) - sub2(f,zone_corner_northeast zone)) + - (sub2(f,zone_corner_southwest zone) - + (sub2(f,zone_corner_southwest zone) - sub2(f,zone_corner_northwest zone))) - fun lower_del f = - 0.5 * ((sub2(f,zone_corner_southeast zone) - + fun lower_del f = + 0.5 * ((sub2(f,zone_corner_southeast zone) - sub2(f,zone_corner_southwest zone)) + - (sub2(f,zone_corner_northeast zone) - + (sub2(f,zone_corner_northeast zone) - sub2(f,zone_corner_northwest zone))) val xi = pow(upper_del r',2) + pow(upper_del z',2) val eta = pow(lower_del r',2) + pow(lower_del z',2) - val upper_disc = (upper_del r')*(lower_del w') - + val upper_disc = (upper_del r')*(lower_del w') - (upper_del z')*(lower_del u') val lower_disc = (upper_del u')*(lower_del z') - (upper_del w') * (lower_del r') @@ -590,7 +587,7 @@ fun make_viscosity(p,(u',w'),(r',z'), alpha',rho') = val gamma = 1.6 val speed_of_sound = gamma*sub2(p,zone)/sub2(rho',zone) val ubar = pow(upper_ubar,2) + pow(lower_ubar,2) - val viscosity = + val viscosity = sub2(rho',zone)*(1.5*ubar + 0.5*speed_of_sound*(sqrt ubar)) val length = sqrt(pow(upper_del r',2) + pow(lower_del r',2)) val courant_delta = 0.5* sub2(alpha',zone)/(speed_of_sound*length) @@ -600,7 +597,7 @@ fun make_viscosity(p,(u',w'),(r',z'), alpha',rho') = val d = array2(dimension_all_zones, 0.0) fun reflect_viscosity_cdelta (direction, zone) = sub2(q',direction zone) * sub1(qb, sub2(nbc,zone)) - fun do_zones (dir,zone) = + fun do_zones (dir,zone) = update2(q',zone,reflect_viscosity_cdelta (dir,zone)) in for_interior_zones (fn zone => let val (qv,dv) = interior_viscosity zone @@ -611,7 +608,7 @@ fun make_viscosity(p,(u',w'),(r',z'), alpha',rho') = for_east_zones (fn zone => do_zones(west,zone)); for_west_zones (fn zone => do_zones(east,zone)); for_north_zones (fn zone => do_zones(south,zone)); - (q', d) + (q', d) end (* @@ -623,7 +620,7 @@ fun polynomial(G,degree,rho_table,theta_table,rho_value,theta_value) = let val (low, high) = bounds1 table fun search_down i = if value > sub1(table,i-1) then i else search_down (i-1) - in + in if value>sub1(table,high) then high+1 else if value <= sub1(table,low) then low else search_down high @@ -638,14 +635,14 @@ fun polynomial(G,degree,rho_table,theta_table,rho_value,theta_value) = (from (0,degree))) end fun zonal_pressure (rho_value:real, theta_value:real) = - let val (G,degree,rho_table,theta_table) = + let val (G,degree,rho_table,theta_table) = extract_pressure_tables_from_constants in polynomial(G, degree, rho_table, theta_table, rho_value, theta_value) end -fun zonal_energy (rho_value, theta_value) = - let val (G, degree, rho_table, theta_table) = +fun zonal_energy (rho_value, theta_value) = + let val (G, degree, rho_table, theta_table) = extract_energy_tables_from_constants in polynomial(G, degree, rho_table, theta_table, rho_value, theta_value) end @@ -655,7 +652,7 @@ val tiny = 0.000001 fun newton_raphson (f,x) = let fun iter (x,fx) = - if fx > tiny then + if fx > tiny then let val fxdx = f(x+dx) val denom = fxdx - fx in if denom < tiny then iter(x,tiny) @@ -704,11 +701,11 @@ fun make_temperature(p,epsilon,rho,theta,rho_prime,q_prime) = *) fun make_cc(alpha_prime, theta_hat) = - let fun interior_cc zone = + let fun interior_cc zone = (0.0001 * pow(sub2(theta_hat,zone),2) * (sqrt (abs(sub2(theta_hat,zone)))) / sub2(alpha_prime,zone)) handle Sqrt => (print ("" (*Real.makestring (sub2(theta_hat, zone))*)); - print ("\nzone =(" (* ^ makestring (#1 zone) *) ^ "," ^ + print ("\nzone =(" (* ^ makestring (#1 zone) *) ^ "," ^ (* makestring (#2 zone) ^ *) ")\n"); printarray2 theta_hat; raise Sqrt) @@ -718,12 +715,12 @@ fun make_cc(alpha_prime, theta_hat) = for_south_zones(fn zone => update2(cc,zone, reflect_north zone cc)); for_west_zones(fn zone => update2(cc,zone,reflect_east zone cc)); for_east_zones(fn zone => update2(cc,zone,reflect_west zone cc)); - for_north_zones(fn zone => update2(cc,zone, reflect_south zone cc)); + for_north_zones(fn zone => update2(cc,zone, reflect_south zone cc)); cc end fun make_sigma(deltat, rho_prime, alpha_prime) = - let fun interior_sigma zone = + let fun interior_sigma zone = sub2(rho_prime,zone)*sub2(alpha_prime,zone)*specific_heat/ deltat val M = array2(dimension_interior_zones, 0.0) fun ohandle zone = @@ -732,8 +729,8 @@ fun make_sigma(deltat, rho_prime, alpha_prime) = print ( (* makestring specific_heat ^ *) " "); print ( (* makestring deltat ^ *) "\n"); raise Overflow) - - in if !trace + + in if !trace then print ("\t\tmake_sigma:deltat = " (* ^ makestring deltat *) ^ "\n") else (); (*** for_interior_zones(fn zone => update2(M,zone, interior_sigma zone)) **) @@ -765,12 +762,12 @@ fun make_ab(theta, sigma, Gamma, preceding) = val b = array2(dimension_all_zones, 0.0) fun interior_ab zone = let val denom = sub2(sigma, zone) + sub2(Gamma, zone) + - sub2(Gamma, preceding zone) * + sub2(Gamma, preceding zone) * (1.0 - sub2(a, preceding zone)) val nume1 = sub2(Gamma,zone) val nume2 = sub2(Gamma,preceding zone)*sub2(b,preceding zone) + sub2(sigma,zone) * sub2(theta,zone) - in (nume1/denom, nume2 / denom) + in (nume1/denom, nume2 / denom) end val f = fn zone => update2(b,zone,sub2(theta,zone)) in @@ -787,7 +784,7 @@ fun make_ab(theta, sigma, Gamma, preceding) = fun make_theta (a, b, succeeding, int_zones) = let val theta = array2(dimension_all_zones, constant_heat_source) - fun interior_theta zone = + fun interior_theta zone = sub2(a,zone) * sub2(theta,succeeding zone)+ sub2(b,zone) in int_zones (fn (k,l) => update2(theta, (k,l), interior_theta (k,l))); @@ -827,8 +824,8 @@ fun compute_heat_conduction(theta_hat, deltat, x', alpha', rho') = *) fun make_pressure(rho', theta') = let val p = array2(dimension_all_zones, 0.0) - fun boundary_p(direction, zone) = - sub1(pbb, sub2(nbc, zone)) + + fun boundary_p(direction, zone) = + sub1(pbb, sub2(nbc, zone)) + sub1(pb,sub2(nbc,zone)) * sub2(p, direction zone) in for_interior_zones @@ -866,12 +863,12 @@ fun make_energy(rho', theta') = fun compute_energy_error ((u',w'),(r',z'),p',q',epsilon',theta',rho',alpha', Gamma_k,Gamma_l,deltat) = let fun mass zone = sub2(rho',zone) * sub2(alpha',zone):real - val internal_energy = + val internal_energy = sum_list (map_interior_zones (fn z => sub2(epsilon',z)*(mass z))) fun kinetic node = - let val average_mass = 0.25*((mass (zone_A node)) + + let val average_mass = 0.25*((mass (zone_A node)) + (mass (zone_B node)) + - (mass (zone_C node)) + + (mass (zone_C node)) + (mass (zone_D node))) val v_square = pow(sub2(u',node),2) + pow(sub2(w',node),2) in 0.5 * average_mass * v_square @@ -891,7 +888,7 @@ fun compute_energy_error ((u',w'),(r',z'),p',q',epsilon',theta',rho',alpha', end fun from(n,m) = if n > m then [] else n::from(n+1,m) - val north_line = + val north_line = map (fn l => (west(kmin,l),(kmin,l))) (from(lmin+1,lmax)) val south_line = map (fn l => (west(kmax,l),(kmax,l))) (from(lmin+1,lmax)) @@ -910,7 +907,7 @@ fun compute_energy_error ((u',w'),(r',z'),p',q',epsilon',theta',rho',alpha', deltat * sub2(Gamma, zone1) * (sub2(theta',zone1) - sub2(theta',zone2)) val north_flow = - let val k = kmin+1 + let val k = kmin+1 in map (fn l => (north(k,l),(k,l))) (from(lmin+1,lmax)) end val south_flow = @@ -931,7 +928,7 @@ fun compute_energy_error ((u',w'),(r',z'),p',q',epsilon',theta',rho',alpha', val h3 = sum_list (map (heat_flow Gamma_l) east_flow) val h4 = sum_list (map (heat_flow Gamma_l) west_flow) val boundary_heat = h1 + h2 + h3 + h4 - in + in internal_energy + kinetic_energy - boundary_heat - boundary_work end @@ -939,7 +936,7 @@ fun compute_time_step(d, theta_hat, theta') = let val deltat_courant = min_list (map_interior_zones (fn zone => sub2(d,zone))) val deltat_conduct = - max_list (map_interior_zones + max_list (map_interior_zones (fn z => (abs(sub2(theta_hat,z) - sub2(theta', z))/ sub2(theta_hat,z)))) val deltat_minimum = min (deltat_courant, deltat_conduct) @@ -947,8 +944,8 @@ fun compute_time_step(d, theta_hat, theta') = end -fun compute_initial_state () = - let +fun compute_initial_state () = + let val v = (all_zero_nodes, all_zero_nodes) val x = let fun interior_position (k,l) = let val pi = 3.1415926535898 @@ -959,19 +956,19 @@ fun compute_initial_state () = end in make_position_matrix interior_position end - val (alpha,s) = - let val (alpha_prime,s_prime) = + val (alpha,s) = + let val (alpha_prime,s_prime) = let val A = array2(dimension_all_zones, 0.0) val S = array2(dimension_all_zones, 0.0) fun reflect_area_vol f = (f A, f S) - fun u2 (f,z) = + fun u2 (f,z) = let val (a,s) = reflect_area_vol(f z) in update2(A,z,a); update2(S,z,s) end in - for_interior_zones + for_interior_zones (fn z => let val (a,s) = zone_area_vol(x, z) in update2(A,z,a); update2(S,z,s) @@ -987,7 +984,7 @@ fun compute_initial_state () = val rho = let val R = array2(dimension_all_zones, 0.0) in for_all_zones (fn z => update2(R,z,1.4)); R end - val theta = + val theta = let val T = array2(dimension_all_zones, constant_heat_source) in for_interior_zones(fn z => update2(T,z,0.0001)); T @@ -1008,9 +1005,9 @@ fun compute_next_state state = val v' = make_velocity (v, x, p, q, alpha, rho, deltat) val _ = if !trace then print "done make_velocity\n" else () - val x' = make_position(x,deltat,v') + val x' = make_position(x,deltat,v') handle _ => ( (* old: handle Overflow => *) - printarray2 (#1 v'); + printarray2 (#1 v'); printarray2 (#2 v'); raise Overflow) val _ = if !trace then print "done make_position\n" else () @@ -1036,9 +1033,9 @@ fun compute_next_state state = val epsilon' = make_energy (rho', theta') val _ = if !trace then print "done make_energy\n" else () - val c' = compute_energy_error (v', x', p', q', epsilon', theta', rho', + val c' = compute_energy_error (v', x', p', q', epsilon', theta', rho', alpha', Gamma_k, Gamma_l, deltat) - val _ = if !trace then print "done compute_energy_error\n" + val _ = if !trace then print "done compute_energy_error\n" else () val deltat' = compute_time_step (d, theta_hat, theta') @@ -1047,7 +1044,7 @@ fun compute_next_state state = (v',x',alpha',s',rho',p',q', epsilon',theta',deltat',c') end -fun runit () = +fun runit () = let fun iter (i,state) = if i = 0 then state else (print "."; iter(i-1, compute_next_state state)) @@ -1062,7 +1059,7 @@ fun print_state ((v1,v2),(r,z),alpha,s,rho,p,q,epsilon,theta,deltat,c) = ( print "\n\nPosition matrices = \n"; printarray2 r; print "\n\n"; printarray2 z; - + print "\n\nalpha = \n"; printarray2 alpha; @@ -1077,7 +1074,7 @@ fun print_state ((v1,v2),(r,z),alpha,s,rho,p,q,epsilon,theta,deltat,c) = ( print "\n\nq = \n"; printarray2 q; - + print "\n\nepsilon = \n"; printarray2 epsilon; @@ -1112,4 +1109,3 @@ structure Main = Simple(val grid_max=100 val step_count=1); *) val _ = doit(); - diff --git a/test_dev/kittmergesort_no_basislib.out.ok b/test_dev/kittmergesort_no_basislib.out.ok new file mode 100644 index 000000000..163c539be --- /dev/null +++ b/test_dev/kittmergesort_no_basislib.out.ok @@ -0,0 +1,6 @@ + + List generated +Doing tmergesort... +Sorted 25000 + numbers + diff --git a/test_dev/kittmergesort_no_basislib.sml b/test_dev/kittmergesort_no_basislib.sml index 6bf01cecd..890105fcc 100644 --- a/test_dev/kittmergesort_no_basislib.sml +++ b/test_dev/kittmergesort_no_basislib.sml @@ -2,10 +2,10 @@ (* This is tmergesort taken from Paulson's book , page 99 *) -(* The merge function has been modified slightly, to +(* The merge function has been modified slightly, to traverse and rebuild both arguments fully, even when the one argument is empty. This ensures that both - recursive calls of tmergesort in itself can put their + recursive calls of tmergesort in itself can put their results in regions local to the body of tmergesort. One can show that the maximum number of live list elements @@ -41,31 +41,29 @@ infix 0 before exception Domain exception Div = Div exception Chr - exception Fail of string + exception Fail of string -fun (a:real) / (b:real) : real = prim ("divFloat", "divFloat", (a,b)) -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun concat (ss : string list) : string = prim ("implodeStringML", "implodeStringProfilingML", ss) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) +fun (a:real) / (b:real) : real = prim ("divFloat", (a,b)) +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) fun str (c : char) : string = implode [c] -fun size (s:string): int = prim ("sizeStringML", "sizeStringML", s) -fun chr (i : int) : char = prim ("chrCharML", "chrCharML", (i, Chr)) -fun ord (c : char) : int = prim ("id", "id", c) -fun print (x:string):unit = prim("printStringML","printStringML",x) +fun size (s : string) : int = prim ("__bytetable_size", s) +fun chr (i : int) : char = prim ("chrCharML", (i, Chr)) +fun ord (c : char) : int = prim ("id", c) +fun print (x:string):unit = prim("printStringML", x) fun append [] ys = ys | append (x::xs) ys = x :: append xs ys fun xs @ ys = append xs ys -fun real (x : int) : real = prim ("realInt", "realInt", x) -fun floor (x : real) : int = prim ("floorFloat", "floorFloat", x) (* may raise Overflow *) +fun real (x : int) : real = prim ("realInt", x) +fun floor (x : real) : int = prim ("floorFloat", x) (* may raise Overflow *) fun not true = false | not false = true fun (f o g) x = f(g x) - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) - - +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) exception Take and Drop @@ -114,10 +112,9 @@ fun tmergesort [] = [] in merge(tmergesort(take(k, xs)), tmergesort(drop(k, xs))) end - -val result = -let +val result = +let val n = 25000 val xs = snd(randlist(n,1,[])) val _ = print "\n List generated\n" @@ -127,4 +124,3 @@ in tmergesort xs; report("Sorted " ^ int_to_string n ^ " numbers\n") end - diff --git a/test_dev/l1.out.ok b/test_dev/l1.out.ok new file mode 100644 index 000000000..c359e279c --- /dev/null +++ b/test_dev/l1.out.ok @@ -0,0 +1 @@ +It works n gives lhej igenHej \ No newline at end of file diff --git a/test_dev/l1.sml b/test_dev/l1.sml index 05ae1840f..a1a5a9fe9 100644 --- a/test_dev/l1.sml +++ b/test_dev/l1.sml @@ -1,7 +1,7 @@ let infixr 5 :: @ - fun print (s:string) : unit = prim("printStringML", "printStringML", s) - datatype l = + fun print (s:string) : unit = prim("printStringML", s) + datatype l = L of string | LL of string val n = L "It works n gives l" diff --git a/test_dev/list_nh.out.ok b/test_dev/list_nh.out.ok new file mode 100644 index 000000000..d1de576a1 --- /dev/null +++ b/test_dev/list_nh.out.ok @@ -0,0 +1,20 @@ +Num: 1 +::Num: 2 +::Num: 3 +::Num: 4 +::Num: 5 +::[] +str1::str2::str3::str4::str5::[] +Num: 1 +::Num: 2 +::Num: 3 +::Num: 4 +::Num: 5 +::[] +intOK5 +strOK5 +datatypeOKniels +Martin Elsman datatypeOKmartin +noname OK +true OK +false OK diff --git a/test_dev/list_nh.sml b/test_dev/list_nh.sml index fc401444b..5ba66af4d 100644 --- a/test_dev/list_nh.sml +++ b/test_dev/list_nh.sml @@ -1,8 +1,8 @@ let - fun print (s:string):unit = prim ("printStringML","printStringML",s) - fun printNum (s:int):unit = prim ("printNum","printNum",s) + fun print (s:string):unit = prim ("printStringML",s) + fun printNum (s:int):unit = prim ("printNum",s) datatype Name = MARTIN of string @@ -20,7 +20,7 @@ let val _ = print_list print l2 val _ = print_list printNum l1 - val _ = + val _ = case l1 of [] => print "intERROR0\n" | [1] => print "intERROR1\n" @@ -30,7 +30,7 @@ let | [1,2,3,4,5] => print "intOK5\n" | _ => print "intERROR6\n" - val _ = + val _ = case l2 of [] => print "strERROR0\n" | ["str1"] => print "strERROR1\n" @@ -71,4 +71,4 @@ let in () -end; \ No newline at end of file +end; diff --git a/test_dev/p1.sml b/test_dev/p1.sml new file mode 100644 index 000000000..4ef7908a6 --- /dev/null +++ b/test_dev/p1.sml @@ -0,0 +1,13 @@ +val () = +let +(* infix - + infix 3 := o + + fun printNum (i:int) : unit = prim("printNum", "printNum", i) + fun f 0 = printNum free + | f n = (printNum n;f (n-1)) +*) + fun print (s:string) : unit = prim("printStringML", s) +in + print "Hello\n" +end diff --git a/test_dev/professor_game.out.ok b/test_dev/professor_game.out.ok new file mode 100644 index 000000000..94a488dd0 --- /dev/null +++ b/test_dev/professor_game.out.ok @@ -0,0 +1,230 @@ +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +Professor_game - LOG with message: solution found +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS || BROWN_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || GREEN_JACKET || BROWN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || BROWN_JACKET || GREEN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS | +| BLUE_JACKET || RED_JACKET || RED_JACKET || BLUE_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS || BROWN_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || GREEN_JACKET || BROWN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || BROWN_JACKET || GREEN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS | +| BLUE_JACKET || RED_JACKET || RED_JACKET || BLUE_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS || BROWN_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || GREEN_JACKET || GREEN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || BROWN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS| +| BLUE_JACKET || BLUE_JACKET || RED_JACKET || RED_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS || BROWN_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || GREEN_JACKET || GREEN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || BROWN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS| +| BLUE_JACKET || BLUE_JACKET || RED_JACKET || RED_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || GREEN_JACKET || BROWN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || BROWN_JACKET || GREEN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS | +| BLUE_JACKET || RED_JACKET || RED_JACKET || BLUE_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || GREEN_JACKET || GREEN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || BROWN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS| +| BLUE_JACKET || BLUE_JACKET || RED_JACKET || RED_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || GREEN_JACKET || GREEN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || BROWN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS| +| BLUE_JACKET || BLUE_JACKET || RED_JACKET || RED_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || BROWN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || GREEN_JACKET || BROWN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || BROWN_JACKET || GREEN_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS | +| BLUE_JACKET || RED_JACKET || RED_JACKET || BLUE_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || GREEN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || BROWN_JACKET || BROWN_JACKET || BLUE_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || GREEN_JACKET || GREEN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| RED_JACKET || RED_JACKET || BLUE_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + +New board ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BLUE_TROUSERS || BROWN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS | +| BROWN_JACKET || GREEN_JACKET || GREEN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|BLUE_JACKET RED_TROUSERS ||RED_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| GREEN_JACKET || BROWN_JACKET || BROWN_JACKET || BLUE_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| GREEN_TROUSERS || BROWN_TROUSERS || BROWN_TROUSERS || BLUE_TROUSERS | +|RED_JACKET GREEN_TROUSERS||GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| BROWN_JACKET || GREEN_JACKET || GREEN_JACKET || BROWN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ +| BROWN_TROUSERS || GREEN_TROUSERS || GREEN_TROUSERS || BROWN_TROUSERS | +|GREEN_JACKET BLUE_TROUSERS ||BLUE_JACKET BROWN_TROUSERS||BROWN_JACKET RED_TROUSERS ||RED_JACKET GREEN_TROUSERS| +| RED_JACKET || RED_JACKET || BLUE_JACKET || GREEN_JACKET | ++--------------------------------++--------------------------------++--------------------------------++--------------------------------+ + diff --git a/test_dev/professor_game.sml b/test_dev/professor_game.sml index 193bbf504..817179f37 100644 --- a/test_dev/professor_game.sml +++ b/test_dev/professor_game.sml @@ -17,91 +17,89 @@ infix 4 = <> > >= < <= infix 3 := o infix 0 before - - type unit = unit - type exn = exn - type 'a ref = 'a ref - - exception Bind = Bind - exception Match = Match - exception Subscript - exception Size - exception Overflow = Overflow - exception Domain - exception Div = Div - exception Chr - exception Fail of string - -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun concat (ss : string list) : string = prim ("implodeStringML", "implodeStringProfilingML", ss) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) +type unit = unit +type exn = exn +type 'a ref = 'a ref + +exception Bind = Bind +exception Match = Match +exception Subscript +exception Size +exception Overflow = Overflow +exception Domain +exception Div = Div +exception Chr +exception Fail of string + +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) fun str (c : char) : string = implode [c] -fun size (s:string): int = prim ("sizeStringML", "sizeStringML", s) - - fun append [] ys = ys - | append (x::xs) ys = x :: append xs ys - fun xs @ ys = append xs ys - - exception Die - fun output (s:string):unit = prim ("printStringML","printStringML",s) - - fun die s = (output("Professor_game - DIE with message: " ^ s); - raise Die) - - fun exnName (e: exn) : string = prim("exnNameML", "exnNameProfilingML", e) (* exomorphic by copying *) - fun exnMessage (e: exn) : string = exnName e - - datatype 'a option = NONE | SOME of 'a - exception Option - fun getOpt (NONE, a) = a - | getOpt (SOME a, b) = a - fun isSome NONE = false - | isSome _ = true - fun valOf (SOME a) = a - | valOf _ = raise Option - - datatype order = LESS | EQUAL | GREATER - - fun !(x: 'a ref): 'a = prim ("!", "!", x) - fun (x: 'a ref) := (y: 'a): unit = prim (":=", ":=", (x, y)) - fun (f o g) x = f(g x) - fun a before () = a - fun ignore (a) = () +fun size (s : string) : int = prim ("__bytetable_size", s) + +fun append [] ys = ys + | append (x::xs) ys = x :: append xs ys +fun xs @ ys = append xs ys + +exception Die +fun output (s:string):unit = prim ("printStringML",s) + +fun die s = (output("Professor_game - DIE with message: " ^ s); + raise Die) + +fun exnName (e: exn) : string = prim("exnNameML", e) (* exomorphic by copying *) +fun exnMessage (e: exn) : string = exnName e + +datatype 'a option = NONE | SOME of 'a +exception Option +fun getOpt (NONE, a) = a + | getOpt (SOME a, b) = a +fun isSome NONE = false + | isSome _ = true +fun valOf (SOME a) = a + | valOf _ = raise Option + +datatype order = LESS | EQUAL | GREATER + +fun !(x: 'a ref): 'a = prim ("!", x) +fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) +fun (f o g) x = f(g x) +fun a before () = a +fun ignore (a) = () (* Top-level identifiers; Some are here - some are introduced later *) -fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) fun not true = false | not false = true fun a <> b = not (a = b) -fun print (s:string) : unit = prim("printStringML", "printStringML", s) -fun printNum (n:int):unit = prim("printNum","printNum",n) +fun print (s:string) : unit = prim("printStringML", s) +fun printNum (n:int):unit = prim("printNum", n) fun log s = output("Professor_game - LOG with message: " ^ s ^ "\n") - fun map f [] = [] - | map f (x::xs) = f x :: map f xs +fun map f [] = [] + | map f (x::xs) = f x :: map f xs - fun size xs = +fun size xs = let fun acc [] k = k - | acc (x::xr) k = acc xr (k+1) - in acc xs 0 + | acc (x::xr) k = acc xr (k+1) + in acc xs 0 end - fun chr (i : int) : char = prim ("chrCharML", "chrCharML", (i, Chr)) - fun ord (c : char) : int = prim ("id", "id", c) - +fun chr (i : int) : char = prim ("chrCharML", (i, Chr)) +fun ord (c : char) : int = prim ("id", c) - fun digit n = chr(ord #"0" + n) - fun digits(n,acc) = +fun digit n = chr(ord #"0" + n) +fun digits(n,acc) = if n >=0 andalso n<=9 then digit n:: acc else digits (n div 10, digit(n mod 10) :: acc) - fun int_to_string(n) = if n >= 0 then implode(digits(n,[])) - else "~" ^ int_to_string(~n) +fun int_to_string(n) = if n >= 0 then implode(digits(n,[])) + else "~" ^ int_to_string(~n) val debug_flag = false fun debug s = if debug_flag then @@ -121,11 +119,11 @@ fun min (n:int) (m:int) = datatype clothes = RED_JACKET | RED_TROUSERS - | GREEN_JACKET + | GREEN_JACKET | GREEN_TROUSERS - | BLUE_JACKET + | BLUE_JACKET | BLUE_TROUSERS - | BROWN_JACKET + | BROWN_JACKET | BROWN_TROUSERS type cart = {top:clothes, @@ -158,7 +156,7 @@ fun add n (row, col) = * PrettyPrinting * *--------------------------*) -fun pp_clothes RED_JACKET = "RED_JACKET " +fun pp_clothes RED_JACKET = "RED_JACKET " | pp_clothes RED_TROUSERS = "RED_TROUSERS " | pp_clothes GREEN_JACKET = "GREEN_JACKET " | pp_clothes GREEN_TROUSERS = "GREEN_TROUSERS" @@ -191,7 +189,7 @@ fun pp_row carts = pp_vertical bots; pp_board_line ()) end - + exception Sub' @@ -205,7 +203,7 @@ exception Sub' handle Sub' => raise Subscript fun nth n l = l sub n - handle Subscript => raise Subscript + handle Subscript => raise Subscript fun split (l, 0) = ([], l) | split (x::xs, m) = @@ -215,19 +213,19 @@ exception Sub' | split ([], _) = raise Sub' fun splitNth n l = - if n < 0 then raise Subscript + if n < 0 then raise Subscript else split (l, n) handle Sub' => raise Subscript fun pp_carts [] = () - | pp_carts carts = + | pp_carts carts = let val (left, right) = splitNth (min colNo (size carts)) carts in (pp_row left; pp_carts right) end - + fun pp_board (board as (row, col, carts)) = (output("New board\n"); pp_carts carts; pp_newline()) @@ -272,17 +270,17 @@ fun matchLeft (row, col, carts) cart = (if col > 0 then let val leftCart = nth ((findPlaceInList(row, col))-1) carts - val _ = debug ("matchLeft with leftcart: " ^ - (pp_clothes (findRight leftCart)) ^ + val _ = debug ("matchLeft with leftcart: " ^ + (pp_clothes (findRight leftCart)) ^ " and rightcart: " ^ (pp_clothes (findLeft cart))) in matchClothes (findRight leftCart) (findLeft cart) end else - true) handle Subscript => - die ("matchLeft with error " ^ " and size list " ^ - (int_to_string (size carts)) ^ ",row " ^ (int_to_string row) ^ + true) handle Subscript => + die ("matchLeft with error " ^ " and size list " ^ + (int_to_string (size carts)) ^ ",row " ^ (int_to_string row) ^ ", col " ^ (int_to_string col) ^ " and findPlaceInList " ^ (int_to_string (findPlaceInList(row, col)))) @@ -306,7 +304,7 @@ fun findSol [] [] board sols = (log "solution found"; | findSol (x::rest) alreadyTried (board as (row, col, carts)) sols = let val _ = debug "In findSol" - val sols' = + val sols' = if match board x then let val _ = debug "findSol got a match" @@ -344,4 +342,3 @@ val cartSet = [{top= BLUE_TROUSERS, bot=BROWN_JACKET, left= BLUE_JACKET, right=B val res = findSol cartSet [] emptyBoard [] val _ = pp_boards res - diff --git a/test_dev/r.c b/test_dev/r.c new file mode 100644 index 000000000..1f6c6a3f5 --- /dev/null +++ b/test_dev/r.c @@ -0,0 +1,9 @@ +#include + +double a = 1.8; + +int main() { + double b = 0 - a; + printf("%f\n", b); + return 0; +} diff --git a/test_dev/raise_div.out.ok b/test_dev/raise_div.out.ok new file mode 100644 index 000000000..507cbe9fa --- /dev/null +++ b/test_dev/raise_div.out.ok @@ -0,0 +1 @@ +uncaught exception Div diff --git a/test_dev/raise_div.sml b/test_dev/raise_div.sml new file mode 100644 index 000000000..17252cb22 --- /dev/null +++ b/test_dev/raise_div.sml @@ -0,0 +1 @@ +val () = raise Div diff --git a/test_dev/raise_maybe.sml b/test_dev/raise_maybe.sml new file mode 100644 index 000000000..9c141f607 --- /dev/null +++ b/test_dev/raise_maybe.sml @@ -0,0 +1,5 @@ +val r = ref 5 +val () = + case r of + ref 4 => raise Div + | _ => () diff --git a/test_dev/real0.out.ok b/test_dev/real0.out.ok new file mode 100644 index 000000000..24d2136a5 --- /dev/null +++ b/test_dev/real0.out.ok @@ -0,0 +1,2 @@ +Num: 1.80 +Num: 0.20 diff --git a/test_dev/real0.sml b/test_dev/real0.sml new file mode 100644 index 000000000..2f4d963b6 --- /dev/null +++ b/test_dev/real0.sml @@ -0,0 +1,19 @@ +val _ = +let + infix 6 + - + infixr 5 :: + infix 4 = <> > >= < <= + infix 3 := o + + fun printReal (n:real):unit = prim("printReal",n) + + val a = 1.0 + val b = 0.8 + val c = a + b + val d = a - b +in +(* val _ = printReal a + val _ = printReal b*) + printReal c +; printReal d +end diff --git a/test_dev/real1.out.ok b/test_dev/real1.out.ok new file mode 100644 index 000000000..c0dc837ee --- /dev/null +++ b/test_dev/real1.out.ok @@ -0,0 +1,7 @@ +Num: 1.00 +Num: 2.00 +Num: 3.00 +Num: 4.00 +Num: 3.00 +Num: 0.90 +Num: 1.00 diff --git a/test_dev/real1.sml b/test_dev/real1.sml index a5eb0f0d1..74b8ed036 100644 --- a/test_dev/real1.sml +++ b/test_dev/real1.sml @@ -1,11 +1,11 @@ -val _ = +val _ = let infix 6 + - infixr 5 :: infix 4 = <> > >= < <= infix 3 := o - fun printReal (n:real):unit = prim("printReal","printReal",n) + fun printReal (n:real):unit = prim("printReal",n) val a = 1.0 val b = 2.0 @@ -22,6 +22,6 @@ let val _ = printReal (2.3 - 1.4) -in +in if c > b then printReal 1.0 else printReal ~2.0 end diff --git a/test_dev/real2.out.ok b/test_dev/real2.out.ok new file mode 100644 index 000000000..71ae2fcbd --- /dev/null +++ b/test_dev/real2.out.ok @@ -0,0 +1,11 @@ +Num: 7.00 +Num: 7.00 +Num: 0.00 +Num: 0.00 +True +Num: 7.00 +Num: 7.00 +Num: 0.00 +Num: 0.00 +Ok - +... +OK diff --git a/test_dev/real2.sml b/test_dev/real2.sml index ae3b3b137..3f732f24c 100644 --- a/test_dev/real2.sml +++ b/test_dev/real2.sml @@ -4,26 +4,27 @@ infixr 5 :: @ infix 4 = <> > >= < <= infix 3 := o infix 0 before -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) - fun printReal (n:real):unit = prim("printReal","printReal",n) -fun print (s:string) : unit = prim("printStringML", "printStringML", s) - infix == - val epsilon = 0.000666 - fun r1 == r2 = - let val _ = printReal r1 - val _ = printReal r2 +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) +fun printReal (n:real):unit = prim("printReal",n) +fun print (s:string) : unit = prim("printStringML",s) + +infix == +val epsilon = 0.000666 +fun r1 == r2 = + let val _ = printReal r1 + val _ = printReal r2 val r = (r1 - r2) val _ = printReal r val r_abs = abs r val _ = printReal r_abs in r_abs < epsilon (*no perfect world*) end - fun error b s = print ((if b then "Ok - " else "Error - ") ^ s ^ "...\n") - val b = (4.0 + 3.0 == 7.0) - val _ = if b then print "True" else print "False" - val _ = error (4.0 + 3.0 == 7.0) "+" +fun error b s = print ((if b then "Ok - " else "Error - ") ^ s ^ "...\n") +val b = (4.0 + 3.0 == 7.0) +val _ = if b then print "True\n" else print "False\n" +val _ = error (4.0 + 3.0 == 7.0) "+" - val b = 4.0 < 3.0 +val b = 4.0 < 3.0 - val _ = if b then print "ERROR" else print "OK" +val _ = if b then print "ERROR\n" else print "OK\n" diff --git a/test_dev/real_cmp.out.ok b/test_dev/real_cmp.out.ok new file mode 100644 index 000000000..3ed887fbb --- /dev/null +++ b/test_dev/real_cmp.out.ok @@ -0,0 +1,10 @@ +Num: 1.00 +Num: 0.80 +OK:gt +OK:gt2 +OK:lt +OK:lt2 +OK:lte +OK:lte2 +OK:gte +OK:gte2 diff --git a/test_dev/real_cmp.sml b/test_dev/real_cmp.sml new file mode 100644 index 000000000..1c4742223 --- /dev/null +++ b/test_dev/real_cmp.sml @@ -0,0 +1,27 @@ +val _ = +let + infix 6 + - + infixr 5 :: + infix 4 = <> > >= < <= + infix 3 := o + + fun print (s:string) : unit = prim("printStringML", s) + + fun printReal (n:real):unit = prim("printReal",n) + + val a = 1.0 + val b = 0.8 +in +(* val _ = printReal a + val _ = printReal b*) + printReal a +; printReal b +; if a>b then print "OK:gt\n" else print "ERR:gt\n" +; if a>a then print "ERR:gt2\n" else print "OK:gt2\n" +; if a=b then print "OK:gte\n" else print "ERR:gte\n" +; if a>=a then print "OK:gte2\n" else print "ERR:gte2\n" +end diff --git a/test_dev/real_negabs.out.ok b/test_dev/real_negabs.out.ok new file mode 100644 index 000000000..ba03d0ac0 --- /dev/null +++ b/test_dev/real_negabs.out.ok @@ -0,0 +1,12 @@ +Num: 1.00 +Num: 0.80 +Num: -2.30 +Num: -0.40 +OK:neg1 +OK:neg2 +OK:neg3 +OK:neg4 +OK:abs1 +OK:abs2 +OK:abs3 +OK:abs4 diff --git a/test_dev/real_negabs.sml b/test_dev/real_negabs.sml new file mode 100644 index 000000000..8e6864250 --- /dev/null +++ b/test_dev/real_negabs.sml @@ -0,0 +1,31 @@ +val _ = +let + infix 6 + - + infixr 5 :: + infix 4 = <> > >= < <= + infix 3 := o + + fun print (s:string) : unit = prim("printStringML", s) + + fun printReal (n:real):unit = prim("printReal",n) + + val a = 1.0 + val b = 0.8 + val c = ~2.3 + val d = ~0.4 +in +(* val _ = printReal a + val _ = printReal b*) + printReal a +; printReal b +; printReal c +; printReal d +; if ~d > 0.0 then print "OK:neg1\n" else print "ERR:neg1\n" +; if ~b < 0.0 then print "OK:neg2\n" else print "ERR:neg2\n" +; if ~b > ~0.9 then print "OK:neg3\n" else print "ERR:neg3\n" +; if ~b < ~0.7 then print "OK:neg4\n" else print "ERR:neg4\n" +; if abs c > 2.0 then print "OK:abs1\n" else print "ERR:abs1\n" +; if abs c < 2.5 then print "OK:abs2\n" else print "ERR:abs2\n" +; if abs b > 0.7 then print "OK:abs3\n" else print "ERR:abs3\n" +; if abs b < 0.9 then print "OK:abs4\n" else print "ERR:abs4\n" +end diff --git a/test_dev/ref-int.out.ok b/test_dev/ref-int.out.ok new file mode 100644 index 000000000..0415c8a97 --- /dev/null +++ b/test_dev/ref-int.out.ok @@ -0,0 +1,3025 @@ +Num: 1 +Num: 2 +Num: 3 +Num: 4 +Num: 5 +Num: 6 +Num: 7 +Num: 8 +Num: 9 +Num: 10 +Num: 11 +Num: 10 +Num: 9 +Num: 8 +Num: 7 +Num: 6 +Num: 5 +Num: 4 +Num: 3 +Num: 2 +Num: 1 +Num: 0 +Num: 1 +Num: 2 +Num: 3 +Num: 4 +Num: 5 +Num: 6 +Num: 7 +Num: 8 +Num: 9 +Num: 10 +Num: 11 +Num: 12 +Num: 13 +Num: 14 +Num: 15 +Num: 16 +Num: 17 +Num: 18 +Num: 19 +Num: 20 +Num: 21 +Num: 22 +Num: 23 +Num: 24 +Num: 25 +Num: 26 +Num: 27 +Num: 28 +Num: 29 +Num: 30 +Num: 31 +Num: 32 +Num: 33 +Num: 34 +Num: 35 +Num: 36 +Num: 37 +Num: 38 +Num: 39 +Num: 40 +Num: 41 +Num: 42 +Num: 43 +Num: 44 +Num: 45 +Num: 46 +Num: 47 +Num: 48 +Num: 49 +Num: 50 +Num: 51 +Num: 52 +Num: 53 +Num: 54 +Num: 55 +Num: 56 +Num: 57 +Num: 58 +Num: 59 +Num: 60 +Num: 61 +Num: 62 +Num: 63 +Num: 64 +Num: 65 +Num: 66 +Num: 67 +Num: 68 +Num: 69 +Num: 70 +Num: 71 +Num: 72 +Num: 73 +Num: 74 +Num: 75 +Num: 76 +Num: 77 +Num: 78 +Num: 79 +Num: 80 +Num: 81 +Num: 82 +Num: 83 +Num: 84 +Num: 85 +Num: 86 +Num: 87 +Num: 88 +Num: 89 +Num: 90 +Num: 91 +Num: 92 +Num: 93 +Num: 94 +Num: 95 +Num: 96 +Num: 97 +Num: 98 +Num: 99 +Num: 100 +Num: 101 +Num: 102 +Num: 103 +Num: 104 +Num: 105 +Num: 106 +Num: 107 +Num: 108 +Num: 109 +Num: 110 +Num: 111 +Num: 112 +Num: 113 +Num: 114 +Num: 115 +Num: 116 +Num: 117 +Num: 118 +Num: 119 +Num: 120 +Num: 121 +Num: 122 +Num: 123 +Num: 124 +Num: 125 +Num: 126 +Num: 127 +Num: 128 +Num: 129 +Num: 130 +Num: 131 +Num: 132 +Num: 133 +Num: 134 +Num: 135 +Num: 136 +Num: 137 +Num: 138 +Num: 139 +Num: 140 +Num: 141 +Num: 142 +Num: 143 +Num: 144 +Num: 145 +Num: 146 +Num: 147 +Num: 148 +Num: 149 +Num: 150 +Num: 151 +Num: 152 +Num: 153 +Num: 154 +Num: 155 +Num: 156 +Num: 157 +Num: 158 +Num: 159 +Num: 160 +Num: 161 +Num: 162 +Num: 163 +Num: 164 +Num: 165 +Num: 166 +Num: 167 +Num: 168 +Num: 169 +Num: 170 +Num: 171 +Num: 172 +Num: 173 +Num: 174 +Num: 175 +Num: 176 +Num: 177 +Num: 178 +Num: 179 +Num: 180 +Num: 181 +Num: 182 +Num: 183 +Num: 184 +Num: 185 +Num: 186 +Num: 187 +Num: 188 +Num: 189 +Num: 190 +Num: 191 +Num: 192 +Num: 193 +Num: 194 +Num: 195 +Num: 196 +Num: 197 +Num: 198 +Num: 199 +Num: 200 +Num: 201 +Num: 202 +Num: 203 +Num: 204 +Num: 205 +Num: 206 +Num: 207 +Num: 208 +Num: 209 +Num: 210 +Num: 211 +Num: 212 +Num: 213 +Num: 214 +Num: 215 +Num: 216 +Num: 217 +Num: 218 +Num: 219 +Num: 220 +Num: 221 +Num: 222 +Num: 223 +Num: 224 +Num: 225 +Num: 226 +Num: 227 +Num: 228 +Num: 229 +Num: 230 +Num: 231 +Num: 232 +Num: 233 +Num: 234 +Num: 235 +Num: 236 +Num: 237 +Num: 238 +Num: 239 +Num: 240 +Num: 241 +Num: 242 +Num: 243 +Num: 244 +Num: 245 +Num: 246 +Num: 247 +Num: 248 +Num: 249 +Num: 250 +Num: 251 +Num: 252 +Num: 253 +Num: 254 +Num: 255 +Num: 256 +Num: 257 +Num: 258 +Num: 259 +Num: 260 +Num: 261 +Num: 262 +Num: 263 +Num: 264 +Num: 265 +Num: 266 +Num: 267 +Num: 268 +Num: 269 +Num: 270 +Num: 271 +Num: 272 +Num: 273 +Num: 274 +Num: 275 +Num: 276 +Num: 277 +Num: 278 +Num: 279 +Num: 280 +Num: 281 +Num: 282 +Num: 283 +Num: 284 +Num: 285 +Num: 286 +Num: 287 +Num: 288 +Num: 289 +Num: 290 +Num: 291 +Num: 292 +Num: 293 +Num: 294 +Num: 295 +Num: 296 +Num: 297 +Num: 298 +Num: 299 +Num: 300 +Num: 301 +Num: 302 +Num: 303 +Num: 304 +Num: 305 +Num: 306 +Num: 307 +Num: 308 +Num: 309 +Num: 310 +Num: 311 +Num: 312 +Num: 313 +Num: 314 +Num: 315 +Num: 316 +Num: 317 +Num: 318 +Num: 319 +Num: 320 +Num: 321 +Num: 322 +Num: 323 +Num: 324 +Num: 325 +Num: 326 +Num: 327 +Num: 328 +Num: 329 +Num: 330 +Num: 331 +Num: 332 +Num: 333 +Num: 334 +Num: 335 +Num: 336 +Num: 337 +Num: 338 +Num: 339 +Num: 340 +Num: 341 +Num: 342 +Num: 343 +Num: 344 +Num: 345 +Num: 346 +Num: 347 +Num: 348 +Num: 349 +Num: 350 +Num: 351 +Num: 352 +Num: 353 +Num: 354 +Num: 355 +Num: 356 +Num: 357 +Num: 358 +Num: 359 +Num: 360 +Num: 361 +Num: 362 +Num: 363 +Num: 364 +Num: 365 +Num: 366 +Num: 367 +Num: 368 +Num: 369 +Num: 370 +Num: 371 +Num: 372 +Num: 373 +Num: 374 +Num: 375 +Num: 376 +Num: 377 +Num: 378 +Num: 379 +Num: 380 +Num: 381 +Num: 382 +Num: 383 +Num: 384 +Num: 385 +Num: 386 +Num: 387 +Num: 388 +Num: 389 +Num: 390 +Num: 391 +Num: 392 +Num: 393 +Num: 394 +Num: 395 +Num: 396 +Num: 397 +Num: 398 +Num: 399 +Num: 400 +Num: 401 +Num: 402 +Num: 403 +Num: 404 +Num: 405 +Num: 406 +Num: 407 +Num: 408 +Num: 409 +Num: 410 +Num: 411 +Num: 412 +Num: 413 +Num: 414 +Num: 415 +Num: 416 +Num: 417 +Num: 418 +Num: 419 +Num: 420 +Num: 421 +Num: 422 +Num: 423 +Num: 424 +Num: 425 +Num: 426 +Num: 427 +Num: 428 +Num: 429 +Num: 430 +Num: 431 +Num: 432 +Num: 433 +Num: 434 +Num: 435 +Num: 436 +Num: 437 +Num: 438 +Num: 439 +Num: 440 +Num: 441 +Num: 442 +Num: 443 +Num: 444 +Num: 445 +Num: 446 +Num: 447 +Num: 448 +Num: 449 +Num: 450 +Num: 451 +Num: 452 +Num: 453 +Num: 454 +Num: 455 +Num: 456 +Num: 457 +Num: 458 +Num: 459 +Num: 460 +Num: 461 +Num: 462 +Num: 463 +Num: 464 +Num: 465 +Num: 466 +Num: 467 +Num: 468 +Num: 469 +Num: 470 +Num: 471 +Num: 472 +Num: 473 +Num: 474 +Num: 475 +Num: 476 +Num: 477 +Num: 478 +Num: 479 +Num: 480 +Num: 481 +Num: 482 +Num: 483 +Num: 484 +Num: 485 +Num: 486 +Num: 487 +Num: 488 +Num: 489 +Num: 490 +Num: 491 +Num: 492 +Num: 493 +Num: 494 +Num: 495 +Num: 496 +Num: 497 +Num: 498 +Num: 499 +Num: 500 +Num: 501 +Num: 502 +Num: 503 +Num: 504 +Num: 505 +Num: 506 +Num: 507 +Num: 508 +Num: 509 +Num: 510 +Num: 511 +Num: 512 +Num: 513 +Num: 514 +Num: 515 +Num: 516 +Num: 517 +Num: 518 +Num: 519 +Num: 520 +Num: 521 +Num: 522 +Num: 523 +Num: 524 +Num: 525 +Num: 526 +Num: 527 +Num: 528 +Num: 529 +Num: 530 +Num: 531 +Num: 532 +Num: 533 +Num: 534 +Num: 535 +Num: 536 +Num: 537 +Num: 538 +Num: 539 +Num: 540 +Num: 541 +Num: 542 +Num: 543 +Num: 544 +Num: 545 +Num: 546 +Num: 547 +Num: 548 +Num: 549 +Num: 550 +Num: 551 +Num: 552 +Num: 553 +Num: 554 +Num: 555 +Num: 556 +Num: 557 +Num: 558 +Num: 559 +Num: 560 +Num: 561 +Num: 562 +Num: 563 +Num: 564 +Num: 565 +Num: 566 +Num: 567 +Num: 568 +Num: 569 +Num: 570 +Num: 571 +Num: 572 +Num: 573 +Num: 574 +Num: 575 +Num: 576 +Num: 577 +Num: 578 +Num: 579 +Num: 580 +Num: 581 +Num: 582 +Num: 583 +Num: 584 +Num: 585 +Num: 586 +Num: 587 +Num: 588 +Num: 589 +Num: 590 +Num: 591 +Num: 592 +Num: 593 +Num: 594 +Num: 595 +Num: 596 +Num: 597 +Num: 598 +Num: 599 +Num: 600 +Num: 601 +Num: 602 +Num: 603 +Num: 604 +Num: 605 +Num: 606 +Num: 607 +Num: 608 +Num: 609 +Num: 610 +Num: 611 +Num: 612 +Num: 613 +Num: 614 +Num: 615 +Num: 616 +Num: 617 +Num: 618 +Num: 619 +Num: 620 +Num: 621 +Num: 622 +Num: 623 +Num: 624 +Num: 625 +Num: 626 +Num: 627 +Num: 628 +Num: 629 +Num: 630 +Num: 631 +Num: 632 +Num: 633 +Num: 634 +Num: 635 +Num: 636 +Num: 637 +Num: 638 +Num: 639 +Num: 640 +Num: 641 +Num: 642 +Num: 643 +Num: 644 +Num: 645 +Num: 646 +Num: 647 +Num: 648 +Num: 649 +Num: 650 +Num: 651 +Num: 652 +Num: 653 +Num: 654 +Num: 655 +Num: 656 +Num: 657 +Num: 658 +Num: 659 +Num: 660 +Num: 661 +Num: 662 +Num: 663 +Num: 664 +Num: 665 +Num: 666 +Num: 667 +Num: 668 +Num: 669 +Num: 670 +Num: 671 +Num: 672 +Num: 673 +Num: 674 +Num: 675 +Num: 676 +Num: 677 +Num: 678 +Num: 679 +Num: 680 +Num: 681 +Num: 682 +Num: 683 +Num: 684 +Num: 685 +Num: 686 +Num: 687 +Num: 688 +Num: 689 +Num: 690 +Num: 691 +Num: 692 +Num: 693 +Num: 694 +Num: 695 +Num: 696 +Num: 697 +Num: 698 +Num: 699 +Num: 700 +Num: 701 +Num: 702 +Num: 703 +Num: 704 +Num: 705 +Num: 706 +Num: 707 +Num: 708 +Num: 709 +Num: 710 +Num: 711 +Num: 712 +Num: 713 +Num: 714 +Num: 715 +Num: 716 +Num: 717 +Num: 718 +Num: 719 +Num: 720 +Num: 721 +Num: 722 +Num: 723 +Num: 724 +Num: 725 +Num: 726 +Num: 727 +Num: 728 +Num: 729 +Num: 730 +Num: 731 +Num: 732 +Num: 733 +Num: 734 +Num: 735 +Num: 736 +Num: 737 +Num: 738 +Num: 739 +Num: 740 +Num: 741 +Num: 742 +Num: 743 +Num: 744 +Num: 745 +Num: 746 +Num: 747 +Num: 748 +Num: 749 +Num: 750 +Num: 751 +Num: 752 +Num: 753 +Num: 754 +Num: 755 +Num: 756 +Num: 757 +Num: 758 +Num: 759 +Num: 760 +Num: 761 +Num: 762 +Num: 763 +Num: 764 +Num: 765 +Num: 766 +Num: 767 +Num: 768 +Num: 769 +Num: 770 +Num: 771 +Num: 772 +Num: 773 +Num: 774 +Num: 775 +Num: 776 +Num: 777 +Num: 778 +Num: 779 +Num: 780 +Num: 781 +Num: 782 +Num: 783 +Num: 784 +Num: 785 +Num: 786 +Num: 787 +Num: 788 +Num: 789 +Num: 790 +Num: 791 +Num: 792 +Num: 793 +Num: 794 +Num: 795 +Num: 796 +Num: 797 +Num: 798 +Num: 799 +Num: 800 +Num: 801 +Num: 802 +Num: 803 +Num: 804 +Num: 805 +Num: 806 +Num: 807 +Num: 808 +Num: 809 +Num: 810 +Num: 811 +Num: 812 +Num: 813 +Num: 814 +Num: 815 +Num: 816 +Num: 817 +Num: 818 +Num: 819 +Num: 820 +Num: 821 +Num: 822 +Num: 823 +Num: 824 +Num: 825 +Num: 826 +Num: 827 +Num: 828 +Num: 829 +Num: 830 +Num: 831 +Num: 832 +Num: 833 +Num: 834 +Num: 835 +Num: 836 +Num: 837 +Num: 838 +Num: 839 +Num: 840 +Num: 841 +Num: 842 +Num: 843 +Num: 844 +Num: 845 +Num: 846 +Num: 847 +Num: 848 +Num: 849 +Num: 850 +Num: 851 +Num: 852 +Num: 853 +Num: 854 +Num: 855 +Num: 856 +Num: 857 +Num: 858 +Num: 859 +Num: 860 +Num: 861 +Num: 862 +Num: 863 +Num: 864 +Num: 865 +Num: 866 +Num: 867 +Num: 868 +Num: 869 +Num: 870 +Num: 871 +Num: 872 +Num: 873 +Num: 874 +Num: 875 +Num: 876 +Num: 877 +Num: 878 +Num: 879 +Num: 880 +Num: 881 +Num: 882 +Num: 883 +Num: 884 +Num: 885 +Num: 886 +Num: 887 +Num: 888 +Num: 889 +Num: 890 +Num: 891 +Num: 892 +Num: 893 +Num: 894 +Num: 895 +Num: 896 +Num: 897 +Num: 898 +Num: 899 +Num: 900 +Num: 901 +Num: 902 +Num: 903 +Num: 904 +Num: 905 +Num: 906 +Num: 907 +Num: 908 +Num: 909 +Num: 910 +Num: 911 +Num: 912 +Num: 913 +Num: 914 +Num: 915 +Num: 916 +Num: 917 +Num: 918 +Num: 919 +Num: 920 +Num: 921 +Num: 922 +Num: 923 +Num: 924 +Num: 925 +Num: 926 +Num: 927 +Num: 928 +Num: 929 +Num: 930 +Num: 931 +Num: 932 +Num: 933 +Num: 934 +Num: 935 +Num: 936 +Num: 937 +Num: 938 +Num: 939 +Num: 940 +Num: 941 +Num: 942 +Num: 943 +Num: 944 +Num: 945 +Num: 946 +Num: 947 +Num: 948 +Num: 949 +Num: 950 +Num: 951 +Num: 952 +Num: 953 +Num: 954 +Num: 955 +Num: 956 +Num: 957 +Num: 958 +Num: 959 +Num: 960 +Num: 961 +Num: 962 +Num: 963 +Num: 964 +Num: 965 +Num: 966 +Num: 967 +Num: 968 +Num: 969 +Num: 970 +Num: 971 +Num: 972 +Num: 973 +Num: 974 +Num: 975 +Num: 976 +Num: 977 +Num: 978 +Num: 979 +Num: 980 +Num: 981 +Num: 982 +Num: 983 +Num: 984 +Num: 985 +Num: 986 +Num: 987 +Num: 988 +Num: 989 +Num: 990 +Num: 991 +Num: 992 +Num: 993 +Num: 994 +Num: 995 +Num: 996 +Num: 997 +Num: 998 +Num: 999 +Num: 1000 +Num: 1001 +Num: 1002 +Num: 1003 +Num: 1004 +Num: 1005 +Num: 1006 +Num: 1007 +Num: 1008 +Num: 1009 +Num: 1010 +Num: 1011 +Num: 1012 +Num: 1013 +Num: 1014 +Num: 1015 +Num: 1016 +Num: 1017 +Num: 1018 +Num: 1019 +Num: 1020 +Num: 1021 +Num: 1022 +Num: 1023 +Num: 1024 +Num: 1025 +Num: 1026 +Num: 1027 +Num: 1028 +Num: 1029 +Num: 1030 +Num: 1031 +Num: 1032 +Num: 1033 +Num: 1034 +Num: 1035 +Num: 1036 +Num: 1037 +Num: 1038 +Num: 1039 +Num: 1040 +Num: 1041 +Num: 1042 +Num: 1043 +Num: 1044 +Num: 1045 +Num: 1046 +Num: 1047 +Num: 1048 +Num: 1049 +Num: 1050 +Num: 1051 +Num: 1052 +Num: 1053 +Num: 1054 +Num: 1055 +Num: 1056 +Num: 1057 +Num: 1058 +Num: 1059 +Num: 1060 +Num: 1061 +Num: 1062 +Num: 1063 +Num: 1064 +Num: 1065 +Num: 1066 +Num: 1067 +Num: 1068 +Num: 1069 +Num: 1070 +Num: 1071 +Num: 1072 +Num: 1073 +Num: 1074 +Num: 1075 +Num: 1076 +Num: 1077 +Num: 1078 +Num: 1079 +Num: 1080 +Num: 1081 +Num: 1082 +Num: 1083 +Num: 1084 +Num: 1085 +Num: 1086 +Num: 1087 +Num: 1088 +Num: 1089 +Num: 1090 +Num: 1091 +Num: 1092 +Num: 1093 +Num: 1094 +Num: 1095 +Num: 1096 +Num: 1097 +Num: 1098 +Num: 1099 +Num: 1100 +Num: 1101 +Num: 1102 +Num: 1103 +Num: 1104 +Num: 1105 +Num: 1106 +Num: 1107 +Num: 1108 +Num: 1109 +Num: 1110 +Num: 1111 +Num: 1112 +Num: 1113 +Num: 1114 +Num: 1115 +Num: 1116 +Num: 1117 +Num: 1118 +Num: 1119 +Num: 1120 +Num: 1121 +Num: 1122 +Num: 1123 +Num: 1124 +Num: 1125 +Num: 1126 +Num: 1127 +Num: 1128 +Num: 1129 +Num: 1130 +Num: 1131 +Num: 1132 +Num: 1133 +Num: 1134 +Num: 1135 +Num: 1136 +Num: 1137 +Num: 1138 +Num: 1139 +Num: 1140 +Num: 1141 +Num: 1142 +Num: 1143 +Num: 1144 +Num: 1145 +Num: 1146 +Num: 1147 +Num: 1148 +Num: 1149 +Num: 1150 +Num: 1151 +Num: 1152 +Num: 1153 +Num: 1154 +Num: 1155 +Num: 1156 +Num: 1157 +Num: 1158 +Num: 1159 +Num: 1160 +Num: 1161 +Num: 1162 +Num: 1163 +Num: 1164 +Num: 1165 +Num: 1166 +Num: 1167 +Num: 1168 +Num: 1169 +Num: 1170 +Num: 1171 +Num: 1172 +Num: 1173 +Num: 1174 +Num: 1175 +Num: 1176 +Num: 1177 +Num: 1178 +Num: 1179 +Num: 1180 +Num: 1181 +Num: 1182 +Num: 1183 +Num: 1184 +Num: 1185 +Num: 1186 +Num: 1187 +Num: 1188 +Num: 1189 +Num: 1190 +Num: 1191 +Num: 1192 +Num: 1193 +Num: 1194 +Num: 1195 +Num: 1196 +Num: 1197 +Num: 1198 +Num: 1199 +Num: 1200 +Num: 1201 +Num: 1202 +Num: 1203 +Num: 1204 +Num: 1205 +Num: 1206 +Num: 1207 +Num: 1208 +Num: 1209 +Num: 1210 +Num: 1211 +Num: 1212 +Num: 1213 +Num: 1214 +Num: 1215 +Num: 1216 +Num: 1217 +Num: 1218 +Num: 1219 +Num: 1220 +Num: 1221 +Num: 1222 +Num: 1223 +Num: 1224 +Num: 1225 +Num: 1226 +Num: 1227 +Num: 1228 +Num: 1229 +Num: 1230 +Num: 1231 +Num: 1232 +Num: 1233 +Num: 1234 +Num: 1235 +Num: 1236 +Num: 1237 +Num: 1238 +Num: 1239 +Num: 1240 +Num: 1241 +Num: 1242 +Num: 1243 +Num: 1244 +Num: 1245 +Num: 1246 +Num: 1247 +Num: 1248 +Num: 1249 +Num: 1250 +Num: 1251 +Num: 1252 +Num: 1253 +Num: 1254 +Num: 1255 +Num: 1256 +Num: 1257 +Num: 1258 +Num: 1259 +Num: 1260 +Num: 1261 +Num: 1262 +Num: 1263 +Num: 1264 +Num: 1265 +Num: 1266 +Num: 1267 +Num: 1268 +Num: 1269 +Num: 1270 +Num: 1271 +Num: 1272 +Num: 1273 +Num: 1274 +Num: 1275 +Num: 1276 +Num: 1277 +Num: 1278 +Num: 1279 +Num: 1280 +Num: 1281 +Num: 1282 +Num: 1283 +Num: 1284 +Num: 1285 +Num: 1286 +Num: 1287 +Num: 1288 +Num: 1289 +Num: 1290 +Num: 1291 +Num: 1292 +Num: 1293 +Num: 1294 +Num: 1295 +Num: 1296 +Num: 1297 +Num: 1298 +Num: 1299 +Num: 1300 +Num: 1301 +Num: 1302 +Num: 1303 +Num: 1304 +Num: 1305 +Num: 1306 +Num: 1307 +Num: 1308 +Num: 1309 +Num: 1310 +Num: 1311 +Num: 1312 +Num: 1313 +Num: 1314 +Num: 1315 +Num: 1316 +Num: 1317 +Num: 1318 +Num: 1319 +Num: 1320 +Num: 1321 +Num: 1322 +Num: 1323 +Num: 1324 +Num: 1325 +Num: 1326 +Num: 1327 +Num: 1328 +Num: 1329 +Num: 1330 +Num: 1331 +Num: 1332 +Num: 1333 +Num: 1334 +Num: 1335 +Num: 1336 +Num: 1337 +Num: 1338 +Num: 1339 +Num: 1340 +Num: 1341 +Num: 1342 +Num: 1343 +Num: 1344 +Num: 1345 +Num: 1346 +Num: 1347 +Num: 1348 +Num: 1349 +Num: 1350 +Num: 1351 +Num: 1352 +Num: 1353 +Num: 1354 +Num: 1355 +Num: 1356 +Num: 1357 +Num: 1358 +Num: 1359 +Num: 1360 +Num: 1361 +Num: 1362 +Num: 1363 +Num: 1364 +Num: 1365 +Num: 1366 +Num: 1367 +Num: 1368 +Num: 1369 +Num: 1370 +Num: 1371 +Num: 1372 +Num: 1373 +Num: 1374 +Num: 1375 +Num: 1376 +Num: 1377 +Num: 1378 +Num: 1379 +Num: 1380 +Num: 1381 +Num: 1382 +Num: 1383 +Num: 1384 +Num: 1385 +Num: 1386 +Num: 1387 +Num: 1388 +Num: 1389 +Num: 1390 +Num: 1391 +Num: 1392 +Num: 1393 +Num: 1394 +Num: 1395 +Num: 1396 +Num: 1397 +Num: 1398 +Num: 1399 +Num: 1400 +Num: 1401 +Num: 1402 +Num: 1403 +Num: 1404 +Num: 1405 +Num: 1406 +Num: 1407 +Num: 1408 +Num: 1409 +Num: 1410 +Num: 1411 +Num: 1412 +Num: 1413 +Num: 1414 +Num: 1415 +Num: 1416 +Num: 1417 +Num: 1418 +Num: 1419 +Num: 1420 +Num: 1421 +Num: 1422 +Num: 1423 +Num: 1424 +Num: 1425 +Num: 1426 +Num: 1427 +Num: 1428 +Num: 1429 +Num: 1430 +Num: 1431 +Num: 1432 +Num: 1433 +Num: 1434 +Num: 1435 +Num: 1436 +Num: 1437 +Num: 1438 +Num: 1439 +Num: 1440 +Num: 1441 +Num: 1442 +Num: 1443 +Num: 1444 +Num: 1445 +Num: 1446 +Num: 1447 +Num: 1448 +Num: 1449 +Num: 1450 +Num: 1451 +Num: 1452 +Num: 1453 +Num: 1454 +Num: 1455 +Num: 1456 +Num: 1457 +Num: 1458 +Num: 1459 +Num: 1460 +Num: 1461 +Num: 1462 +Num: 1463 +Num: 1464 +Num: 1465 +Num: 1466 +Num: 1467 +Num: 1468 +Num: 1469 +Num: 1470 +Num: 1471 +Num: 1472 +Num: 1473 +Num: 1474 +Num: 1475 +Num: 1476 +Num: 1477 +Num: 1478 +Num: 1479 +Num: 1480 +Num: 1481 +Num: 1482 +Num: 1483 +Num: 1484 +Num: 1485 +Num: 1486 +Num: 1487 +Num: 1488 +Num: 1489 +Num: 1490 +Num: 1491 +Num: 1492 +Num: 1493 +Num: 1494 +Num: 1495 +Num: 1496 +Num: 1497 +Num: 1498 +Num: 1499 +Num: 1500 +Num: 1501 +Num: 1502 +Num: 1503 +Num: 1504 +Num: 1505 +Num: 1506 +Num: 1507 +Num: 1508 +Num: 1509 +Num: 1510 +Num: 1511 +Num: 1512 +Num: 1513 +Num: 1514 +Num: 1515 +Num: 1516 +Num: 1517 +Num: 1518 +Num: 1519 +Num: 1520 +Num: 1521 +Num: 1522 +Num: 1523 +Num: 1524 +Num: 1525 +Num: 1526 +Num: 1527 +Num: 1528 +Num: 1529 +Num: 1530 +Num: 1531 +Num: 1532 +Num: 1533 +Num: 1534 +Num: 1535 +Num: 1536 +Num: 1537 +Num: 1538 +Num: 1539 +Num: 1540 +Num: 1541 +Num: 1542 +Num: 1543 +Num: 1544 +Num: 1545 +Num: 1546 +Num: 1547 +Num: 1548 +Num: 1549 +Num: 1550 +Num: 1551 +Num: 1552 +Num: 1553 +Num: 1554 +Num: 1555 +Num: 1556 +Num: 1557 +Num: 1558 +Num: 1559 +Num: 1560 +Num: 1561 +Num: 1562 +Num: 1563 +Num: 1564 +Num: 1565 +Num: 1566 +Num: 1567 +Num: 1568 +Num: 1569 +Num: 1570 +Num: 1571 +Num: 1572 +Num: 1573 +Num: 1574 +Num: 1575 +Num: 1576 +Num: 1577 +Num: 1578 +Num: 1579 +Num: 1580 +Num: 1581 +Num: 1582 +Num: 1583 +Num: 1584 +Num: 1585 +Num: 1586 +Num: 1587 +Num: 1588 +Num: 1589 +Num: 1590 +Num: 1591 +Num: 1592 +Num: 1593 +Num: 1594 +Num: 1595 +Num: 1596 +Num: 1597 +Num: 1598 +Num: 1599 +Num: 1600 +Num: 1601 +Num: 1602 +Num: 1603 +Num: 1604 +Num: 1605 +Num: 1606 +Num: 1607 +Num: 1608 +Num: 1609 +Num: 1610 +Num: 1611 +Num: 1612 +Num: 1613 +Num: 1614 +Num: 1615 +Num: 1616 +Num: 1617 +Num: 1618 +Num: 1619 +Num: 1620 +Num: 1621 +Num: 1622 +Num: 1623 +Num: 1624 +Num: 1625 +Num: 1626 +Num: 1627 +Num: 1628 +Num: 1629 +Num: 1630 +Num: 1631 +Num: 1632 +Num: 1633 +Num: 1634 +Num: 1635 +Num: 1636 +Num: 1637 +Num: 1638 +Num: 1639 +Num: 1640 +Num: 1641 +Num: 1642 +Num: 1643 +Num: 1644 +Num: 1645 +Num: 1646 +Num: 1647 +Num: 1648 +Num: 1649 +Num: 1650 +Num: 1651 +Num: 1652 +Num: 1653 +Num: 1654 +Num: 1655 +Num: 1656 +Num: 1657 +Num: 1658 +Num: 1659 +Num: 1660 +Num: 1661 +Num: 1662 +Num: 1663 +Num: 1664 +Num: 1665 +Num: 1666 +Num: 1667 +Num: 1668 +Num: 1669 +Num: 1670 +Num: 1671 +Num: 1672 +Num: 1673 +Num: 1674 +Num: 1675 +Num: 1676 +Num: 1677 +Num: 1678 +Num: 1679 +Num: 1680 +Num: 1681 +Num: 1682 +Num: 1683 +Num: 1684 +Num: 1685 +Num: 1686 +Num: 1687 +Num: 1688 +Num: 1689 +Num: 1690 +Num: 1691 +Num: 1692 +Num: 1693 +Num: 1694 +Num: 1695 +Num: 1696 +Num: 1697 +Num: 1698 +Num: 1699 +Num: 1700 +Num: 1701 +Num: 1702 +Num: 1703 +Num: 1704 +Num: 1705 +Num: 1706 +Num: 1707 +Num: 1708 +Num: 1709 +Num: 1710 +Num: 1711 +Num: 1712 +Num: 1713 +Num: 1714 +Num: 1715 +Num: 1716 +Num: 1717 +Num: 1718 +Num: 1719 +Num: 1720 +Num: 1721 +Num: 1722 +Num: 1723 +Num: 1724 +Num: 1725 +Num: 1726 +Num: 1727 +Num: 1728 +Num: 1729 +Num: 1730 +Num: 1731 +Num: 1732 +Num: 1733 +Num: 1734 +Num: 1735 +Num: 1736 +Num: 1737 +Num: 1738 +Num: 1739 +Num: 1740 +Num: 1741 +Num: 1742 +Num: 1743 +Num: 1744 +Num: 1745 +Num: 1746 +Num: 1747 +Num: 1748 +Num: 1749 +Num: 1750 +Num: 1751 +Num: 1752 +Num: 1753 +Num: 1754 +Num: 1755 +Num: 1756 +Num: 1757 +Num: 1758 +Num: 1759 +Num: 1760 +Num: 1761 +Num: 1762 +Num: 1763 +Num: 1764 +Num: 1765 +Num: 1766 +Num: 1767 +Num: 1768 +Num: 1769 +Num: 1770 +Num: 1771 +Num: 1772 +Num: 1773 +Num: 1774 +Num: 1775 +Num: 1776 +Num: 1777 +Num: 1778 +Num: 1779 +Num: 1780 +Num: 1781 +Num: 1782 +Num: 1783 +Num: 1784 +Num: 1785 +Num: 1786 +Num: 1787 +Num: 1788 +Num: 1789 +Num: 1790 +Num: 1791 +Num: 1792 +Num: 1793 +Num: 1794 +Num: 1795 +Num: 1796 +Num: 1797 +Num: 1798 +Num: 1799 +Num: 1800 +Num: 1801 +Num: 1802 +Num: 1803 +Num: 1804 +Num: 1805 +Num: 1806 +Num: 1807 +Num: 1808 +Num: 1809 +Num: 1810 +Num: 1811 +Num: 1812 +Num: 1813 +Num: 1814 +Num: 1815 +Num: 1816 +Num: 1817 +Num: 1818 +Num: 1819 +Num: 1820 +Num: 1821 +Num: 1822 +Num: 1823 +Num: 1824 +Num: 1825 +Num: 1826 +Num: 1827 +Num: 1828 +Num: 1829 +Num: 1830 +Num: 1831 +Num: 1832 +Num: 1833 +Num: 1834 +Num: 1835 +Num: 1836 +Num: 1837 +Num: 1838 +Num: 1839 +Num: 1840 +Num: 1841 +Num: 1842 +Num: 1843 +Num: 1844 +Num: 1845 +Num: 1846 +Num: 1847 +Num: 1848 +Num: 1849 +Num: 1850 +Num: 1851 +Num: 1852 +Num: 1853 +Num: 1854 +Num: 1855 +Num: 1856 +Num: 1857 +Num: 1858 +Num: 1859 +Num: 1860 +Num: 1861 +Num: 1862 +Num: 1863 +Num: 1864 +Num: 1865 +Num: 1866 +Num: 1867 +Num: 1868 +Num: 1869 +Num: 1870 +Num: 1871 +Num: 1872 +Num: 1873 +Num: 1874 +Num: 1875 +Num: 1876 +Num: 1877 +Num: 1878 +Num: 1879 +Num: 1880 +Num: 1881 +Num: 1882 +Num: 1883 +Num: 1884 +Num: 1885 +Num: 1886 +Num: 1887 +Num: 1888 +Num: 1889 +Num: 1890 +Num: 1891 +Num: 1892 +Num: 1893 +Num: 1894 +Num: 1895 +Num: 1896 +Num: 1897 +Num: 1898 +Num: 1899 +Num: 1900 +Num: 1901 +Num: 1902 +Num: 1903 +Num: 1904 +Num: 1905 +Num: 1906 +Num: 1907 +Num: 1908 +Num: 1909 +Num: 1910 +Num: 1911 +Num: 1912 +Num: 1913 +Num: 1914 +Num: 1915 +Num: 1916 +Num: 1917 +Num: 1918 +Num: 1919 +Num: 1920 +Num: 1921 +Num: 1922 +Num: 1923 +Num: 1924 +Num: 1925 +Num: 1926 +Num: 1927 +Num: 1928 +Num: 1929 +Num: 1930 +Num: 1931 +Num: 1932 +Num: 1933 +Num: 1934 +Num: 1935 +Num: 1936 +Num: 1937 +Num: 1938 +Num: 1939 +Num: 1940 +Num: 1941 +Num: 1942 +Num: 1943 +Num: 1944 +Num: 1945 +Num: 1946 +Num: 1947 +Num: 1948 +Num: 1949 +Num: 1950 +Num: 1951 +Num: 1952 +Num: 1953 +Num: 1954 +Num: 1955 +Num: 1956 +Num: 1957 +Num: 1958 +Num: 1959 +Num: 1960 +Num: 1961 +Num: 1962 +Num: 1963 +Num: 1964 +Num: 1965 +Num: 1966 +Num: 1967 +Num: 1968 +Num: 1969 +Num: 1970 +Num: 1971 +Num: 1972 +Num: 1973 +Num: 1974 +Num: 1975 +Num: 1976 +Num: 1977 +Num: 1978 +Num: 1979 +Num: 1980 +Num: 1981 +Num: 1982 +Num: 1983 +Num: 1984 +Num: 1985 +Num: 1986 +Num: 1987 +Num: 1988 +Num: 1989 +Num: 1990 +Num: 1991 +Num: 1992 +Num: 1993 +Num: 1994 +Num: 1995 +Num: 1996 +Num: 1997 +Num: 1998 +Num: 1999 +Num: 2000 +Num: 2001 +Num: 2002 +Num: 2003 +Num: 2004 +Num: 2005 +Num: 2006 +Num: 2007 +Num: 2008 +Num: 2009 +Num: 2010 +Num: 2011 +Num: 2012 +Num: 2013 +Num: 2014 +Num: 2015 +Num: 2016 +Num: 2017 +Num: 2018 +Num: 2019 +Num: 2020 +Num: 2021 +Num: 2022 +Num: 2023 +Num: 2024 +Num: 2025 +Num: 2026 +Num: 2027 +Num: 2028 +Num: 2029 +Num: 2030 +Num: 2031 +Num: 2032 +Num: 2033 +Num: 2034 +Num: 2035 +Num: 2036 +Num: 2037 +Num: 2038 +Num: 2039 +Num: 2040 +Num: 2041 +Num: 2042 +Num: 2043 +Num: 2044 +Num: 2045 +Num: 2046 +Num: 2047 +Num: 2048 +Num: 2049 +Num: 2050 +Num: 2051 +Num: 2052 +Num: 2053 +Num: 2054 +Num: 2055 +Num: 2056 +Num: 2057 +Num: 2058 +Num: 2059 +Num: 2060 +Num: 2061 +Num: 2062 +Num: 2063 +Num: 2064 +Num: 2065 +Num: 2066 +Num: 2067 +Num: 2068 +Num: 2069 +Num: 2070 +Num: 2071 +Num: 2072 +Num: 2073 +Num: 2074 +Num: 2075 +Num: 2076 +Num: 2077 +Num: 2078 +Num: 2079 +Num: 2080 +Num: 2081 +Num: 2082 +Num: 2083 +Num: 2084 +Num: 2085 +Num: 2086 +Num: 2087 +Num: 2088 +Num: 2089 +Num: 2090 +Num: 2091 +Num: 2092 +Num: 2093 +Num: 2094 +Num: 2095 +Num: 2096 +Num: 2097 +Num: 2098 +Num: 2099 +Num: 2100 +Num: 2101 +Num: 2102 +Num: 2103 +Num: 2104 +Num: 2105 +Num: 2106 +Num: 2107 +Num: 2108 +Num: 2109 +Num: 2110 +Num: 2111 +Num: 2112 +Num: 2113 +Num: 2114 +Num: 2115 +Num: 2116 +Num: 2117 +Num: 2118 +Num: 2119 +Num: 2120 +Num: 2121 +Num: 2122 +Num: 2123 +Num: 2124 +Num: 2125 +Num: 2126 +Num: 2127 +Num: 2128 +Num: 2129 +Num: 2130 +Num: 2131 +Num: 2132 +Num: 2133 +Num: 2134 +Num: 2135 +Num: 2136 +Num: 2137 +Num: 2138 +Num: 2139 +Num: 2140 +Num: 2141 +Num: 2142 +Num: 2143 +Num: 2144 +Num: 2145 +Num: 2146 +Num: 2147 +Num: 2148 +Num: 2149 +Num: 2150 +Num: 2151 +Num: 2152 +Num: 2153 +Num: 2154 +Num: 2155 +Num: 2156 +Num: 2157 +Num: 2158 +Num: 2159 +Num: 2160 +Num: 2161 +Num: 2162 +Num: 2163 +Num: 2164 +Num: 2165 +Num: 2166 +Num: 2167 +Num: 2168 +Num: 2169 +Num: 2170 +Num: 2171 +Num: 2172 +Num: 2173 +Num: 2174 +Num: 2175 +Num: 2176 +Num: 2177 +Num: 2178 +Num: 2179 +Num: 2180 +Num: 2181 +Num: 2182 +Num: 2183 +Num: 2184 +Num: 2185 +Num: 2186 +Num: 2187 +Num: 2188 +Num: 2189 +Num: 2190 +Num: 2191 +Num: 2192 +Num: 2193 +Num: 2194 +Num: 2195 +Num: 2196 +Num: 2197 +Num: 2198 +Num: 2199 +Num: 2200 +Num: 2201 +Num: 2202 +Num: 2203 +Num: 2204 +Num: 2205 +Num: 2206 +Num: 2207 +Num: 2208 +Num: 2209 +Num: 2210 +Num: 2211 +Num: 2212 +Num: 2213 +Num: 2214 +Num: 2215 +Num: 2216 +Num: 2217 +Num: 2218 +Num: 2219 +Num: 2220 +Num: 2221 +Num: 2222 +Num: 2223 +Num: 2224 +Num: 2225 +Num: 2226 +Num: 2227 +Num: 2228 +Num: 2229 +Num: 2230 +Num: 2231 +Num: 2232 +Num: 2233 +Num: 2234 +Num: 2235 +Num: 2236 +Num: 2237 +Num: 2238 +Num: 2239 +Num: 2240 +Num: 2241 +Num: 2242 +Num: 2243 +Num: 2244 +Num: 2245 +Num: 2246 +Num: 2247 +Num: 2248 +Num: 2249 +Num: 2250 +Num: 2251 +Num: 2252 +Num: 2253 +Num: 2254 +Num: 2255 +Num: 2256 +Num: 2257 +Num: 2258 +Num: 2259 +Num: 2260 +Num: 2261 +Num: 2262 +Num: 2263 +Num: 2264 +Num: 2265 +Num: 2266 +Num: 2267 +Num: 2268 +Num: 2269 +Num: 2270 +Num: 2271 +Num: 2272 +Num: 2273 +Num: 2274 +Num: 2275 +Num: 2276 +Num: 2277 +Num: 2278 +Num: 2279 +Num: 2280 +Num: 2281 +Num: 2282 +Num: 2283 +Num: 2284 +Num: 2285 +Num: 2286 +Num: 2287 +Num: 2288 +Num: 2289 +Num: 2290 +Num: 2291 +Num: 2292 +Num: 2293 +Num: 2294 +Num: 2295 +Num: 2296 +Num: 2297 +Num: 2298 +Num: 2299 +Num: 2300 +Num: 2301 +Num: 2302 +Num: 2303 +Num: 2304 +Num: 2305 +Num: 2306 +Num: 2307 +Num: 2308 +Num: 2309 +Num: 2310 +Num: 2311 +Num: 2312 +Num: 2313 +Num: 2314 +Num: 2315 +Num: 2316 +Num: 2317 +Num: 2318 +Num: 2319 +Num: 2320 +Num: 2321 +Num: 2322 +Num: 2323 +Num: 2324 +Num: 2325 +Num: 2326 +Num: 2327 +Num: 2328 +Num: 2329 +Num: 2330 +Num: 2331 +Num: 2332 +Num: 2333 +Num: 2334 +Num: 2335 +Num: 2336 +Num: 2337 +Num: 2338 +Num: 2339 +Num: 2340 +Num: 2341 +Num: 2342 +Num: 2343 +Num: 2344 +Num: 2345 +Num: 2346 +Num: 2347 +Num: 2348 +Num: 2349 +Num: 2350 +Num: 2351 +Num: 2352 +Num: 2353 +Num: 2354 +Num: 2355 +Num: 2356 +Num: 2357 +Num: 2358 +Num: 2359 +Num: 2360 +Num: 2361 +Num: 2362 +Num: 2363 +Num: 2364 +Num: 2365 +Num: 2366 +Num: 2367 +Num: 2368 +Num: 2369 +Num: 2370 +Num: 2371 +Num: 2372 +Num: 2373 +Num: 2374 +Num: 2375 +Num: 2376 +Num: 2377 +Num: 2378 +Num: 2379 +Num: 2380 +Num: 2381 +Num: 2382 +Num: 2383 +Num: 2384 +Num: 2385 +Num: 2386 +Num: 2387 +Num: 2388 +Num: 2389 +Num: 2390 +Num: 2391 +Num: 2392 +Num: 2393 +Num: 2394 +Num: 2395 +Num: 2396 +Num: 2397 +Num: 2398 +Num: 2399 +Num: 2400 +Num: 2401 +Num: 2402 +Num: 2403 +Num: 2404 +Num: 2405 +Num: 2406 +Num: 2407 +Num: 2408 +Num: 2409 +Num: 2410 +Num: 2411 +Num: 2412 +Num: 2413 +Num: 2414 +Num: 2415 +Num: 2416 +Num: 2417 +Num: 2418 +Num: 2419 +Num: 2420 +Num: 2421 +Num: 2422 +Num: 2423 +Num: 2424 +Num: 2425 +Num: 2426 +Num: 2427 +Num: 2428 +Num: 2429 +Num: 2430 +Num: 2431 +Num: 2432 +Num: 2433 +Num: 2434 +Num: 2435 +Num: 2436 +Num: 2437 +Num: 2438 +Num: 2439 +Num: 2440 +Num: 2441 +Num: 2442 +Num: 2443 +Num: 2444 +Num: 2445 +Num: 2446 +Num: 2447 +Num: 2448 +Num: 2449 +Num: 2450 +Num: 2451 +Num: 2452 +Num: 2453 +Num: 2454 +Num: 2455 +Num: 2456 +Num: 2457 +Num: 2458 +Num: 2459 +Num: 2460 +Num: 2461 +Num: 2462 +Num: 2463 +Num: 2464 +Num: 2465 +Num: 2466 +Num: 2467 +Num: 2468 +Num: 2469 +Num: 2470 +Num: 2471 +Num: 2472 +Num: 2473 +Num: 2474 +Num: 2475 +Num: 2476 +Num: 2477 +Num: 2478 +Num: 2479 +Num: 2480 +Num: 2481 +Num: 2482 +Num: 2483 +Num: 2484 +Num: 2485 +Num: 2486 +Num: 2487 +Num: 2488 +Num: 2489 +Num: 2490 +Num: 2491 +Num: 2492 +Num: 2493 +Num: 2494 +Num: 2495 +Num: 2496 +Num: 2497 +Num: 2498 +Num: 2499 +Num: 2500 +Num: 2501 +Num: 2502 +Num: 2503 +Num: 2504 +Num: 2505 +Num: 2506 +Num: 2507 +Num: 2508 +Num: 2509 +Num: 2510 +Num: 2511 +Num: 2512 +Num: 2513 +Num: 2514 +Num: 2515 +Num: 2516 +Num: 2517 +Num: 2518 +Num: 2519 +Num: 2520 +Num: 2521 +Num: 2522 +Num: 2523 +Num: 2524 +Num: 2525 +Num: 2526 +Num: 2527 +Num: 2528 +Num: 2529 +Num: 2530 +Num: 2531 +Num: 2532 +Num: 2533 +Num: 2534 +Num: 2535 +Num: 2536 +Num: 2537 +Num: 2538 +Num: 2539 +Num: 2540 +Num: 2541 +Num: 2542 +Num: 2543 +Num: 2544 +Num: 2545 +Num: 2546 +Num: 2547 +Num: 2548 +Num: 2549 +Num: 2550 +Num: 2551 +Num: 2552 +Num: 2553 +Num: 2554 +Num: 2555 +Num: 2556 +Num: 2557 +Num: 2558 +Num: 2559 +Num: 2560 +Num: 2561 +Num: 2562 +Num: 2563 +Num: 2564 +Num: 2565 +Num: 2566 +Num: 2567 +Num: 2568 +Num: 2569 +Num: 2570 +Num: 2571 +Num: 2572 +Num: 2573 +Num: 2574 +Num: 2575 +Num: 2576 +Num: 2577 +Num: 2578 +Num: 2579 +Num: 2580 +Num: 2581 +Num: 2582 +Num: 2583 +Num: 2584 +Num: 2585 +Num: 2586 +Num: 2587 +Num: 2588 +Num: 2589 +Num: 2590 +Num: 2591 +Num: 2592 +Num: 2593 +Num: 2594 +Num: 2595 +Num: 2596 +Num: 2597 +Num: 2598 +Num: 2599 +Num: 2600 +Num: 2601 +Num: 2602 +Num: 2603 +Num: 2604 +Num: 2605 +Num: 2606 +Num: 2607 +Num: 2608 +Num: 2609 +Num: 2610 +Num: 2611 +Num: 2612 +Num: 2613 +Num: 2614 +Num: 2615 +Num: 2616 +Num: 2617 +Num: 2618 +Num: 2619 +Num: 2620 +Num: 2621 +Num: 2622 +Num: 2623 +Num: 2624 +Num: 2625 +Num: 2626 +Num: 2627 +Num: 2628 +Num: 2629 +Num: 2630 +Num: 2631 +Num: 2632 +Num: 2633 +Num: 2634 +Num: 2635 +Num: 2636 +Num: 2637 +Num: 2638 +Num: 2639 +Num: 2640 +Num: 2641 +Num: 2642 +Num: 2643 +Num: 2644 +Num: 2645 +Num: 2646 +Num: 2647 +Num: 2648 +Num: 2649 +Num: 2650 +Num: 2651 +Num: 2652 +Num: 2653 +Num: 2654 +Num: 2655 +Num: 2656 +Num: 2657 +Num: 2658 +Num: 2659 +Num: 2660 +Num: 2661 +Num: 2662 +Num: 2663 +Num: 2664 +Num: 2665 +Num: 2666 +Num: 2667 +Num: 2668 +Num: 2669 +Num: 2670 +Num: 2671 +Num: 2672 +Num: 2673 +Num: 2674 +Num: 2675 +Num: 2676 +Num: 2677 +Num: 2678 +Num: 2679 +Num: 2680 +Num: 2681 +Num: 2682 +Num: 2683 +Num: 2684 +Num: 2685 +Num: 2686 +Num: 2687 +Num: 2688 +Num: 2689 +Num: 2690 +Num: 2691 +Num: 2692 +Num: 2693 +Num: 2694 +Num: 2695 +Num: 2696 +Num: 2697 +Num: 2698 +Num: 2699 +Num: 2700 +Num: 2701 +Num: 2702 +Num: 2703 +Num: 2704 +Num: 2705 +Num: 2706 +Num: 2707 +Num: 2708 +Num: 2709 +Num: 2710 +Num: 2711 +Num: 2712 +Num: 2713 +Num: 2714 +Num: 2715 +Num: 2716 +Num: 2717 +Num: 2718 +Num: 2719 +Num: 2720 +Num: 2721 +Num: 2722 +Num: 2723 +Num: 2724 +Num: 2725 +Num: 2726 +Num: 2727 +Num: 2728 +Num: 2729 +Num: 2730 +Num: 2731 +Num: 2732 +Num: 2733 +Num: 2734 +Num: 2735 +Num: 2736 +Num: 2737 +Num: 2738 +Num: 2739 +Num: 2740 +Num: 2741 +Num: 2742 +Num: 2743 +Num: 2744 +Num: 2745 +Num: 2746 +Num: 2747 +Num: 2748 +Num: 2749 +Num: 2750 +Num: 2751 +Num: 2752 +Num: 2753 +Num: 2754 +Num: 2755 +Num: 2756 +Num: 2757 +Num: 2758 +Num: 2759 +Num: 2760 +Num: 2761 +Num: 2762 +Num: 2763 +Num: 2764 +Num: 2765 +Num: 2766 +Num: 2767 +Num: 2768 +Num: 2769 +Num: 2770 +Num: 2771 +Num: 2772 +Num: 2773 +Num: 2774 +Num: 2775 +Num: 2776 +Num: 2777 +Num: 2778 +Num: 2779 +Num: 2780 +Num: 2781 +Num: 2782 +Num: 2783 +Num: 2784 +Num: 2785 +Num: 2786 +Num: 2787 +Num: 2788 +Num: 2789 +Num: 2790 +Num: 2791 +Num: 2792 +Num: 2793 +Num: 2794 +Num: 2795 +Num: 2796 +Num: 2797 +Num: 2798 +Num: 2799 +Num: 2800 +Num: 2801 +Num: 2802 +Num: 2803 +Num: 2804 +Num: 2805 +Num: 2806 +Num: 2807 +Num: 2808 +Num: 2809 +Num: 2810 +Num: 2811 +Num: 2812 +Num: 2813 +Num: 2814 +Num: 2815 +Num: 2816 +Num: 2817 +Num: 2818 +Num: 2819 +Num: 2820 +Num: 2821 +Num: 2822 +Num: 2823 +Num: 2824 +Num: 2825 +Num: 2826 +Num: 2827 +Num: 2828 +Num: 2829 +Num: 2830 +Num: 2831 +Num: 2832 +Num: 2833 +Num: 2834 +Num: 2835 +Num: 2836 +Num: 2837 +Num: 2838 +Num: 2839 +Num: 2840 +Num: 2841 +Num: 2842 +Num: 2843 +Num: 2844 +Num: 2845 +Num: 2846 +Num: 2847 +Num: 2848 +Num: 2849 +Num: 2850 +Num: 2851 +Num: 2852 +Num: 2853 +Num: 2854 +Num: 2855 +Num: 2856 +Num: 2857 +Num: 2858 +Num: 2859 +Num: 2860 +Num: 2861 +Num: 2862 +Num: 2863 +Num: 2864 +Num: 2865 +Num: 2866 +Num: 2867 +Num: 2868 +Num: 2869 +Num: 2870 +Num: 2871 +Num: 2872 +Num: 2873 +Num: 2874 +Num: 2875 +Num: 2876 +Num: 2877 +Num: 2878 +Num: 2879 +Num: 2880 +Num: 2881 +Num: 2882 +Num: 2883 +Num: 2884 +Num: 2885 +Num: 2886 +Num: 2887 +Num: 2888 +Num: 2889 +Num: 2890 +Num: 2891 +Num: 2892 +Num: 2893 +Num: 2894 +Num: 2895 +Num: 2896 +Num: 2897 +Num: 2898 +Num: 2899 +Num: 2900 +Num: 2901 +Num: 2902 +Num: 2903 +Num: 2904 +Num: 2905 +Num: 2906 +Num: 2907 +Num: 2908 +Num: 2909 +Num: 2910 +Num: 2911 +Num: 2912 +Num: 2913 +Num: 2914 +Num: 2915 +Num: 2916 +Num: 2917 +Num: 2918 +Num: 2919 +Num: 2920 +Num: 2921 +Num: 2922 +Num: 2923 +Num: 2924 +Num: 2925 +Num: 2926 +Num: 2927 +Num: 2928 +Num: 2929 +Num: 2930 +Num: 2931 +Num: 2932 +Num: 2933 +Num: 2934 +Num: 2935 +Num: 2936 +Num: 2937 +Num: 2938 +Num: 2939 +Num: 2940 +Num: 2941 +Num: 2942 +Num: 2943 +Num: 2944 +Num: 2945 +Num: 2946 +Num: 2947 +Num: 2948 +Num: 2949 +Num: 2950 +Num: 2951 +Num: 2952 +Num: 2953 +Num: 2954 +Num: 2955 +Num: 2956 +Num: 2957 +Num: 2958 +Num: 2959 +Num: 2960 +Num: 2961 +Num: 2962 +Num: 2963 +Num: 2964 +Num: 2965 +Num: 2966 +Num: 2967 +Num: 2968 +Num: 2969 +Num: 2970 +Num: 2971 +Num: 2972 +Num: 2973 +Num: 2974 +Num: 2975 +Num: 2976 +Num: 2977 +Num: 2978 +Num: 2979 +Num: 2980 +Num: 2981 +Num: 2982 +Num: 2983 +Num: 2984 +Num: 2985 +Num: 2986 +Num: 2987 +Num: 2988 +Num: 2989 +Num: 2990 +Num: 2991 +Num: 2992 +Num: 2993 +Num: 2994 +Num: 2995 +Num: 2996 +Num: 2997 +Num: 2998 +Num: 2999 +Num: 3000 +Num: 3001 +Num: 3002 +Num: 3003 diff --git a/test_dev/ref-int.sml b/test_dev/ref-int.sml index 3ebba2eb0..75c08e7e6 100644 --- a/test_dev/ref-int.sml +++ b/test_dev/ref-int.sml @@ -6,19 +6,18 @@ infix 3 := o type 'a ref = 'a ref - fun !(x: 'a ref): 'a = prim ("!", "!", x) - fun (x: 'a ref) := (y: 'a): unit = prim (":=", ":=", (x, y)) + fun !(x: 'a ref): 'a = prim ("!", x) + fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) - fun op = (x: ''a, y: ''a): bool = prim ("=", "=", (x, y)) + fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) fun not true = false | not false = true fun a <> b = not (a = b) fun (f o g) x = f(g x) - fun print (s:string) : unit = prim("printStringML", "printStringML", s) - fun printNum (n:int):unit = prim("printNum","printNum",n) -(* fun printNum n = print (Int.toString n)*) + fun print (s:string) : unit = prim("printStringML", s) + fun printNum (n:int):unit = prim("printNum",n) local val counter = ref 0 @@ -33,7 +32,7 @@ fun loop 0 f = f () val res = (loop 10 (fn () => printNum(inc())); loop 10 (fn () => printNum(succ()))) - + val counter = ref 0 fun inc () = (counter := (!counter + 1); diff --git a/test_dev/ref-real.out.ok b/test_dev/ref-real.out.ok new file mode 100644 index 000000000..3a4847922 --- /dev/null +++ b/test_dev/ref-real.out.ok @@ -0,0 +1,3 @@ +Num: 6001.00 +Num: 7002.00 +Num: 8003.00 diff --git a/test_dev/ref-real.sml b/test_dev/ref-real.sml index e58504c30..23ddb413f 100644 --- a/test_dev/ref-real.sml +++ b/test_dev/ref-real.sml @@ -1,51 +1,20 @@ +infix 6 + - +infixr 5 :: +infix 4 = <> > >= < <= +infix 3 := o +type 'a ref = 'a ref +fun !(x: 'a ref): 'a = prim ("!", x) +fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) +fun printReal (n:real):unit = prim("printReal",n) - - infix 6 + - - infixr 5 :: - infix 4 = <> > >= < <= - infix 3 := o - type 'a ref = 'a ref - - fun !(x: 'a ref): 'a = prim ("!", "!", x) - fun (x: 'a ref) := (y: 'a): unit = prim (":=", ":=", (x, y)) - - fun printReal (n:real):unit = prim("printReal","printReal",n) - -(*val _ = - let - val _ = printReal(1.0) - val a = 1.0 - val _ = printReal a - val b = 3.0 - val _ = printReal b - val c = a + b - val _ = printReal(c) - in - () - end - - -local - val counter = ref 0.0 -in - fun inc() = (counter := !counter + 1.0; !counter) - fun succ() = (counter := !counter - 1.0; !counter) -end -*) fun loop 0 f = f () - | loop n f = (f (); - loop (n-1) f) + | loop n f = (f (); loop (n-1) f) -(*val res = (loop 10 (fn () => printReal(inc())); - loop 10 (fn () => printReal(succ()))) -*) val counter = ref 0.0 -fun inc () = (counter := (!counter + 1.0); - printReal(!counter); - !counter) +fun inc () = (counter := (!counter + 1.0); !counter) -val res = (loop 6000 inc; - loop 1000 inc; - loop 1000 inc) +val () = (printReal(loop 6000 inc); + printReal(loop 1000 inc); + printReal(loop 1000 inc)) diff --git a/test_dev/ref.out.ok b/test_dev/ref.out.ok new file mode 100644 index 000000000..915612089 --- /dev/null +++ b/test_dev/ref.out.ok @@ -0,0 +1 @@ +Hej med digHej igen \ No newline at end of file diff --git a/test_dev/ref.sml b/test_dev/ref.sml index 2db511f99..bb957eed8 100644 --- a/test_dev/ref.sml +++ b/test_dev/ref.sml @@ -1,8 +1,8 @@ let - fun print (s:string) : unit = prim("printStringML", "printStringML", s) - fun !(x: 'a ref): 'a = prim ("!", "!", x) + fun print (s:string) : unit = prim("printStringML", s) + fun !(x: 'a ref): 'a = prim ("!", x) infix 3 := o - fun (x: 'a ref) := (y: 'a): unit = prim (":=", ":=", (x, y)) + fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) val r = ref "Hej med dig" in print (!r); diff --git a/test_dev/reg.out.ok b/test_dev/reg.out.ok new file mode 100644 index 000000000..c909a00bf --- /dev/null +++ b/test_dev/reg.out.ok @@ -0,0 +1 @@ +Num: 501560 diff --git a/test_dev/reg.sml b/test_dev/reg.sml new file mode 100644 index 000000000..8f303fd98 --- /dev/null +++ b/test_dev/reg.sml @@ -0,0 +1,135 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before +fun !(x: 'a ref): 'a = prim ("!", x) +fun printNum (i:int) : unit = prim("printNum", i) + +val r00 = ref 0w0 +val r01 = ref 0w1 +val r02 = ref 0w2 +val r03 = ref 0w3 +val r04 = ref 0w4 +val r05 = ref 0w5 +val r06 = ref 0w6 +val r07 = ref 0w7 +val r08 = ref 0w8 +val r09 = ref 0w9 + +val r10 = ref 0w10 +val r11 = ref 0w11 +val r12 = ref 0w12 +val r13 = ref 0w13 +val r14 = ref 0w14 +val r15 = ref 0w15 +val r16 = ref 0w16 +val r17 = ref 0w17 +val r18 = ref 0w18 +val r19 = ref 0w19 + +val r20 = ref 0w20 +val r21 = ref 0w21 +val r22 = ref 0w22 +val r23 = ref 0w23 +val r24 = ref 0w24 +val r25 = ref 0w25 +val r26 = ref 0w26 +val r27 = ref 0w27 +val r28 = ref 0w28 +val r29 = ref 0w29 + +val r30 = ref 0w30 +val r31 = ref 0w31 +val r32 = ref 0w32 +val r33 = ref 0w33 +val r34 = ref 0w34 +val r35 = ref 0w35 +val r36 = ref 0w36 +val r37 = ref 0w37 +val r38 = ref 0w38 +val r39 = ref 0w39 + +fun max n m = + if n > m then n else m +fun mk (n,acc) = + if n <= 0 then acc + else mk(n-1,n::acc) + +fun sumit (nil,acc) = acc + | sumit (x::xs,acc) = sumit(xs,max x acc) + +fun alloc () = + let val xs = mk(500000,nil) + in sumit(xs,0) + end + +fun toWord (i:int):word = prim("id",i) + +fun sum () = + let + val x00 = !r00 + val x01 = !r01 + val x02 = !r02 + val x03 = !r03 + val x04 = !r04 + val x05 = !r05 + val x06 = !r06 + val x07 = !r07 + val x08 = !r08 + val x09 = !r09 + + val x10 = !r10 + val x11 = !r11 + val x12 = !r12 + val x13 = !r13 + val x14 = !r14 + val x15 = !r15 + val x16 = !r16 + val x17 = !r17 + val x18 = !r18 + val x19 = !r19 + + val x20 = !r20 + val x21 = !r21 + val x22 = !r22 + val x23 = !r23 + val x24 = !r24 + val x25 = !r25 + val x26 = !r26 + val x27 = !r27 + val x28 = !r28 + val x29 = !r29 + + val x30 = !r30 + val x31 = !r31 + val x32 = !r32 + val x33 = !r33 + val x34 = !r34 + val x35 = !r35 + val x36 = !r36 + val x37 = !r37 + val x38 = !r38 + val x39 = !r39 + + val x0 = x00 + x01 + x02 + x03 + x04 + x05 + x06 + x07 + x08 + x09 + val x1 = x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + val x2 = x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + val x3 = x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + val y = x0 + x1 + x2 + x3 + val v = alloc() +(* val () = printNum 0 *) +(* val () = printNum v *) + val x0 = x00 + x01 + x02 + x03 + x04 + x05 + x06 + x07 + x08 + x09 + val x1 = x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + val x2 = x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + val x3 = x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + val y = x0 + x1 + x2 + x3 + in toWord v + y + y + end + +val x = sum() +fun toIntX (w : word) : int = prim("id", w) + +val () = printNum (toIntX x) diff --git a/test_dev/shra.out.ok b/test_dev/shra.out.ok new file mode 100644 index 000000000..0d50c4bea --- /dev/null +++ b/test_dev/shra.out.ok @@ -0,0 +1,5 @@ +Num: -64 +Num: -32 +Num: -1 +Num: -1 +Ok diff --git a/test_dev/shra.sml b/test_dev/shra.sml new file mode 100644 index 000000000..6a94b6e4d --- /dev/null +++ b/test_dev/shra.sml @@ -0,0 +1,50 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) +fun not true = false | not false = true +fun a <> b = not (a = b) +fun print (s:string) : unit = prim("printStringML", s) +fun printNum (n:int):unit = prim("printNum",n) +fun toInt (w : word32) : int = prim("__word32_to_int", w) +fun toIntX (w : word32) : int = prim("__word32_to_int_X", w) +fun cast_iw (a: int) : word = prim("id", a) +fun fromInt (i : int) : word32 = prim("__word_to_word32", cast_iw i) +fun rshiftsig_ (w : word32, k : word) : word32 = + prim("__shift_right_signed_word32", (w,k)) + +fun printWord a = printNum (toIntX a) + +fun ~>> (w:word,k:word) = rshiftsig_(w, k) + + +fun doit n = + let val a = fromInt n + val () = printWord a + val b = ~>> (a, 0w1) + in printWord b + end + +val () = doit ~64 + +val () = doit ~1 + +val maxInt = 2147483647 +val minInt = ~2147483648 + +fun tst b = + if b then print "Ok\n" + else print "Err\n" + +val r = ref false +val () = tst (if !r then true + else toIntX 0wx7FFFFFFF = maxInt) + + (* +val test10c = checkrange (~513, 513) + (fn i => i div 2 = Int32.fromLarge(toLargeIntX (~>> (i2w i, 0w1)))); +*) diff --git a/test_dev/sign.out.ok b/test_dev/sign.out.ok new file mode 100644 index 000000000..21da4d2be --- /dev/null +++ b/test_dev/sign.out.ok @@ -0,0 +1,5 @@ +OK +OK +OK +OK +OK diff --git a/test_dev/sign.sml b/test_dev/sign.sml new file mode 100644 index 000000000..627e7ae28 --- /dev/null +++ b/test_dev/sign.sml @@ -0,0 +1,24 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun print (s:string) : unit = prim("printStringML", s) +fun sign i = if i > 0 then 1 else if i < 0 then ~1 else 0 +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) +fun sameSign (i, j) = sign i = sign j + +val maxInt : int = prim("max_fixed_int", 0) +val minInt : int = prim("min_fixed_int", 0) + +val () = if sign maxInt > 0 then print "OK\n" else print "ERR\n" + +val () = if sign minInt < 0 then print "OK\n" else print "ERR\n" + +val () = if sign 1 = sign maxInt then print "OK\n" else print "ERR\n" +val () = if sign ~1 = sign minInt then print "OK\n" else print "ERR\n" + +val () = if (sign minInt = ~1 andalso sign maxInt = 1 + andalso sameSign(minInt, ~1) andalso sameSign(maxInt, 1)) then print "OK\n" else print "ERR\n" diff --git a/test_dev/string1.out.ok b/test_dev/string1.out.ok new file mode 100644 index 000000000..b1d4443ed --- /dev/null +++ b/test_dev/string1.out.ok @@ -0,0 +1 @@ +Hej Igen diff --git a/test_dev/string1.sml b/test_dev/string1.sml index 97ede2657..564abb271 100644 --- a/test_dev/string1.sml +++ b/test_dev/string1.sml @@ -6,9 +6,9 @@ let infix 3 := o infix 0 before - fun print (s:string) : unit = prim("printStringML", "printStringML", s) - - fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) + fun print (s:string) : unit = prim("printStringML", s) + + fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) val _ = print ("Hej" ^ " " ^ "Igen" ^ "\n") in diff --git a/test_dev/string_sub.out.ok b/test_dev/string_sub.out.ok new file mode 100644 index 000000000..c471c853a --- /dev/null +++ b/test_dev/string_sub.out.ok @@ -0,0 +1,4 @@ +First: Ok +Seccond: Ok +Last: Ok +Second to last: Ok diff --git a/test_dev/string_sub.sml b/test_dev/string_sub.sml new file mode 100644 index 000000000..306cc098d --- /dev/null +++ b/test_dev/string_sub.sml @@ -0,0 +1,43 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) + +fun not true = false + | not false = true + +fun a <> b = not (a = b) + +fun print (s:string) : unit = prim("printStringML", s) + +fun sub_unsafe (s:string,i:int) : char = prim ("__bytetable_sub", (s,i)) +fun size (s : string) : int = prim ("__bytetable_size", s) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) +fun alloc_unsafe (i:int) : string = prim("allocStringML", i) +fun update_unsafe (t:string,i:int,c:char) : unit = prim("__bytetable_update", (t, i, c)) +fun null() : char = prim("id",0:int) +fun ord (c : char) : int = prim ("id", c) + +val s = "aHello there - this is a quite long string, but not too longa" + +val sz = size s + +val () = print "First: " +val () = if ord(sub_unsafe(s,0)) = 97 then print "Ok\n" + else print "Err\n" + +val () = print "Seccond: " +val () = if ord(sub_unsafe(s,1)) = 72 then print "Ok\n" + else print "Err\n" + +val () = print "Last: " +val () = if ord(sub_unsafe(s,sz-1)) = 97 then print "Ok\n" + else print "Err\n" + +val () = print "Second to last: " +val () = if ord(sub_unsafe(s,sz-2)) = 103 then print "Ok\n" + else print "Err\n" diff --git a/test_dev/string_upd.out.ok b/test_dev/string_upd.out.ok new file mode 100644 index 000000000..96ee202f7 --- /dev/null +++ b/test_dev/string_upd.out.ok @@ -0,0 +1,2 @@ +String - 0: 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' +String - 1: 'aaaaaXaaaaaaaaaaaaaaaaaaaaaaaaaaa' diff --git a/test_dev/string_upd.sml b/test_dev/string_upd.sml new file mode 100644 index 000000000..213116b11 --- /dev/null +++ b/test_dev/string_upd.sml @@ -0,0 +1,30 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) + +fun not true = false + | not false = true + +fun a <> b = not (a = b) + +fun print (s:string) : unit = prim("printStringML", s) + +fun sub_unsafe (s:string,i:int) : char = prim ("__bytetable_sub", (s,i)) +fun size (s : string) : int = prim ("__bytetable_size", s) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) +fun alloc_unsafe (i:int) : string = prim("allocStringML", i) +fun update_unsafe (t:string,i:int,c:char) : unit = prim("__bytetable_update", (t, i, c)) +fun null() : char = prim("id",0:int) +fun ord (c : char) : int = prim ("id", c) + +fun printS s x = print ("String - " ^ x ^ ": '" ^ s ^ "'\n") + +val y = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +val () = printS y "0" +val () = update_unsafe(y,5,#"X") +val () = printS y "1" diff --git a/test_dev/string_update.out.ok b/test_dev/string_update.out.ok new file mode 100644 index 000000000..7d6a3e87e --- /dev/null +++ b/test_dev/string_update.out.ok @@ -0,0 +1,17 @@ +First: Ok +Seccond: Ok +Second to last: Ok +Last: Ok +==Now updating== +String - 0: 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa' +String - 1: 'aaaaaXaaaaaaaaaaaaaaaaaaaaaaaaaaa' +Now s +String - 0: 'aHello there - this is a quite long string, but not too longa' +String - 1: 'aHello there - this is a quite long string, but not too londa' +String - 2: 'aHello there - this is a quite long string, but not too londe' +String - 3: 'bHello there - this is a quite long string, but not too londe' +String - 4: 'bcello there - this is a quite long string, but not too londe' +First: Ok +Second: Ok +Second to last: Ok +Last: Ok diff --git a/test_dev/string_update.sml b/test_dev/string_update.sml new file mode 100644 index 000000000..321d8429a --- /dev/null +++ b/test_dev/string_update.sml @@ -0,0 +1,79 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) + +fun not true = false + | not false = true + +fun a <> b = not (a = b) + +fun print (s:string) : unit = prim("printStringML", s) + +fun sub_unsafe (s:string,i:int) : char = prim ("__bytetable_sub", (s,i)) +fun size (s : string) : int = prim ("__bytetable_size", s) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) +fun alloc_unsafe (i:int) : string = prim("allocStringML", i) +fun update_unsafe (t:string,i:int,c:char) : unit = prim("__bytetable_update", (t, i, c)) +fun null() : char = prim("id",0:int) +fun ord (c : char) : int = prim ("id", c) + +val s = "aHello there - this is a quite long string, but not too longa" + +val sz = size s + +val () = print "First: " +val () = if ord(sub_unsafe(s,0)) = 97 then print "Ok\n" + else print "Err\n" + +val () = print "Seccond: " +val () = if ord(sub_unsafe(s,1)) = 72 then print "Ok\n" + else print "Err\n" + +val () = print "Second to last: " +val () = if ord(sub_unsafe(s,sz-2)) = 103 then print "Ok\n" + else print "Err\n" + +val () = print "Last: " +val () = if ord(sub_unsafe(s,sz-1)) = 97 then print "Ok\n" + else print "Err\n" + +val () = print "==Now updating==\n" + +fun printS s x = print ("String - " ^ x ^ ": '" ^ s ^ "'\n") + +val y = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +val () = printS y "0" +val () = update_unsafe(y,5,#"X") +val () = printS y "1" + +val () = print "Now s\n" +val () = printS s "0" +val () = update_unsafe(s,sz-2,#"d") +val () = printS s "1" +val () = update_unsafe(s,sz-1,#"e") +val () = printS s "2" +val () = update_unsafe(s,0,#"b") +val () = printS s "3" +val () = update_unsafe(s,1,#"c") +val () = printS s "4" + +val () = print "First: " +val () = if sub_unsafe(s,0) = #"b" then print "Ok\n" + else print "Err\n" + +val () = print "Second: " +val () = if sub_unsafe(s,1) = #"c" then print "Ok\n" + else print "Err\n" + +val () = print "Second to last: " +val () = if sub_unsafe(s,sz-2) = #"d" then print "Ok\n" + else print "Err\n" + +val () = print "Last: " +val () = if sub_unsafe(s,sz-1) = #"e" then print "Ok\n" + else print "Err\n" diff --git a/test_dev/strs.sml b/test_dev/strs.sml index 7984a7856..812c52a5a 100644 --- a/test_dev/strs.sml +++ b/test_dev/strs.sml @@ -1,7 +1,7 @@ infix ^ -fun implode (chars : char list) : string = prim ("implodeCharsML", "implodeCharsProfilingML", chars) -fun (s : string) ^ (s' : string) : string = prim ("concatStringML", "concatStringProfilingML", (s, s')) -fun print (x:string):unit = prim("printStringML","printStringML",x) +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) +fun print (x : string) : unit = prim ("printStringML", x) val _ = print ("Hello " ^ " You world " ^ "1" ^ "2\n") -val _ = print (implode [#"a",#"b",#"e"] ^ "\n") \ No newline at end of file +val _ = print (implode [#"a",#"b",#"e"] ^ "\n") diff --git a/test_dev/test_dattyp.out.ok b/test_dev/test_dattyp.out.ok new file mode 100644 index 000000000..3d1b80b9a --- /dev/null +++ b/test_dev/test_dattyp.out.ok @@ -0,0 +1,1501 @@ +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist h +in makelist 0 diff --git a/test_dev/test_dattyp.sml b/test_dev/test_dattyp.sml index 65fdd3117..3e10378dd 100644 --- a/test_dev/test_dattyp.sml +++ b/test_dev/test_dattyp.sml @@ -6,7 +6,7 @@ type 'a ref = 'a ref - fun print (s:string) : unit = prim("printStringML", "printStringML", s) + fun print (s:string) : unit = prim("printStringML", s) datatype int_list = C of int * int_list | N @@ -19,4 +19,4 @@ val res = makeList 1500 - val l = len res \ No newline at end of file + val l = len res diff --git a/test_dev/testdyn1-nobasis.out.ok b/test_dev/testdyn1-nobasis.out.ok new file mode 100644 index 000000000..4736800b7 --- /dev/null +++ b/test_dev/testdyn1-nobasis.out.ok @@ -0,0 +1,92 @@ +Testing list operations: + [rev, @, map]... +Ok - rev... +Ok - map... +Ok - @... +Testing string operations: + [implode, explode, chr, ord, size]... +Ok - int_to_string... +Ok - implode... +Ok - explode... +Ok - chr... +Ok - ord... +Ok - Chr... +Ok - Chr2... +Ok - size... +Testing ref [ref, :=, !]... +Ok - !1... +Ok - :=1... +Ok - !2... +Ok - :=2... +Ok - !3... +Testing polymorphic equality... +Ok - equal... +Ok - equal2... +Ok - equal3... +Ok - equal4... +Ok - equal5 (ref1)... +Ok - equal5 (ref2)... +Ok - equal6 (dat k)... +Ok - equal7 (dat k)... +Testing arithmetic integer operations: + [~, abs, floor, +, -, *, div, mod, <, >, <=, >=] ... +Ok - ~1... +Ok - ~2... +Ok - abs1... +Ok - abs2... +Ok - floor1... +Ok - floor2... +Ok - floor3... +Ok - +... +Ok - -... +Ok - *... +Ok - intdivmod - 2 mod 3 = 2, 2 div 3 = 0... +Ok - intdivmod - 34 mod ~3 = ~2, 34 div ~3 = ~12... +Ok - intdivmod - 5 mod ~2 = ~1, 5 div ~2 = ~3... +Ok - intdivmod - ~7 mod 3 = 2, ~7 div 3 = ~3... +Ok - Div1... +Ok - Div2... +Ok - <1... +Ok - <2... +Ok - <3... +Ok - >1... +Ok - >2... +Ok - >3... +Ok - <=1... +Ok - <=2... +Ok - <=3... +Ok - >=1... +Ok - >=2... +Ok - >=3... +Testing arithmetic real operations: + [+, -, *, /, ~, abs, real, sqrt, <, >, <=, >=] ... +Ok - +... +Ok - -... +Ok - *... +Ok - /... +Ok - ~1... +Ok - ~2... +Ok - abs1... +Ok - abs2... +Ok - real1... +Ok - real2... +Ok - sqrt1... +Ok - sqrt2... +Ok - sqrt3... +Ok - <1... +Ok - <2... +Ok - <3... +Ok - >1... +Ok - >2... +Ok - >3... +Ok - <=1... +Ok - <=2... +Ok - <=3... +Ok - >=1... +Ok - >=2... +Ok - >=3... +Testing composition o: +Ok - o... +Testing generative exceptions: +Ok - exn - generative... +End of test. diff --git a/test_dev/testdyn1-nobasis.sml b/test_dev/testdyn1-nobasis.sml new file mode 100644 index 000000000..b14de796d --- /dev/null +++ b/test_dev/testdyn1-nobasis.sml @@ -0,0 +1,323 @@ +(*testdyn1-nobasis.sml*) + +(* ------------------------------------------------------------------- *) +(* testdyn1, 08/02/1995 19:17, Martin *) +(* Dynamic test of primitives... except for input/output *) +(* ------------------------------------------------------------------- *) + +(* + MEMO : 'sin', 'cos', 'arctan', 'ln' and 'exp' are not checked yet. + +*) + +(* structure General *) + +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +exception Fail of string +exception Subscript +exception Span +exception Size +exception Domain +exception Chr + +datatype order = LESS | EQUAL | GREATER + +fun !(x: 'a ref): 'a = prim ("!", x) +fun (x: 'a ref) := (y: 'a): unit = prim (":=", (x, y)) +fun (f o g) x = f(g x) +fun a before () = a +fun ignore (a) = () + +fun exnName (e: exn) : string = prim("exnNameML", e) (* exomorphic by copying *) +fun exnMessage (e: exn) : string = exnName e + +datatype 'a option = NONE | SOME of 'a +exception Option +fun getOpt (NONE, a) = a + | getOpt (SOME a, b) = a +fun isSome NONE = false + | isSome _ = true +fun valOf (SOME a) = a + | valOf _ = raise Option + +fun op = (x: ''a, y: ''a): bool = prim ("=", (x, y)) + +fun not true = false + | not false = true + +fun a <> b = not (a = b) + +fun print (s:string) : unit = prim("printStringML", s) +fun implode (chars : char list) : string = prim ("implodeCharsML", chars) +fun concat (ss : string list) : string = prim ("implodeStringML", ss) +fun (s : string) ^ (s' : string) : string = prim ("concatStringML", (s, s')) +fun str (c : char) : string = implode [c] +fun size (s:string): int = prim ("__bytetable_size", s) +fun ord (c : char) : int = prim ("id", c) +fun chr (i:int) : char = if i>=0 andalso i<256 then prim ("id", i) + else raise Chr + +local + fun sub_unsafe (s:string,i:int) : char = prim ("__bytetable_sub", (s,i)) +in fun explode s = + let fun h (j, res) = if j<0 then res + else h (j-1, sub_unsafe (s, j) :: res) + in h (size s - 1, nil) + end +end + +(* structure List *) + + exception Empty + + fun null [] = true + | null _ = false + + fun hd [] = raise Empty + | hd (x::xr) = x + + fun tl [] = raise Empty + | tl (x::xr) = xr + + fun last [] = raise Empty + | last [x] = x + | last (x::xr) = last xr + + fun length xs = + let fun acc [] k = k + | acc (x::xr) k = acc xr (k+1) + in acc xs 0 + end + + local + fun revAcc [] ys = ys + | revAcc (x::xs) ys = revAcc xs (x::ys) + in + fun rev xs = revAcc xs [] + end + + fun nil @ ys = ys + | (x::xs) @ ys = x :: (xs @ ys) + + fun app f [] = () + | app f (x::xr) = (f x; app f xr) + + fun map f [] = [] + | map f (x::xs) = f x :: map f xs + + fun foldr f e [] = e + | foldr f e (x::xr) = f(x, foldr f e xr) + + fun foldl f e [] = e + | foldl f e (x::xr) = foldl f (f(x, e)) xr + + (* structure Real *) + + fun real (x : int) : real = prim ("realInt", x) + fun floor (x : real) : int = prim ("floorFloat", x) (* may raise Overflow *) + fun ceil (x : real) : int = prim ("ceilFloat", x) (* may raise Overflow *) + fun trunc (x : real) : int = prim ("truncFloat", x) (* may raise Overflow *) + + fun (x: real) / (y: real): real = prim ("divFloat", (x, y)) + + (* structure Math *) + fun sqrt (r : real) : real = prim ("sqrtFloat", r) + + (* The tests *) + + infix == + val epsilon = 0.000666 + fun r1 == r2 = abs (r1 - r2) < epsilon (*no perfect world*) + + fun digit n = chr(ord #"0" + n) + fun digits(n,acc) = + if n >=0 andalso n<=9 then digit n:: acc + else digits (n div 10, digit(n mod 10) :: acc) + + fun int_to_string(n) = if n >= 0 then implode(digits(n,[])) + else "~" ^ int_to_string(~n) + + fun error b s = print ((if b then "Ok - " else "Error - ") ^ s ^ "...\n") + + (* testing stuff *) + val _ = + let + val _ = print "Testing list operations:\n\ + \ [rev, @, map]...\n" + in + error (rev [3,34,2,23] = [23,2,34,3]) "rev"; + error (map (fn a:int => 2 * a) [3,34,2] = [6,68,4]) "map"; + error ([34,56] @ [12,67] = [34,56,12,67]) "@" + end + + val _ = + let + val _ = print "Testing string operations:\n\ + \ [implode, explode, chr, ord, size]...\n" + fun hds [] = #"-" + | hds (x::_) = x + in + error (int_to_string 232 = "232") "int_to_string"; + error (implode [#"h", #"e", #"l", #"l", #" "] = "hell ") "implode"; + error (hds (explode "hello") = #"h") "explode"; + error (chr 66 = #"B") "chr"; + error (ord #"B" = 66) "ord"; + error (((chr 1000) handle Chr => #"h") = #"h") "Chr"; + error (((chr 1000) handle Div => #"h" + | Chr => #"k") = #"k") "Chr2"; + error (size "hello I'm 19 long.." = 19) "size" + end + + val _ = + let + val _ = print "Testing ref [ref, :=, !]...\n" + val a = ref "hello" + val g = ref 45 + in + error (!a = "hello") "!1"; + error ((a := "hej") = ()) ":=1"; + error (!a = "hej") "!2"; + error ((g := !g + 1) = ()) ":=2"; + error (!g = 46) "!3" + end + + val _ = + let + val _ = print "Testing polymorphic equality...\n" + val a = [(34,"hejsa"), (4, "bw")] + val b = [[3,23], [~34,23]] + val c = (56, ref "hello") + val d = ref "hej" + datatype k = A of int * string | B | C of k * k + val k1 = C (A(5,"hello"), B) + val k2 = C (A(5,"hello2"), B) + val k3 = C (A(5,"hello2"), B) + in + error (a = [(34,"hejsa"), (4, "bw")]) "equal"; + error ((a = [(34,"hejsa"), (4, "cw")]) = false) "equal2"; + error (b = [[3,23], [~34,23]]) "equal3"; + error ((b = [[3,23], [~34,21]]) = false) "equal4"; + error ((c = (56, ref "hello")) = false) "equal5 (ref1)"; + error ((34,d) = (34,d)) "equal5 (ref2)"; + error (k1 <> k2) "equal6 (dat k)"; + error (k2 = k3) "equal7 (dat k)" + end + + val _ = + let + val _ = print "Testing arithmetic integer operations:\n\ + \ [~, abs, floor, +, -, *, div, mod, <, >, <=, >=] ...\n" + fun checkdivmod (i, d) = + let + val (r, q) = (i mod d, i div d) + val gt_zero = fn a => a > 0 + in + error (gt_zero r = gt_zero d andalso d * q + r = i) + ("intdivmod - " ^ int_to_string i ^ " mod " ^ int_to_string d ^ + " = " ^ int_to_string r ^ ", " ^ int_to_string i ^ " div " + ^ int_to_string d ^ " = " ^ int_to_string q) + end + in + error (~ 5 = ~5) "~1"; + error (~ (~2) = 2) "~2"; + error (abs 5 = 5) "abs1"; + error (abs (~23) = 23) "abs2"; + error (floor (23.23) = 23) "floor1"; + error (floor (~23.23) = ~24) "floor2"; + error (((floor (23.0E23)) handle Overflow => 4) = 4) "floor3"; + error (23 + 12 = 35 andalso ~4 + 5 = 1) "+"; + error (34 - 12 = 22 andalso ~23 - 15 = ~38) "-"; + error (12 * 3 = 36 andalso ~23 * 2 = ~46) "*"; + map checkdivmod [(2,3), (34, ~3), (5, ~2), (~7, 3)]; + error (((3 div 0) handle Div => 60) = 60) "Div1"; + error (((3 mod 0) handle Div => 45) = 45) "Div2"; + error ((23 < 40) = true) "<1"; + error ((54 < 40) = false) "<2"; + error ((40 < 40) = false) "<3"; + error ((23 > 40) = false) ">1"; + error ((54 > 40) = true) ">2"; + error ((40 > 40) = false) ">3"; + error ((23 <= 40) = true) "<=1"; + error ((54 <= 40) = false) "<=2"; + error ((40 <= 40) = true) "<=3"; + error ((23 >= 40) = false) ">=1"; + error ((54 >= 40) = true) ">=2"; + error ((40 >= 40) = true) ">=3" + end + + val _ = + let + val _ = print "Testing arithmetic real operations:\n\ + \ [+, -, *, /, ~, abs, real, sqrt, <, >, <=, >=] ...\n" + in + error (4.0 + 3.0 == 7.0) "+"; + error (4.0 - 1.0 == 3.0) "-"; + error (4.0 * 3.0 == 12.0) "*"; + error (9.0 / 2.0 == 4.5) "/"; + error (~ 5.3 == ~5.3) "~1"; + error (~ (~2.23) == 2.23) "~2"; + error (abs 5.23 == 5.23) "abs1"; + error (abs (~23.12) == 23.12) "abs2"; + error (real 5 == 5.0) "real1"; + error (real ~5 == ~5.0) "real2"; + error (sqrt 0.0 == 0.0) "sqrt1"; + error (sqrt 2.0 > 1.4) "sqrt2"; + error (sqrt 2.0 < 1.5) "sqrt3"; + + error ((23.34 < 40.23) = true) "<1"; + error ((54.12 < 40.45) = false) "<2"; + error ((40.12 < 40.12) = false) "<3"; + error ((23.34 > 40.12) = false) ">1"; + error ((54.45 > 40.23) = true) ">2"; + error ((40.23 > 40.23) = false) ">3"; + error ((23.12 <= 40.34) = true) "<=1"; + error ((54.23 <= 40.23) = false) "<=2"; + error ((40.23 <= 40.23) = true) "<=3"; + error ((23.75 >= 40.75) = false) ">=1"; + error ((54.57 >= 40.57) = true) ">=2"; + error ((40.23 >= 40.23) = true) ">=3" + end + + val _ = + let + val _ = print "Testing composition o:\n" + fun f x = 3 + x + fun g y = (y, 2*y) + in + error ((g o f) 7 = (10,20)) "o" + end + + val _ = + let + val _ = print "Testing generative exceptions:\n" + fun g a = + let + fun f x = + let + exception E + in + if x < 1 then raise E + else ((f (x-1)) handle E => 7) (* should not handle this.. *) + end + in + (f a) handle _ => a + end (* a *) + in + error (g 10 = 10) "exn - generative" + end + + fun etst b s = if b then () else print ("Error - " ^ s ^ "...\n"); + + val _ = etst ("\u0041\u000a\\u0041\n" = "A\n\092" ^ "u0041\010") + "backslash u does not work or somepin"; + + val _ = etst (map ord [#"a", #"A", #" ", chr 42, #"\117"] = + [97, 65, 32, 42, 117]) "char problem, maybe #" + + val _ = print "End of test.\n" diff --git a/test_dev/word_list.out.ok b/test_dev/word_list.out.ok new file mode 100644 index 000000000..f870c37a6 --- /dev/null +++ b/test_dev/word_list.out.ok @@ -0,0 +1,4 @@ +counting +Num: 6 +Num: 63 +Num: 9 diff --git a/test_dev/word_list.sml b/test_dev/word_list.sml new file mode 100644 index 000000000..c35986df0 --- /dev/null +++ b/test_dev/word_list.sml @@ -0,0 +1,34 @@ +infix 7 * / div mod +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before + +fun print (s:string) : unit = prim("printStringML", s) +fun printNum (n:int):unit = prim("printNum", n) + +fun len nil = 0 + | len (x::xs) = 1 + len xs + +val () = print "counting\n" + +val x = [0w1,0w2,0w5,0wxFF,0wxFFFF,0wxFFFFAAAA] + +val () = printNum (len x) + +val ws = [0w0,0w1,0w2,0w254,0w255,0w256,0w257, + 0w0,0w0,0w0,0w0,0w0, + 0w1,0w0,0w2,0w0,0w254,0w0,0w255,0w0,0w256,0w0,0w257, + 0wxFFFFFFFC,0wxFFFFFFFD,0wxFFFFFFFE,0wxFFFFFFFF, + 0w0,0wxFFFFFFFC,0w0,0wxFFFFFFFD,0w0,0wxFFFFFFFE,0w0,0wxFFFFFFFF, + 0w0,0wxFFFFFFF0,0w0,0wxFFFFFFF1,0w0,0wxFFFFFFF2,0w0,0wxFFFFFFF3, + 0w0,0wxFFFFFF00,0w0,0wxFFFFFF01,0w0,0wxFFFFFF02,0w0,0wxFFFFFF03, + 0w0,0wxFF00FF00,0w0,0wxFF01FF01,0w0,0wxFF02FF02,0w0,0wxFF03FF03, + 0wxFFFBFFFC,0wxFFFCFFFD,0wxFFFDFFFE,0wxFFFEFFFF] + +val () = printNum (len ws) + +val y = [1,2,5,256,~32768,32767,65535,~2147483648,2147483647] + +val () = printNum (len y) diff --git a/to_do b/to_do index d73e39c9f..365731ce1 100644 --- a/to_do +++ b/to_do @@ -1,3 +1,17 @@ +mael 2018-12-19: Investigate prettier effect printing. Why do we print +U-nodes? + +mael 2018-12-19: Consider adding a new -Psre flag for printing + simplified region expressions: + + 1. All comparison operations should be pretty-printed as such + (<,=,>,<=,>=). + + 2. print short-cut boolean expressions nicely + + 3. Don't print "letregion r:m in e end" constructs when r is used + only for storing immediate closures. + mael 2013-11-21: Create a Prims.concatWith to allow for inlining of JsCore.exec2, etc. Currently, all JavaScript interaction (except for calls to JsCore.exec1) is done through the creation of Function @@ -9,19 +23,19 @@ signature DYN_TYPE = sig eqtype tn eqtype con - datatype t = - DT_Tuple of t list + datatype t = + DT_Tuple of t list | DT_Dat of tn * t list | DT_Arrow of t * t - | DT_Int32 | DT_Int31 | DT_Real | DT_Bool | DT_String + | DT_Int32 | DT_Int31 | DT_Real | DT_Bool | DT_String val con_arg_t : tn * t list -> con -> t - datatype v = + datatype v = V_Int32 of Int32.int | V_Int31 of Int31.int | V_Bool of bool - | V_Real of real + | V_Real of real | V_String of string | V_Tuple of v list | V_Fn of v -> v @@ -29,11 +43,11 @@ signature DYN_TYPE = sig end -structure Dt :> DYN_TYPE +structure Dt :> DYN_TYPE Built-in function: - + val typeof : '_a -> Dt.t fun variant (a : '_a) : Dt.v = case typeof a of @@ -42,7 +56,7 @@ Built-in function: fun op = (v1 : '_a, v2 : '_a) = case typeof v1 of - + mael 2008-10-19: Make a filesys abstraction FSys that allows for source files and target files to be stored in a database or in the @@ -105,7 +119,7 @@ mael 2005-10-25: MLB-make needs to check the integrity (e.g., size) of needed. It is sufficient to check the integrity of lnk-files since lnk-files are generated last. DONE. -varming 2005-09-05: Upgraded SMLserver to Apache. Started work on +varming 2005-09-05: Upgraded SMLserver to Apache. Started work on configuration prior to compilation (autoconf). > cd kit @@ -114,8 +128,8 @@ configuration prior to compilation (autoconf). > ./configure Generates apropriate Makefiles to build the kit. To build SMLserver -try configure --enable-SMLserver --with-apache=/path/to/apache -To build oracle driver configure --enable-SMLserver +try configure --enable-SMLserver --with-apache=/path/to/apache +To build oracle driver configure --enable-SMLserver --with-apache=/path/to/apache --with-oracle=/path/to/oracle mael 2005-09-02: Both "make mlkit", "make smlserver", and "make @@ -143,7 +157,7 @@ Things to do: - Upgrade to Apache. (Carsten) - Setup and test separate compilation mechanisms - - Setup regression testing for different compile time options, such + - Setup regression testing for different compile time options, such as "-gc", "-prof", "-gc -prof" (Martin) @@ -170,14 +184,14 @@ mael 2005-05-27: Things to do: 3) Options that do not influence the generated code: pretty-printing options verbosity options (chat,debug) - + For computing a subdirectory of MLB to store target code, etc., we sort all options in category (1) and (2); call this list of options L and the list of option values V. val s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_" val sz = size s (*=64*) - + This allows for the encoding of 6 option values for each character. Divide V into lists of 6-tuples (pad with true values for possible missing entries in the last tuple). Interpret each tuple as a @@ -195,7 +209,7 @@ mael 2004-12-13: Status on MLB files. It is now possible to compile the MLKit itself using MLB-files. Unfortunately, a segmentation fault occurs when compiling General.sml with the generated executable - compilation of Initial.sml -goes well. +goes well. Some things to do: @@ -211,7 +225,7 @@ Some things to do: * Extend mlbmake to take a single sml-file "file.sml" as argument. Its semantics should then be similar to - local $(SML_LIB)/basis/basis.mlb in file.sml end - OK + local $(SML_LIB)/basis/basis.mlb in file.sml end - OK mael 2004-10-30 Plan for mlb-files implementation in the MLKit. @@ -233,7 +247,7 @@ Things to do: 2) Optimize loading of export bases so that only infix and elaboration bases are loaded for all {u1.eb ... uN.eb} in - + mlkit -o myfile -load u1.eb ... uN.eb file.sml After the infix and elaboration bases are loaded, the program unit @@ -274,7 +288,7 @@ Let C be the contexts defined by C[.] := . | let f = \x.e in C[.] Turn - let f = \x.C[\y.e1] in e2 + let f = \x.C[\y.e1] in e2 into let f = \x.\y.C[e1] in e2 @@ -284,7 +298,7 @@ mael 2001-11-13: turn curried functions into functions that take let f = \x1...\xn.e in (...(f e1)...en) ==> let f = \.e in f - + mael 2001-11-12: better cross-module in-lining; support in-lining of non-closed functions. @@ -306,11 +320,11 @@ mael 2001-11-12: unboxed implementation of datatypes that kit/basis/Splaymap.sml, and kit/basis/Splayset.sml, (4) Patricia trees (kit/src/Common/IntFinMapPT.sml), and (5) Union Find data structure (kit/src/Compiler/Kam/UnionFindPoly.sml.) - + mael 2001-11-12: unboxed implementation of datatypes that have only one unary constructor; in most cases this optimisation is captured by the unboxing mentioned above. - + mael 2001-08-07: catch stack-overflow mael 2001-08-03: man pages for mlkit and smlserver, rp2ps - OK @@ -324,13 +338,13 @@ nh 2001-06-01: Fra url: The results were (sorted by decreasing speed): - 1.4,393 secs: compiler: MLKit; target code: no garbage collection (i.e., only regions) - 2.4,802 secs: compiler: MLKit; target code: regions and garbage collection - 3.6,3 secs: compiler: mosml; target code: garbage collection, no regions + 1.4,393 secs: compiler: MLKit; target code: no garbage collection (i.e., only regions) + 2.4,802 secs: compiler: MLKit; target code: regions and garbage collection + 3.6,3 secs: compiler: mosml; target code: garbage collection, no regions 4.8,131 secs: compiler: MLKit; target code: regions, garbage collection and profiling. Check the region profile graph and the object profil of the largest region. (The program points in the latter graph do not seem to be right: maybe the same program points are - used in the basis library and in the evaluation system code?.) + used in the basis library and in the evaluation system code?.) VERSION 3 @@ -345,7 +359,7 @@ TO BE FIXED BY: (MT|ME|FAXE) =============================== BUGS =============================== ERROR: CompileDec `val rec pat' error -SYMPTOM: Compilation crashes: +SYMPTOM: Compilation crashes: Impossible: CompileDec.compileREC.id_sigma TESTFILE: kit/test/valrecpat.sml PRIORITY: MEDIUM @@ -368,7 +382,7 @@ compilation, we should restrict the annotated bases to those identifiers that occur free in the functor binding. Is it possible to do this restriction during the pass for finding free identifiers (FreeIds)? - + Implement some kind of project reuse; it currently takes too long for the manager to find out that the code for the basis library can be reused. The problem is that the result basis for the basis library @@ -413,4 +427,3 @@ Why are regions that are passed to primitive functions in the runtime system not tested for resetting automatically (in CompLamb); currently, the user must do the resetting in the C function. Is there a reason? What about Mogensens idea about resetting? -