diff --git a/Makefile.in b/Makefile.in index e8de96980..baeb97242 100644 --- a/Makefile.in +++ b/Makefile.in @@ -12,7 +12,6 @@ VPATH=@srcdir@ SYSCONFDIR=$(DESTDIR)@sysconfdir@ INSTDIR=$(DESTDIR)$(exec_prefix) -INSTDIR_KAM=$(DESTDIR)@exec_prefix@ INSTDIR_BARRY=$(DESTDIR)@exec_prefix@ MANDIR=$(DESTDIR)@mandir@ LIBDIR=$(DESTDIR)@libdir@ @@ -30,7 +29,6 @@ MLCOMP=@mlcomp@ CWD=$(shell pwd) export INSTDIR -export INSTDIR_KAM export INSTDIR_BARRY include Makefiledefault @@ -55,20 +53,6 @@ smltojs: all: mlkit mlkit_basislibs smltojs smltojs_basislibs -smlserver_all: smlserver smlserver_libs - -.PHONY: smlserver_basislib -smlserver_basislib: - (cd basis && SML_LIB=.. ../bin/smlserverc -c basis.mlb) - -.PHONY: smlserver_kitlib -smlserver_kitlib: - (cd basis && SML_LIB=.. ../bin/smlserverc -c kitlib.mlb) - -.PHONY: smlserver_weblib -smlserver_weblib: - (cd basis && SML_LIB=.. ../bin/smlserverc -c web/lib.mlb) - .PHONY: mlkit_basislibs mlkit_basislibs: (cd basis && SML_LIB=.. ../bin/mlkit -c -no_gc basis.mlb) @@ -83,12 +67,6 @@ mlkit_kitlibs: (cd basis && SML_LIB=.. ../bin/mlkit -c -gc -prof kitlib.mlb) (cd basis && SML_LIB=.. ../bin/mlkit -c -no_gc -prof kitlib.mlb) -.PHONY: smlserver_libs -smlserver_libs: mlkit_cleanlibs - $(MAKE) smlserver_basislib - $(MAKE) smlserver_kitlib - $(MAKE) smlserver_weblib - .PHONY: mlkit_cleanlibs mlkit_cleanlibs: (cd basis && find . -name MLB -type d | xargs rm -rf) @@ -118,17 +96,6 @@ install_smltojs_basislibs: $(MKDIR) $(LIBDIR)/basis/MLB/Js/ $(INSTALLDATA) -p js/basis/MLB/Js/*.{d,eb,eb1,lnk,js} $(LIBDIR)/basis/MLB/Js -.PHONY: install_smlserver_basislib -install_smlserver_basislib: - $(MKDIR) $(LIBDIR)/basis/MLB/SMLserver - $(MKDIR) $(LIBDIR)/basis/io/MLB/SMLserver - $(MKDIR) $(LIBDIR)/basis/web/MLB/SMLserver - $(MKDIR) $(LIBDIR)/basis/web/xmlrpc/MLB/SMLserver - $(INSTALLDATA) -p basis/MLB/SMLserver/*.{d,eb,eb1,lnk,uo} $(LIBDIR)/basis/MLB/SMLserver - $(INSTALLDATA) -p basis/io/MLB/SMLserver/*.{d,eb,eb1,lnk,uo} $(LIBDIR)/basis/io/MLB/SMLserver - $(INSTALLDATA) -p basis/web/MLB/SMLserver/*.{d,eb,eb1,lnk,uo} $(LIBDIR)/basis/web/MLB/SMLserver - $(INSTALLDATA) -p basis/web/xmlrpc/MLB/SMLserver/*.{d,eb,eb1,lnk,uo} $(LIBDIR)/basis/web/xmlrpc/MLB/SMLserver - .PHONY: install_mlkit_basislibs install_mlkit_basislibs: $(MKDIR) $(LIBDIR)/basis/MLB @@ -150,17 +117,6 @@ install_mlkit_basislibs: $(INSTALLDATA) -p basis/io/MLB/RI_PROF/*.{d,eb,eb1,lnk,o,rev} $(LIBDIR)/basis/io/MLB/RI_PROF $(INSTALLDATA) -p basis/io/MLB/RI_GC_PROF/*.{d,eb,eb1,lnk,o,rev} $(LIBDIR)/basis/io/MLB/RI_GC_PROF -.PHONY: mlkit_kam -mlkit_kam: - $(MKDIR) bin - $(MAKE) -C src mlkit_kam - -.PHONY: smlserver -smlserver: - $(MKDIR) bin - $(MAKE) -C src smlserver - $(MAKE) man_smlserver - .PHONY: barry barry: $(MKDIR) bin @@ -169,7 +125,7 @@ barry: .PHONY: clean clean: - $(CLEAN) bin run lib bootstrap dist man/man1/*.1 doc/README_SMLSERVER_BIN doc/README_BIN + $(CLEAN) bin run lib bootstrap dist man/man1/*.1 doc/README_BIN cd basis && $(MAKE) clean cd doc/manual && $(MAKE) clean cd kitlib && $(CLEAN) run @@ -178,12 +134,6 @@ clean: cd test && $(MAKE) clean cd test_dev && $(MAKE) clean cd src && $(MAKE) clean - $(MAKE) -C smlserver_demo clean - cd smlserver && $(CLEAN) - cd smlserver/xt && $(CLEAN) - cd smlserver/xt/demolib && $(CLEAN) - cd smlserver/xt/libxt && $(CLEAN) - cd smlserver/xt/www && $(CLEAN) $(MAKE) -C js clean .PHONY: clean_mlb @@ -310,15 +260,12 @@ install_src: $(MKDIR) $(INSTDIR)/src $(MKDIR) $(INSTDIR)/src/Common $(INSTDIR)/src/Compiler $(INSTDIR)/src/Manager $(INSTDIR)/src/Kitlib $(INSTDIR)/src/Pickle $(MKDIR) $(INSTDIR)/src/CUtils $(INSTDIR)/src/Edlib $(INSTDIR)/src/Parsing $(INSTDIR)/src/Runtime - $(MKDIR) $(INSTDIR)/src/SMLserver $(INSTDIR)/src/Tools - $(MKDIR) $(INSTDIR)/src/SMLserver/apache - $(MKDIR) $(INSTDIR)/src/SMLserver/apache/test + $(MKDIR) $(INSTDIR)/src/Tools $(MKDIR) $(INSTDIR)/src/Common/EfficientElab $(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/Barry $(INSTDIR)/src/Compiler/Backend/Dummy $(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/Benchmark $(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 $(INSTALLDATA) src/Common/*.{mlb,sig,sml} $(INSTDIR)/src/Common @@ -329,8 +276,6 @@ install_src: $(INSTALLDATA) src/Compiler/Backend/*.sml $(INSTDIR)/src/Compiler/Backend $(INSTALLDATA) src/Compiler/Backend/Barry/*.sml $(INSTDIR)/src/Compiler/Backend/Barry $(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 @@ -339,12 +284,7 @@ install_src: $(INSTALLDATA) src/Edlib/Makefile src/Edlib/*.{sml,sig,mlb} $(INSTDIR)/src/Edlib $(INSTALLDATA) src/Parsing/*.{sml,sig,grm,lex} $(INSTDIR)/src/Parsing $(INSTALLDATA) src/Runtime/Makefile src/Runtime/*.{c,h,in} $(INSTDIR)/src/Runtime - $(INSTALLDATA) src/SMLserver/*.{c,h} $(INSTDIR)/src/SMLserver - $(INSTALLDATA) src/SMLserver/apache/Makefile.in src/SMLserver/apache/Makefile src/SMLserver/apache/README $(INSTDIR)/src/SMLserver/apache - $(INSTALLDATA) src/SMLserver/apache/Notes src/SMLserver/apache/*.{c,h,in} $(INSTDIR)/src/SMLserver/apache - $(INSTALLDATA) src/SMLserver/apache/test/Makefile src/SMLserver/apache/test/*.{c,txt} $(INSTDIR)/src/SMLserver/apache/test $(INSTALLDATA) src/Tools/Benchmark/*.{sml,mlb} src/Tools/Benchmark/Makefile $(INSTDIR)/src/Tools/Benchmark - $(INSTALLDATA) src/Tools/GenOpcodes/*.{sml,mlb,in} src/Tools/GenOpcodes/Makefile $(INSTDIR)/src/Tools/GenOpcodes $(INSTALLDATA) src/Tools/MlbMake/*.{sml,sig,mlb,in} src/Tools/MlbMake/Makefile $(INSTDIR)/src/Tools/MlbMake $(INSTALLDATA) src/Tools/Rp2ps/*.{c,h,in} src/Tools/Rp2ps/Makefile $(INSTDIR)/src/Tools/Rp2ps $(INSTALLDATA) src/Tools/Tester/*.{sml,mlb,in} src/Tools/Tester/Makefile $(INSTDIR)/src/Tools/Tester @@ -363,7 +303,6 @@ bootstrap_first: .PHONY: bootstrap_next_build bootstrap_next_build: - cd src && $(MAKE) genopcodes BINDIR=../$(BINDIR) cd src/Compiler && SML_LIB=$(CWD) ../../bin/mlkit -gc native64.mlb .PHONY: bootstrap_next_install @@ -402,11 +341,6 @@ man_mlkit: $(MKDIR) man/man1 SML_LIB=$(exec_prefix)/lib/mlkit bin/mlkit -man > man/man1/mlkit.1 -.PHONY: man_smlserver -man_smlserver: - $(MKDIR) man/man1 - SML_LIB=$(exec_prefix)/lib/smlserver bin/smlserverc -man > man/man1/smlserverc.1 - .PHONY: man_smltojs man_smltojs: $(MKDIR) man/man1 @@ -464,41 +398,6 @@ install_smltojs: install_smltojs0 else echo "SML_LIB $(exec_prefix)/lib/smltojs" > $(SYSCONFDIR)/smltojs/mlb-path-map; \ fi -.PHONY: install_smlserver0 -install_smlserver0: - $(MKDIR) $(INSTDIR) - $(MKDIR) $(BINDIR) - $(INSTALL) bin/smlserverc $(BINDIR) - $(INSTALL) bin/smlserver-wrap $(BINDIR) - $(INSTALL) bin/mspcomp $(BINDIR) - $(MKDIR) $(LIBDIR)/smlserver - $(MAKE) install_smlserver_basislib LIBDIR=$(LIBDIR)/smlserver - $(MAKE) install_basis LIBDIR=$(LIBDIR)/smlserver - $(MKDIR) $(LIBDIR)/smlserver/basis/web - $(MKDIR) $(LIBDIR)/smlserver/basis/web/xmlrpc - $(INSTALLDATA) -p basis/web/*.{sml,sig,mlb} $(LIBDIR)/smlserver/basis/web - $(INSTALLDATA) -p basis/web/xmlrpc/*.{sml,sig,mlb} $(LIBDIR)/smlserver/basis/web/xmlrpc -# $(MKDIR) $(MANDIR) - $(MKDIR) $(MANDIR)/man1 - $(INSTALLDATA) man/man1/smlserverc.1 $(MANDIR)/man1 -# $(MKDIR) $(INSTDIR)/share -# $(MKDIR) $(INSTDIR)/share/smlserver -# $(MKDIR) $(INSTDIR)/share/doc - $(MKDIR) $(INSTDIR)/share/doc/smlserver - $(MAKE) install_license KIND=smlserver - $(INSTALLDATA) README_SMLSERVER.md $(DATADIR)/doc/smlserver - $(INSTALLDATA) NEWS_SMLSERVER.md $(DATADIR)/doc/smlserver - $(MAKE) -C smlserver_demo install LIBDIR=$(LIBDIR)/smlserver - $(MAKE) -C src/SMLserver/apache install LIBDIR=$(LIBDIR)/smlserver/lib - -.PHONY: install_smlserver -install_smlserver: install_smlserver0 - $(MKDIR) $(SYSCONFDIR)/smlserverc - if [ -e $(SYSCONFDIR)/smlserverc/mlb-path-map ]; \ - then true; \ - else echo "SML_LIB $(exec_prefix)/lib/smlserver" > $(SYSCONFDIR)/smlserverc/mlb-path-map; \ - fi - # ----------------------------------------------------- # Target for building MLKit binary package. The target # assumes that the mlkit has been build using @@ -557,42 +456,3 @@ mlkit_bin_dist: printf "\t"'for f in $$$$(find * -type f | grep -v Makefile); do install -p "$$$$f" "$$(PREFIX)/$$$$f"; done\n' \ >> $(CWD)/dist/$(BIN_DIST)/Makefile (cd dist && tar czf $(BIN_DIST).tgz $(BIN_DIST)) - - -# ----------------------------------------------------- -# Target for building SMLserver binary package. The target -# assumes that SMLserver has been build using -# $ ./autobuild -# $ ./configure --enable-SMLserver --with-apxs=`which apxs2` --enable-odbc -# $ make smlserver_all -# ----------------------------------------------------- -SMLSERVER_DIST_BIN=smlserver-$(KITVERSION)-i386 -.PHONY: smlserver_i386_tgz -smlserver_i386_tgz: - $(MKDIR) dist - rm -rf dist/$(SMLSERVER_DIST_BIN) - $(MAKE) install_smlserver0 DESTDIR=$(CWD)/dist/$(SMLSERVER_DIST_BIN) prefix= - $(INSTALLDATA) doc/README_SMLSERVER_BIN dist/$(SMLSERVER_DIST_BIN)/share/doc/smlserver - (cd dist && tar czvf $(SMLSERVER_DIST_BIN).tgz $(SMLSERVER_DIST_BIN)) - -# The following is obsolete!! -bootstrap_kam: install_kam bootstrap0 - -install_kam: - $(MKDIR) $(INSTDIR_KAM) - $(MKDIR) $(INSTDIR_KAM)/bin - $(MKDIR) $(INSTDIR_KAM)/doc - $(INSTALL) bin/mlkit_kam $(INSTDIR_KAM)/bin - $(INSTALL) bin/kam $(INSTDIR_KAM)/bin - $(INSTALLDATA) copyright $(INSTDIR_KAM) - $(INSTALLDATA) README.md $(INSTDIR_KAM) - $(INSTALLDATA) -R kitdemo $(INSTDIR_KAM)/kitdemo - $(INSTALLDATA) -R ml-yacc-lib $(INSTDIR_KAM)/ml-yacc-lib - $(INSTALLDATA) -R basis $(INSTDIR_KAM)/basis - $(INSTALLDATA) doc/mlkit.pdf $(INSTDIR_KAM)/doc - -# echo '#!/bin/sh' > $(INSTDIR_KAM)/bin/mlkit_kam -# echo -e '$(INSTDIR_KAM)/bin/mlkit_kam.$(ARCH-OS) $(INSTDIR_KAM) $$*' >> $(INSTDIR_KAM)/bin/mlkit_kam -# chmod a+x $(INSTDIR_KAM)/bin/mlkit_kam -# rm -f /usr/bin/mlkit_kam -# cp -f -p $(INSTDIR_KAM)/bin/mlkit_kam /usr/bin/mlkit_kam diff --git a/NEWS.md b/NEWS.md index 6bfabaccb..fe2d94314 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,13 @@ ## MLKit NEWS +* mael 2021-11-15: Removed all SMLserver code as well as the KAM + bytecode backend as it is no longer maintained. The successor to + SMLserver will be based on the native backend. + ### MLKit version 4.5.9 is released * mael 2021-09-17: Fixed smltojs problem with generating statements - consisting og lambda expressions. + consisting of lambda expressions. * mael 2021-09-17: Fixed problem with dealing with comments in ML-Yacc; fix ported from upstream implementation. diff --git a/NEWS_SMLSERVER.md b/NEWS_SMLSERVER.md deleted file mode 100644 index 5802a8e70..000000000 --- a/NEWS_SMLSERVER.md +++ /dev/null @@ -1,185 +0,0 @@ -## SMLserver NEWS - -### SMLserver version 4.3.12 is released - -* mael 2017-12-10: Support for responses to binary asynchronous - XmlHTTPRequests. - -* mael 2013-11-19: The SMLserver sources are now ported to work with - Apache 2.4 and Postgres 9.1 (through ODBC). - -### SMLserver version 4.3.2 is released - -* mael 2007-04-12: The book "SMLserver - A Functional Approach to Web - Publishing" has been reworked to reflect the move from AOLserver to - the Apache platform; see http://www.smlserver.org for more. - -* mael 2007-04-12: Note: support for "extended typing" (see below) - is currently not maintained. - -* mael 2007-04-10: Moved `smlserver_demo/web_lib/lib.mlb` to - `basis/web/lib.mlb`. The Web library is now precompiled before - installation. This change also involved moving the `Db.sml` file into - `smlserver_demo/web_demo_lib/Db.sml`, as this file needs to be - configured for each individual use. - -* mael 2007-04-10: Duplicate uo-code-files in ul-files are now - removed to speed up the generation of ul-files. - -* mael 2007-02-05: The book "SMLserver, A Functional Approach to Web - Publishing" has been upgraded to reflect the move to the Apache - platform. - -* mael 2007-02-05: XML-RPC support. It is now possible to write XML-RPC - services and to call XML-RPC services using SMLserver. This work is - primarily due to Martin Olsen (mol@itu.dk). - -* mael 2007-02-05: WEB signature changes: Web.return, Web.write, - Web.returnRedirect, Web.Conn.write, Web.Conn.return (and friends) - now have return type unit. - -* mael 2007-02-05: SMLserver has now moved from AOLserver to Apache, - due to work by Carsten Varming (varming@cmu.edu). Many new features - have been added. - -* mael 2007-02-05: ML Server Pages (msp-files) are now supported by - the use of the mspcomp tool, which compiles msp-files into - sml-scripts. - -### SMLserver version 4.1.4 is released - -* mael 2004-05-18: Finished work on "extended typing" in SMLserver, - featuring static guarantees that (1) generated XHTML is valid XHTML - 1.0 and (2) forms and links are used consistently with corresponding - target scripts. See `smlserver/xt/` for examples. Use the smlserverc - compiler flag `-xt` (or `--extended_typing`) to enable. See the PADL'04 - paper "Typing XHTML Web Applications in ML" for implementation - details. - -* nh 2003-06-18: Support for `multipart/form-data` implemented in - `Ns.sml`, see function `getQuery()`. - -* mael 2003-02-24: Initialized work on extended typing in SMLserver, - featuring static guarantees that (1) generated XHTML 1.0 validates - and (2) forms and links are used consistently with corresponding - target scripts. See `/smlserver/xt/` for examples. Use the - smlserverc compiler flag `-xt` (or `--extended_typing`) to enable. - -* nh 2003-01-08: Added hModule to the interpreter context in - `nssml.c`. This makes it easier to access parameters in the - configuration file. Used to access the trap-file in function - `nssml_trapProc`. - -* nh 2003-01-08: Fixed bug with cache name in `Ns.Cache`. Cache names - can have a maximum size of 32 characters i AOLserver versions - 3.X. After version 4, cache names can be of arbitrary size. - -* nh 2003-01-07: Updated NS_CACHE.sml signature such that it matches - the PADL paper. Reimplemented the Triple constructor, so that the - result type is 'a*'b*'c instead of (('a*'b)*'c). - Updated SMLserver book with new cache interface. - -* nh 2002-10-31: `Ns.Cache` version 2 - Typed caching and - memoization. Inserted in the `NS.sml` signature - -* mael 2002-10-31: Execution caching of library initialization. - -### SMLserver version 4.1.1 is released - -* mael 2002-08-24: Added functions for trapping of URL requests - (`Ns.registerTrap`) and for scheduling (`Ns.scheduleScript`, - `Ns.scheduleDaily`, `Ns.scheduleWeekly`). It is now also possible - to configure for a script to be run when the webserver starts (see - the default configuration file for details.) - -* mael 2002-03-19: Added possibility for caching loaded leaf-bytecode - files (flag CODE_CACHE in `LoadKAM.h`). This feature improves on the - number of requests that can be served per second. Default: enabled. - -### SMLserver version 4.1.0 is released - -* mael 2002-01-29: Cleaned up documentation and demonstration - examples. - -* nh 2001-12-29: Added support for MySQL - -* mael 2001-10-09: Added support for threaded simultaneous responses - of requests. Serving a request is no longer blocked by the serving - of other requests. - -* nh 2001-10-05: Added multilingual support in `ScsFormVar` module. - -* mael 2001-09-30: Changed the name of the SMLserver compiler from - `mlkit_web` to `smlserverc`. - -* nh 2001-09-23: Added dictionary support for multilingual language - support. Additional modules `ScsDict`, `ScsLogin`, and `ScsLang`. - -* nh 2001-09-21: Added support for checking form variables - (module `/scs/ScsFormVar.sml`). Added two utility packages: - `/scs/ScsDate` and `/scs/ScsList`. Fixed authentication example. It - now works on both PostgreSQL and Oracle. - -* nh 2001-09-17: Added support for cookies, caching. Added - authentication example with simple filtering. - -* mael 2001-07-22: Primitives for accessing the AOLserver - configuration file added to the `Ns` structure. Also added primitive - for getting the url associated with a request. - -### SMLserver version 3.9.2 is released - -* mael 2001-07-19: Proper handling of uncaught exceptions. To avoid - that AOLserver is killed when an SMLserver web-page evaluates to an - uncaught exception, the interpreter no longer uses the exit system - call to terminate execution when an uncaught exception appears. - Instead, the interpreter returns a status code of -1 (or -2 if the - uncaught exception is Interrupt). In case the interpreter returns - -1, a warning is written to the server log. The Interrupt exception - can thus be used to terminate an SMLserver web-page without - generating a warning. - -* mael 2001-07-19: Added Interrupt exception to front end. - -### SMLserver version 3.9.1 is released - -* mael 2001-07-12: Space bug fixed. Each time a request was - served, a new stack was allocated but never freed; the - implementation now recycles allocated stacks. - -* mael 2001-07-12: Functionality for sending email (Ns.sendmail/ - Ns.mail) added to Ns structure. - -* mael 2001-07-12: Support for accessing request headers and - information about server setup added to Ns structure. - -* mael 2001-07-05: Bug fix: valrec may now overwrite identifier - status. Bug reported by Johnny Andersen. - -* mael 2001-07-05: Quotation support. The datatype - - datatype 'a frag = QUOTE of string | ANTIQUOTE of 'a - - is available in the top-level environment. Moreover, the back-tick character - cease to be allowed in symbolic identifiers. Values of the `'a - frag` datatype may be constructed using the quotation/antiquotation - syntax: - - val s = "world" - val a : string frag list = `hello ^s - goodbye` - - Quotation support makes for a nice way of embedding HTML and SQL - in your web-applications. - -* mael 2001-07-05: An uncaught exception now causes the program to - return -1 to the shell (instead of 0). Suggestion by Stephen Weeks. - -* mael 2001-07-05: Bug fix: The function `OS.FileSys.tmpName` now - returns a file name for a file in `/tmp/` (instead of in `/etc/`). Bug - reported by Stephen Weeks. - -* mael & nh: bytecode backend added as an alternative to the x86 - native backend; primarily, the bytecode backend is added for - portability and for use with the SMLserver project, which adds - Standard ML language support to AOLserver -- a webserver from - America Online. diff --git a/README.md b/README.md index 5926ff9a2..cb4272236 100644 --- a/README.md +++ b/README.md @@ -56,10 +56,6 @@ which are built on top of MLKit: * [SMLToJs](/README_SMLTOJS.md). A compiler that compiles all of Standard ML into JavaScript. -* [SMLserver](/README_SMLSERVER.md). A compiler and Apache module that - allow for Standard ML to be efficiently executed in a web-server - context. - * [Barry](/README_BARRY.md). A Standard ML source-to-source compiler that will eliminate modules, using static interpretation and generate optimised Core-language Standard ML code. diff --git a/README_SMLSERVER.md b/README_SMLSERVER.md deleted file mode 100644 index d2b797b38..000000000 --- a/README_SMLSERVER.md +++ /dev/null @@ -1,219 +0,0 @@ -## SMLserver - -See the [SMLserver home page](http://www.smlserver.org) - -SMLserver is an SML module for Apache2. SMLserver supports Web server -interpretation of bytecode compiled Standard ML scripts. Both ML -Server Pages [1] (i.e., msp-files) and plain sml-files, using an SML -interface to the Apache2 API, are supported. - -SMLserver uses a load-once-execute-many scheme for executing sml-files -and msp-files. Together with database pooling, the scheme makes it -possible to create database backed Web sites in Standard ML that are -capable of responding to a high number of requests compared to systems -using a traditional CGI based approach. The database API supports a -variety of different RDBMS's, including Oracle, PostgreSQL, and MySQL. - -Project files (mlb-files) maintained by the Web programmer are used to -keep track of library modules, msp-files, and sml-files that are part -of the Web project. When a page is requested, SMLserver first checks -if the library modules are loaded. If the library modules are not -loaded, SMLserver loads the library modules. Then the page requested -is loaded and executed, leaving the library modules loaded for reuse -by other requests. Only when the project is recompiled or Apache is -restarted, the library modules are reloaded. - -The book "SMLserver - A Functional Approach to Web Publishing (Second -Edition)" [2] is available for download from the SMLserver home page. - -## System Requirements - -To use SMLserver you need the following: - -* Linux Box (e.g. Debian) - -* Apache2. - -* SMLserver. Binary packages and source packages are available from - the SMLserver home page; see the top of this file. - -* An RDBMS. To get access to a database from within your Standard ML - scripts, you need to have an RDBMS system installed that is - supported by SMLserver - see below. One such RDBMS is PostgreSQL, - which you can fetch from www.postgresql.org. Detailed information - about setting up a database with PostgreSQL for the purpose of - using it with SMLserver is given below. - -## Building SMLserver from the Sources Without Database Access - -Requirements: - -1. a working Apache2 webserver -2. apxs2 installed (e.g., apache2-threaded-dev) -3. mlkit >= 4.3.6 compiled and installed -4. bison, flex - -SMLserver installation after unpacking the SMLserver sources into -directory kit: - - $ cd kit - $ ./autobuild - $ ./configure --enable-SMLserver --with-apxs=`which apxs2` --with-compiler=`which mlkit` - $ make smlserver - $ make smlserver_libs - $ sudo make install_smlserver - -Apache2 configuration for SMLserver: - - Edit /etc/apache2/apache2.conf: - Add index.sml to DirectoryIndex list - - Edit /etc/apache2/sites-available/default: - Change DocumentRoot to /home/mael/web/www - Change Directory path to /home/mael/web/www - - $ sudo cp /usr/local/lib/smlserver/lib/mod_sml.so /usr/lib/apache2/modules/ - $ sudo echo "LoadModule sml_module /usr/lib/apache2/modules/mod_sml.so" > /etc/apache2/mods-available/sml.load - -Create the file `/etc/apache2/mods-available/sml.conf` with the following content: - - - AddHandler sml-module .sml - SmlPrjId "web" - SmlPath "/home/mael/web/www/" - SmlInitScript "/home/mael/web/www/../web_sys/init.sml" - - # - # SetHandler None - # RewriteEngine On - # RewriteBase /web/secret - # RewriteRule .* pub.sml - # - -Now execute the following commands: - - $ sudo ln -sf /etc/apache2/mods-available/sml.conf /etc/apache2/mods-enabled/sml.conf - $ sudo ln -sf /etc/apache2/mods-available/sml.load /etc/apache2/mods-enabled/sml.load - $ sudo apache2ctl stop - $ sudo apache2ctl start - -SMLserver configuration and demonstration: - - $ cd $HOME - $ mkdir web - $ cp -pa /usr/local/lib/smlserver/{www,web_sys,web_lib,web_demo_lib} web/ - -Make sure the database configuration lines in `web/web_sys/init.sml` -are commented out. - - $ cd web/www - $ make - -Point your browser to http://localhost/web/ - -## Building SMLserver from the sources with postgresql access - -Additional requirements: - -1. postgresql (e.g., Debian package postgresql-9.1) -2. unixodbc: (e.g., Debian packages unixodbc, unixodbc-dev, odbc-postgresql) - -Do as above, but with the changes below. - -Add the following lines to `/etc/odbc.ini` (replace `user` with your login -name): - - [psql] - Description = PostgreSQL - Driver = /usr/lib/odbc/psqlodbca.so - Database = user - Servername = localhost - -Add `--enable-odbc` to the `./configure` command: - - $ ./configure --enable-SMLserver --with-apxs=`which apxs2` --with-compiler=`which mlkit` --enable-odbc - -After make install_smlserver: - - $ sudo ln -sf /usr/local/lib/smlserver/lib/libsmlodbc.so /usr/lib/ - -Make sure postgresql is started: - - $ sudo /etc/init.d/postgresql-9.1 restart - -Create a database user with the same name as your login name on -the Linux box: - - $ sudo su - postgres - $ createuser -P user - -Invent a new password for the database user. Answer yes to the questions -asked by createuser. - -As user, create a database (also called user) as follows: - - $ createdb $USER - -Install the data models for the sample Web programs by executing: - - $ cd $HOME/web/web_demo_lib/pgsql - $ psql -c "\i all.sql" - -Verify that the database is available using isql: - - $ isql psql user passwd - > select * from guest; - > q - -You should see a message from Homer Simpson... - -Restart Apache2 by executing the commands - - $ sudo apache2ctl stop - $ sudo apache2ctl start - -After copying the sample Web directory to $HOME, as described above, -edit the file `$HOME/web/web_demo_lib/Db.sml`. Make sure that the structure -`DbBackend` passed to the DbFunctor is the structure `Web.DbPgBackend`. -The lines defining the Oracle structure and the `MySQL` structure should -be commented out. - -Edit the file `$HOME/web/web_sys/init.sml`. Enable the Postgresql -configuration lines. - -Compile the sample Web project as described above. - -Go start your Web browser and visit the database examples available -from http://localhost/web/index.sml. - -## Building SMLserver from the sources with oracle access - -To build Oracle interface, first download Oracle Instant Client + -SDK. Then execute the following commands: - - $ cd /abs/path/to/oracle/instant/client/ - $ ln -sf libclntsh.so.10.1 libclntsh.so - $ cd mlkit/kit - -Proceed as above with this configure command: - - $ configure --enable-SMLserver --with-apache=/abs/path/to/apache \ - --with-oracle=/abs/path/to/oracle/instant/client/and/sdk \ - --with-compiler=/path/to/compiler - -Before starting Apache: - - $ unzip instant_client /abs/path/to/smlserver/lib - $ set LD_LIBRARY_PATH to /abs/path/to/smlserver/lib - - -## References - -[1] A system for running ML Server Pages using the Apache Web server - CGI support was first implemented by Peter Sestoft. For - information about this work, consult - http://www.dina.kvl.dk/~sestoft/msp - -[2] Martin Elsman, Niels Hallenberg, and Carsten Varming. SMLserver - - A Functional Approach to Web Publishing. Second Edition. February - 2007. Available from SMLserver home page (see above). diff --git a/basis/.cvsignore b/basis/.cvsignore deleted file mode 100644 index e8600d0f2..000000000 --- a/basis/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -PM MLB *.log run basislib.ul *.vcg CM diff --git a/basis/BinIO.sml b/basis/BinIO.sml index 45f4f021b..63ff618f6 100644 --- a/basis/BinIO.sml +++ b/basis/BinIO.sml @@ -14,6 +14,8 @@ structure BinIO : BIN_IO = * course. Some `conversion' functions: *) + fun getCtx () : foreignptr = prim("__get_ctx",()) + fun fromString (s: string) : vector = Byte.stringToBytes s fun toString (v : vector) : string = Byte.bytesToString v @@ -24,17 +26,17 @@ structure BinIO : BIN_IO = type instream = TextIO.instream (*={ic: int, name : string}*) - fun raiseIo fcn nam exn = + fun raiseIo fcn nam exn = raise IO.Io {function = fcn, name = nam, cause = exn} - fun openIn (f: string) : instream = - {ic=prim ("openInBinStream", (f, CannotOpen)), + fun openIn (f: string) : instream = + {ic=prim ("openInBinStream", (getCtx(), f, CannotOpen)), name=f} handle exn as CannotOpen => raiseIo "openIn" f exn - fun closeIn (is : instream) : unit = + fun closeIn (is : instream) : unit = TextIO.closeIn is - fun input (is : instream) : vector = + fun input (is : instream) : vector = fromString (TextIO.input is) fun inputAll (is : instream) : vector = @@ -57,37 +59,37 @@ structure BinIO : BIN_IO = case TextIO.lookahead is of NONE => NONE | SOME c => SOME (fromChar c); - + (* Binary output: *) type outstream = TextIO.outstream (* = {oc: int, name : string} *) - fun openOut(f: string): outstream = - {oc=prim ("openOutBinStream", (f, CannotOpen)), name=f} + fun openOut (f: string): outstream = + {oc=prim ("openOutBinStream", (getCtx(), f, CannotOpen)), name=f} handle exn as CannotOpen => raiseIo "openOut" f exn - fun openAppend(f: string): outstream = - {oc=prim ("openAppendBinStream", (f, CannotOpen)), name=f} + fun openAppend (f: string): outstream = + {oc=prim ("openAppendBinStream", (getCtx(), f, CannotOpen)), name=f} handle exn as CannotOpen => raiseIo "openAppend" f exn fun closeOut (os : outstream) : unit = TextIO.closeOut os local - fun raiseIo fcn nam exn = - raise IO.Io {function = fcn^"", name = nam^"", cause = exn} - fun output0(os as {oc,name},str:vector,function):unit = - (prim ("outputBinStream", (oc, str, IO.ClosedStream)); + fun raiseIo fcn nam exn = + raise IO.Io {function = fcn^"", name = nam^"", cause = exn} + fun output0 (os as {oc,name},str:vector,function):unit = + (prim ("outputBinStream", (getCtx(), oc, str, IO.ClosedStream)); if os = TextIO.stdErr then TextIO.flushOut os else ()) handle exn as IO.ClosedStream => raiseIo function name exn in - fun output(os : outstream, vec : vector) : unit = + fun output (os : outstream, vec : vector) : unit = output0(os,vec,"output") end - fun output1(os : outstream, w : elem) : unit = + fun output1 (os : outstream, w : elem) : unit = TextIO.output1(os, toChar w) - fun flushOut(os : outstream) : unit = TextIO.flushOut os + fun flushOut (os : outstream) : unit = TextIO.flushOut os - end \ No newline at end of file + end diff --git a/basis/Date.sml b/basis/Date.sml index c610eff8a..86ffb585f 100644 --- a/basis/Date.sml +++ b/basis/Date.sml @@ -37,6 +37,8 @@ structure Date :> DATE = tm_year : int } + fun getCtx () : foreignptr = prim("__get_ctx",()) + fun getlocaltime_ (r : real) : tmoz = prim("sml_localtime", r) fun getunivtime_ (r : real) : tmoz = prim("sml_gmtime", r) fun mktime_ (t : tmoz) : real = prim("sml_mktime", t) @@ -46,8 +48,8 @@ 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,Overflow(*strftime_exn*))) + in fun asctime_ (t : tmoz) : string = prim("sml_asctime", (getCtx(),t,asctime_exn)) + fun strftime_ (s : string, t : tmoz) : string = prim("sml_strftime", (getCtx(),s,t,Overflow(*strftime_exn*))) end val toweekday = fn 0 => Sun | 1 => Mon | 2 => Tue | 3 => Wed diff --git a/basis/FileSys.sml b/basis/FileSys.sml index 487049722..9891f2c0b 100644 --- a/basis/FileSys.sml +++ b/basis/FileSys.sml @@ -1,9 +1,9 @@ (* FileSys -- 1995-06-16, 1995-09-25, 1996-05-01, 1996-10-13 *) -(* The preliminary OS structure defined here is +(* The preliminary OS structure defined here is * hidden by a redeclaration later.. *) -structure OS = +structure OS = struct type syserror = int exception SysErr = Initial2.SysErr @@ -12,20 +12,20 @@ structure OS = fun errorMsg (err : int) : string = prim("sml_errormsg", err) fun errorName (err : int) : string = let - val s = prim("sml_errorName", err : int) : string + val s = prim("sml_errorName", err : int) : string in if isNull s then raise Fail ("OS.errorName: " ^ Int.toString err ^ " not a valid error number") else - let + let val a = String.map Char.toLower (Byte.unpackStringVec(Word8VectorSlice.slice((Byte.stringToBytes s),1,NONE))) in if a = "2big" then "toobig" else a end end - fun syserror (err : string) : syserror option = + fun syserror (err : string) : syserror option = let val err = if err = "toobig" then "E2BIG" else "E" ^ (String.map Char.toUpper err) - val s = prim("@sml_syserror", err : string) : int + val s = prim("@sml_syserror", err : string) : int in if s = ~1 then NONE else SOME s end @@ -40,19 +40,21 @@ structure FileSys : OS_FILE_SYS = type file_id = {dev:int,ino:int} (* with ordering *) infix << - fun ({dev,ino} : file_id) << ({dev=dev',ino=ino'} : file_id) : bool = + fun ({dev,ino} : file_id) << ({dev=dev',ino=ino'} : file_id) : bool = dev < dev' orelse (dev = dev' andalso ino < ino') (* Primitives from Runtime/IO.c -- raise Fail on error *) val failexn = Initial.FileSys.filesys_fail - fun chdir_ (s : string) : unit = prim("sml_chdir", (s, failexn)) - fun remove_ (s : string) : unit = prim("sml_remove", (s, failexn)) - fun rename_ (s1 : string, s2 : string) : unit = prim("sml_rename", (s1, s2, failexn)) - fun access_ (s : string, i : int) : bool = prim("sml_access", (s, i, failexn)) - fun getdir_ () : string = prim("sml_getdir", failexn) - fun isdir_ (s : string) : bool = prim("sml_isdir", (s,failexn)) - fun mkdir_ (s : string) : unit = prim("sml_mkdir", (s, failexn)) + fun getCtx () : foreignptr = prim("__get_ctx",()) + + fun chdir_ (s : string) : unit = prim("sml_chdir", (getCtx(), s, failexn)) + fun remove_ (s : string) : unit = prim("sml_remove", (getCtx(), s, failexn)) + fun rename_ (s1 : string, s2 : string) : unit = prim("sml_rename", (getCtx(), s1, s2, failexn)) + fun access_ (s : string, i : int) : bool = prim("sml_access", (s, i)) + fun getdir_ () : string = prim("sml_getdir", (getCtx(), failexn)) + fun isdir_ (s : string) : bool = prim("sml_isdir", (getCtx(), s,failexn)) + fun mkdir_ (s : string) : unit = prim("sml_mkdir", (getCtx(), s, failexn)) fun tmpnam_ (c: int) : string = if c > 10 then raise failexn else @@ -61,27 +63,26 @@ structure FileSys : OS_FILE_SYS = in if access_(f,0) then tmpnam_(c+1) else f end - fun modtime_ (s : string) : real = prim("sml_modtime", (s, failexn)) - fun rmdir_ (s : string) : unit = prim("sml_rmdir", (s, failexn)) - fun settime_ (s : string, r : real) : unit = prim("sml_settime", (s,r,failexn)) - fun filesize_ (s : string) : int = prim("sml_filesize", (s, failexn)) - fun opendir_ (s : string) : dirstruct_ = prim("sml_opendir", (s, failexn)) - fun readdir_ (d : dirstruct_) : string = prim("sml_readdir", (d,failexn)) + fun modtime_ (s : string) : real = prim("sml_modtime", (getCtx(), s, failexn)) + fun rmdir_ (s : string) : unit = prim("sml_rmdir", (getCtx(), s, failexn)) + fun settime_ (s : string, r : real) : unit = prim("sml_settime", (getCtx(), s,r,failexn)) + fun filesize_ (s : string) : int = prim("sml_filesize", (getCtx(), s, failexn)) + fun opendir_ (s : string) : dirstruct_ = prim("sml_opendir", (getCtx(), s, failexn)) + fun readdir_ (d : dirstruct_) : string = prim("sml_readdir", (getCtx(), d,failexn)) fun rewinddir_ (d : dirstruct_) : unit = prim("sml_rewinddir", d) - fun closedir_ (d : dirstruct_) : unit = prim("sml_closedir", (d, failexn)) + fun closedir_ (d : dirstruct_) : unit = prim("sml_closedir", (getCtx(), d, failexn)) fun errno_ () : OS.syserror = prim("sml_errno", ()) fun errormsg_ (err : OS.syserror) : string = prim("sml_errormsg", err) fun mkerrno_ (i : int) : OS.syserror = prim("id", i) - fun islink_ (s : string) : bool = prim("sml_islink", (s, failexn)) - fun isreg_ (s : string) : bool = prim("sml_isreg", (s, failexn)) - fun readlink_ (s : string) : string = prim("sml_readlink", (s, failexn)) - fun realpath_ (s : string) : string = prim("sml_realpath", (s, failexn)) - fun devinode_ (s : string) : file_id = prim("sml_devinode", (s, failexn)) + fun islink_ (s : string) : bool = prim("sml_islink", (getCtx(), s, failexn)) + fun isreg_ (s : string) : bool = prim("sml_isreg", (getCtx(), s, failexn)) + fun readlink_ (s : string) : string = prim("sml_readlink", (getCtx(), s, failexn)) + fun realpath_ (s : string) : string = prim("sml_realpath", (getCtx(), s, failexn)) + fun devinode_ (s : string) : file_id = prim("sml_devinode", (getCtx(), s, failexn)) fun int_to_word_ (i : int) : word = prim("id", i) fun isNull (s : string) = prim("__is_null", s) : bool - fun formatErr mlOp (SOME operand) reason = mlOp ^ " failed on `" ^ operand ^ "': " ^ reason | formatErr mlOp NONE reason = @@ -202,7 +203,7 @@ structure FileSys : OS_FILE_SYS = | readDir (arg as ref (SOME dstr)) = let val e = (SOME (readdir_ dstr)) handle Fail _ => NONE in - Option.join(Option.map(fn entry => + Option.join(Option.map(fn entry => if entry <> Path.parentArc andalso entry <> Path.currentArc then SOME entry else diff --git a/basis/INET_SOCK.sig b/basis/INET_SOCK.sig new file mode 100644 index 000000000..6c7cb41d2 --- /dev/null +++ b/basis/INET_SOCK.sig @@ -0,0 +1,27 @@ +(** InetSock interface + +This structure provides operations for creating and manipulating +Internet-domain addresses and sockets. + +*) + +signature INET_SOCK = sig + type inet + type 'st sock = (inet,'st) Socket.sock + type 'm stream_sock = 'm Socket.stream sock + type sock_addr = inet Socket.sock_addr + val inetAF : Socket.AF.addr_family +(* + val toAddr : NetHostDB.in_addr * int -> sock_addr + val fromAddr : sock_addr -> NetHostDB.in_addr * int +*) + val any : int -> sock_addr + structure TCP : sig + val socket : unit -> 'm stream_sock +(* + val socket' : int -> 'm stream_sock + val getNODELAY : 'm stream_sock -> bool + val setNODELAY : 'm stream_sock * bool -> unit +*) + end +end diff --git a/basis/Initial.sml b/basis/Initial.sml index 04c69cfdf..8c0429ef4 100644 --- a/basis/Initial.sml +++ b/basis/Initial.sml @@ -338,6 +338,4 @@ structure Initial = end end - - end diff --git a/basis/MIT_LICENSE b/basis/MIT_LICENSE index de786f15f..c16bd6066 100644 --- a/basis/MIT_LICENSE +++ b/basis/MIT_LICENSE @@ -1,6 +1,7 @@ The MIT License -Copyright (c) 2004-2012 IT University of Copenhagen, 2008-2012 Martin Elsman +Copyright (c) 2004-2012 IT University of Copenhagen, 2008-2021 Martin +Elsman Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/basis/NET_HOST_DB.sml b/basis/NET_HOST_DB.sig similarity index 73% rename from basis/NET_HOST_DB.sml rename to basis/NET_HOST_DB.sig index 14e972430..abd13475b 100644 --- a/basis/NET_HOST_DB.sml +++ b/basis/NET_HOST_DB.sig @@ -1,25 +1,33 @@ +(** NetHostDB interface + +This structure provides functionality for accessing the information +contained in the network host data base. The structure can be used to +convert host names to Internet addresses. + +*) + signature NET_HOST_DB = sig eqtype in_addr eqtype addr_family type entry - val name : entry -> string - val aliases : entry -> string list - val addrType : entry -> addr_family - val addr : entry -> in_addr - val addrs : entry -> in_addr list - val getByName : string -> entry option - val getByAddr : in_addr -> entry option + val name : entry -> string + val aliases : entry -> string list + val addrType : entry -> addr_family + val addr : entry -> in_addr + val addrs : entry -> in_addr list + val getByName : string -> entry option + val getByAddr : in_addr -> entry option val getHostName : unit -> string - val toString : in_addr -> string - val scan : (char, 'a) StringCvt.reader - -> (in_addr, 'a) StringCvt.reader - val fromString : string -> in_addr option + val toString : in_addr -> string + val scan : (char, 'a) StringCvt.reader + -> (in_addr, 'a) StringCvt.reader + val fromString : string -> in_addr option end -(* +(** eqtype in_addr The type representing an Internet address. @@ -78,15 +86,15 @@ fromString s Addresses in this notation have one of the following forms: a - where a is a 32-bit unsigned integer constant. + where a is a 32-bit unsigned integer constant. a.b where a is an 8-bit unsigned integer constant, and b is a 24-bit - integer constant. + integer constant. a.b.c where a and b are 8-bit unsigned integer constants, and c is a 16-bit - integer constant. + integer constant. a.b.c.d - where a, b, c, and d are 8-bit integer constants. + where a, b, c, and d are 8-bit integer constants. The integer constants may be decimal, octal, or hexadecimal, as specified in the C language. diff --git a/basis/NetHostDb.sml b/basis/NetHostDb.sml new file mode 100644 index 000000000..efefc1133 --- /dev/null +++ b/basis/NetHostDb.sml @@ -0,0 +1,235 @@ +structure NetHostDb :> NET_HOST_DB = struct + +fun not_impl s = raise Fail ("not implemented: " ^ s) + +fun isNull s = prim("__is_null",s : string) : bool + +(* error utilities *) + +fun failure s = + let fun errno () : int = prim("sml_errno",()) + fun errmsg (i : int) : string = prim("sml_errormsg", i) + in raise Fail (s ^ ": " ^ errmsg(errno())) + end + +type in_addr = int (* IPv4 *) + +type addr_family = int + +type entry = + { addrType : addr_family, + addrs : in_addr list, + aliases : string list, + name : string, + xerr : int } + +fun name (e:entry) = #name e + +fun aliases (e:entry) = #aliases e + +fun addrType (e:entry) = #addrType e + +fun addrs (e:entry) = #addrs e +fun addr (e:entry) = + case #addrs e of + a :: _ => a + | _ => raise Fail "NetHostDb.addr: impossible" + +fun repair ({addrType,addrs,aliases,name,xerr}:entry) : entry option = + if xerr < 0 then NONE + else SOME {addrType=addrType, + addrs=List.rev addrs, + aliases=List.rev aliases, + name=name, + xerr=xerr} + +fun getByName (n:string) : entry option = + let val e : entry = prim("sml_gethostbyname", n) + in repair e + end + +fun getByAddr (a: in_addr) : entry option = + let val e : entry = prim("sml_gethostbyaddr", a) + in repair e + end + +fun getHostName () : string = + let val res = prim("sml_gethostname",()) + in if isNull res then failure "NetHostDb.getHostName" + else res + end + +fun toString (a:in_addr) : string = + let val res = prim("sml_inaddr_tostring",a) + in if isNull res then failure "NetHostDb.toString" + else res + end + +(* The scan function below is copied from MLton + https://github.com/MLton/mlton/blob/master/basis-library/net/net-host-db.sml + together with StringCvtfunctionality from + https://github.com/MLton/mlton/blob/master/basis-library/text/string-cvt.sml + (slightly modified) + + MLton is released under an HPND-style license; see + ../doc/license/MLton-HPND-LICENSE for details. +*) + +val radixToInt: StringCvt.radix -> int = + fn StringCvt.BIN => 2 + | StringCvt.OCT => 8 + | StringCvt.DEC => 10 + | StringCvt.HEX => 16 + +val radixToWord: StringCvt.radix -> word = Word.fromInt o radixToInt + +fun radixFn off l h c = + if c < l orelse c > h then NONE + else SOME (Char.ord c - off) + +fun charToDigit (radix: StringCvt.radix): char -> int option = + case radix of + StringCvt.BIN => radixFn 48 #"0" #"1" + | StringCvt.OCT => radixFn 48 #"0" #"7" + | StringCvt.DEC => radixFn 48 #"0" #"9" + | StringCvt.HEX => fn c => case radixFn 48 #"0" #"9" c of + NONE => + (case radixFn 65 #"A" #"F" c of + NONE => radixFn 97 #"a" #"f" c + | res => res) + | res => res + +fun charToWDigit radix = (Option.map Word.fromInt) o (charToDigit radix) + +fun wdigits radix reader state = + let + val op + = Word.+ + val op * = Word.* + val r = radixToWord radix + fun loop (accum, state) = + case reader state of + NONE => SOME (accum, state) + | SOME (c, state') => + case charToWDigit radix c of + NONE => SOME (accum, state) + | SOME n => loop (n + accum * r, state') + in case reader state of + NONE => NONE + | SOME (c, state) => + case charToWDigit radix c of + NONE => NONE + | SOME n => loop (n, state) + end + +fun scan0 reader state = + let + fun scanW state = + case reader state of + SOME (#"0", state') => + (case reader state' of + NONE => SOME (0w0, state') + | SOME (c, state'') => + if Char.isDigit c + then wdigits StringCvt.OCT reader state' + else if c = #"x" orelse c = #"X" + then wdigits StringCvt.HEX reader state'' + else SOME (0w0, state')) + | _ => wdigits StringCvt.DEC reader state + fun loop (n, state, acc) = + if n <= 0 + then List.rev acc + else let + fun finish (w, state) = + case reader state of + SOME (#".", state') => + loop (n - 1, state', (w, state)::acc) + | _ => List.rev ((w, state)::acc) + in + case scanW state of + SOME (w, state') => finish (w, state') + | NONE => List.rev acc + end + val l = loop (4, state, []) + fun get1 w = + (Word8.fromLarge (Word.toLarge (Word.andb (w, 0wxFF))), + Word.>>(w, 0w8)) + fun get2 w = + let + val (a,w) = get1 w + val (b,w) = get1 w + in (a,b,w) + end + fun get3 w = + let + val (a,b,w) = get2 w + val (c,w) = get1 w + in (a,b,c,w) + end + fun get4 w = + let + val (a,b,c,w) = get3 w + val (d,w) = get1 w + in (a,b,c,d,w) + end + fun try l = + case l of + [] => NONE + | [(w, statew)] => + let + val (d,c,b,a,w) = get4 w + in + if w = 0wx0 + then SOME (Vector.fromList [a,b,c,d], statew) + else NONE + end + | [(x, statex), (w, statew)] => + let + val (d,c,b,w) = get3 w + val (a,x) = get1 x + in + if w = 0wx0 andalso x = 0wx0 + then SOME (Vector.fromList [a,b,c,d], statew) + else try [(x, statex)] + end + | [(y, statey), (x, statex), (w, statew)] => + let + val (d,c,w) = get2 w + val (b,x) = get1 x + val (a,y) = get1 y + in + if w = 0wx0 andalso x = 0wx0 andalso y = 0wx0 + then SOME (Vector.fromList [a,b,c,d], statew) + else try [(y, statey), (x, statex)] + end + | [(z, statez), (y, statey), (x, statex), (w, statew)] => + let + val (d,w) = get1 w + val (c,x) = get1 x + val (b,y) = get1 y + val (a,z) = get1 z + in + if w = 0wx0 andalso x = 0wx0 andalso y = 0wx0 andalso z = 0wx0 + then SOME (Vector.fromList [a,b,c,d], statew) + else try [(z, statez), (y, statey), (x, statex)] + end + | _ => NONE + in + try l + end + +fun scan (reader: (char,'a)StringCvt.reader) : (in_addr,'a)StringCvt.reader = + fn (a : 'a) => + case scan0 reader a of + NONE => NONE + | SOME(v,a) => + if Vector.length v > 4 then + failure "NetHostDb.scan" + else + let val toW = Word.fromLarge o Word8.toLarge + val w = Vector.foldl (fn (w8,w) => Word.orb(Word.<<(w,0w8),toW w8)) 0w0 v + in SOME(Word.toInt w, a) + end + +fun fromString s = StringCvt.scanString scan s + +end diff --git a/basis/Posix.sml b/basis/Posix.sml index d0b86b05c..180f9b2c8 100644 --- a/basis/Posix.sml +++ b/basis/Posix.sml @@ -67,12 +67,13 @@ functor CreateWriterReader (S : sig val vectorLength : vector -> int end) = struct + fun getCtx () : foreignptr = prim("__get_ctx",()) open S val failexn = Initial.FileSys.filesys_fail - fun isreg_ (s : file_desc) : bool = prim("sml_isreg", (s, failexn)) + fun isreg_ (s : file_desc) : bool = prim("sml_isreg", (getCtx(), s, failexn)) fun isReg fd = (isreg_ fd) handle Fail s => raiseSys ("isReg " ^ (Int.toString fd)) NONE "" - fun filesize_ (s : file_desc) : int = prim("sml_filesizefd", (s, failexn)) + fun filesize_ (s : file_desc) : int = prim("sml_filesizefd", (getCtx(), s, failexn)) fun fileSize fd = (filesize_ fd) handle Fail s => raiseSys "filesize" NONE "" exception ClosedStream = Initial.ClosedStream @@ -219,6 +220,7 @@ functor CreateWriterReader (S : sig structure Posix :> POSIX = struct + fun getCtx () : foreignptr = prim("__get_ctx",()) structure Signal : POSIX_SIGNAL = struct type signal = int @@ -402,7 +404,7 @@ struct fun sysconf (s : string) = let - fun rsys i = (prim ("sml_sysconf", i : int) : int) + fun rsys i = (prim ("sml_sysconf", (getCtx(), i : int)) : int) handle Overflow => raise OS.SysErr ("Not supported", NONE) in SysWord.fromInt @@ -432,7 +434,7 @@ struct cutime_usec : int, cstime_sec : int, cstime_usec : int - ) = (prim ("sml_times", ())) + ) = (prim ("sml_times", (getCtx()))) handle Overflow => raiseSys "Posix.ProcEnv.times" NONE "" @@ -480,7 +482,7 @@ struct fun getgroups () = let val e = OS.SysErr ("Posix.ProcEnv.getgroups", NONE) - val (r,l) = prim("sml_getgroups", e : exn) : (int * int list) + val (r,l) = prim("sml_getgroups", (getCtx(), e : exn)) : (int * int list) in if r = ~1 then raiseSys "Posix.ProcEnv.getgroups" NONE "" else l end @@ -1021,7 +1023,7 @@ struct val s = SysWord.toInt(ProcEnv.sysconf "_SC_GETGR_R_SIZE_MAX") val e = OS.SysErr ("getgrgid: no group with gid = " ^ (Int.toString g) ^ " found", NONE) - val (n,m,res) = prim("sml_getgrgid", (g : int, s : int, e : exn)) + val (n,m,res) = prim("sml_getgrgid", (getCtx(), g : int, s : int, e : exn)) : (string * string list * int) val res' = Error.fromWord(SysWord.fromInt res) in @@ -1033,7 +1035,7 @@ struct let val s = SysWord.toInt(ProcEnv.sysconf "_SC_GETGR_R_SIZE_MAX") val e = OS.SysErr ("getgrnam: no group with groupname = " ^ n ^ " found", NONE) - val (g,m,res) = prim("sml_getgrnam", (n : string, s : int, e : exn)) + val (g,m,res) = prim("sml_getgrnam", (getCtx(), n : string, s : int, e : exn)) : (int * string list * int) val res' = Error.fromWord(SysWord.fromInt res) in @@ -1045,7 +1047,7 @@ struct let val s = SysWord.toInt(ProcEnv.sysconf "_SC_GETPW_R_SIZE_MAX") val e = OS.SysErr ("getpwnam: no user with username = " ^ n ^ " found", NONE) - val (u,g,h,s,res) = prim("sml_getpwnam", (n : string, s : int, e : exn)) + val (u,g,h,s,res) = prim("sml_getpwnam", (getCtx(), n : string, s : int, e : exn)) : (int * int * string * string * int) val res' = Error.fromWord(SysWord.fromInt res) in @@ -1057,7 +1059,7 @@ struct let val s = SysWord.toInt(ProcEnv.sysconf "_SC_GETPW_R_SIZE_MAX") val e = OS.SysErr ("getpwuid: no user with uid = " ^ (Int.toString u) ^ " found", NONE) - val (n,g,h,s,res) = prim("sml_getpwuid", (u : int, s : int, e : exn)) + val (n,g,h,s,res) = prim("sml_getpwuid", (getCtx(), u : int, s : int, e : exn)) : (string * int * string * string * int) val res' = Error.fromWord(SysWord.fromInt res) in diff --git a/basis/Process.sml b/basis/Process.sml index 418e71814..165fc3b81 100644 --- a/basis/Process.sml +++ b/basis/Process.sml @@ -11,39 +11,39 @@ structure Process : OS_PROCESS = fun isSuccess 0 = true | isSuccess _ = false - local + fun getCtx () : foreignptr = prim("__get_ctx",()) + + local val exn = Fail "Process" - fun system_ (s: string) : status = prim("sml_system", (s,exn)) - fun getenv_ (s: string) : string = prim("sml_getenv", (s, exn)) - in - fun system s = system_ s handle _ => failure + fun getenv_ (s: string) : string = prim("sml_getenv", (getCtx(), s, exn)) + in + fun system (s: string) : status = prim("sml_system", s) fun getEnv s = (SOME (getenv_ s)) handle _ => NONE end fun terminate (s:status) : 'a = prim("terminateML", s) - local + local val exittasks = Initial.exittasks val exitCalled = Initial.exitCalled val exp = Initial.RaisedInExit - in + in fun atExit newtask = if !exitCalled then () else exittasks := newtask :: !exittasks fun exit status = - if (!exitCalled) then raise exp else - (exitCalled := true ; + if (!exitCalled) then raise exp else + (exitCalled := true ; List.app (fn f => (f ()) handle _ => ()) (!exittasks); - exittasks := [] ; + exittasks := [] ; terminate status) end - fun sleep t = + fun sleep t = let val s = Int.fromLarge(Time.toSeconds t) val m = Int.fromLarge(Time.toMicroseconds(Time.-(t, Time.fromSeconds (Int.toLarge s)))) in - if (s < 0 orelse m < 0) then () else + if (s < 0 orelse m < 0) then () else (prim("sml_microsleep", (s : int, m : int)) : (int * int * int) ; ()) end end - diff --git a/basis/Real.sml b/basis/Real.sml index 2d92584ea..565caed4f 100644 --- a/basis/Real.sml +++ b/basis/Real.sml @@ -5,9 +5,12 @@ structure Real : REAL = (* Primitives *) 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 getCtx () : foreignptr = prim("__get_ctx",()) + + fun floor (x : real) : int = prim ("floorFloat", (getCtx(),x)) (* may raise Overflow *) + fun ceil (x : real) : int = prim ("ceilFloat", (getCtx(),x)) (* may raise Overflow *) + fun trunc (x : real) : int = prim ("truncFloat", (getCtx(),x)) (* may raise Overflow *) fun realFloor (x: real) : real = prim ("realFloor", x) fun realCeil (x: real) : real = prim ("realCeil", x) diff --git a/basis/SOCKET.sig b/basis/SOCKET.sig new file mode 100644 index 000000000..906057fc9 --- /dev/null +++ b/basis/SOCKET.sig @@ -0,0 +1,596 @@ +(** Socket interface *) + +signature SOCKET = sig + type ('af,'st) sock (* af (addr family) : INetSock.inet or UnixSock.unix *) + type 'af sock_addr (* st (socket type) : dgram or stream *) + (*type dgram*) + type 'm stream (* m (mode) : active or passive *) + type passive + type active + + structure AF : sig + eqtype addr_family + val list : unit -> (string * addr_family) list + val toString : addr_family -> string + val fromString : string -> addr_family option + end + + structure SOCK : sig + eqtype sock_type + val stream : sock_type + val dgram : sock_type + val list : unit -> (string * sock_type) list + val toString : sock_type -> string + val fromString : string -> sock_type option + end + + structure Ctl : sig + val getDEBUG : ('af, 'st) sock -> bool + val setDEBUG : ('af, 'st) sock * bool -> unit + val getREUSEADDR : ('af, 'st) sock -> bool + val setREUSEADDR : ('af,'st) sock * bool -> unit + val getKEEPALIVE : ('af, 'st) sock -> bool + val setKEEPALIVE : ('af, 'st) sock * bool -> unit + val getDONTROUTE : ('af, 'st) sock -> bool + val setDONTROUTE : ('af, 'st) sock * bool -> unit +(* + val getLINGER : ('af, 'st) sock -> Time.time option + val setLINGER : ('af, 'st) sock * Time.time option -> unit +*) + val getBROADCAST : ('af, 'st) sock -> bool + val setBROADCAST : ('af, 'st) sock * bool -> unit + val getOOBINLINE : ('af, 'st) sock -> bool + val setOOBINLINE : ('af, 'st) sock * bool -> unit + val getSNDBUF : ('af, 'st) sock -> int + val setSNDBUF : ('af, 'st) sock * int -> unit + val getRCVBUF : ('af, 'st) sock -> int + val setRCVBUF : ('af, 'st) sock * int -> unit + val getTYPE : ('af, 'st) sock -> SOCK.sock_type + val getERROR : ('af, 'st) sock -> bool +(* + val getPeerName : ('af, 'st) sock -> 'af sock_addr + val getSockName : ('af, 'st) sock -> 'af sock_addr + val getNREAD : ('af, 'st) sock -> int + val getATMARK : ('af, active stream) sock -> bool +*) + end + + val sameAddr : 'af sock_addr * 'af sock_addr -> bool + val familyOfAddr : 'af sock_addr -> AF.addr_family + + val bind : ('af, 'st) sock * 'af sock_addr -> unit + val listen : ('af, passive stream) sock * int -> unit + val accept : ('af, passive stream) sock + -> ('af, active stream) sock * 'af sock_addr +(* + val acceptNB : ('af, passive stream) sock + -> (('af, active stream) sock + * 'af sock_addr) option + val connect : ('af, 'st) sock * 'af sock_addr -> unit + val connectNB : ('af, 'st) sock * 'af sock_addr -> bool +*) + + val close : ('af, 'st) sock -> unit + + datatype shutdown_mode + = NO_RECVS + | NO_SENDS + | NO_RECVS_OR_SENDS + val shutdown : ('af, 'mode stream) sock * shutdown_mode -> unit + + type sock_desc + val sockDesc : ('af, 'st) sock -> sock_desc + val sameDesc : sock_desc * sock_desc -> bool + + val select : { rds : sock_desc list, + wrs : sock_desc list, + exs : sock_desc list, + timeout : Time.time option + } + -> { rds : sock_desc list, + wrs : sock_desc list, + exs : sock_desc list + } + + val ioDesc : ('af, 'st) sock -> OS.IO.iodesc + + type out_flags = {don't_route : bool, oob : bool} + type in_flags = {peek : bool, oob : bool} + + val sendVec : ('af, active stream) sock * Word8VectorSlice.slice -> int + val sendArr : ('af, active stream) sock * Word8ArraySlice.slice -> int + +(* + val sendVec' : ('af, active stream) sock * Word8VectorSlice.slice * out_flags -> int + val sendArr' : ('af, active stream) sock * Word8ArraySlice.slice * out_flags -> int + val sendVecNB : ('af, active stream) sock * Word8VectorSlice.slice -> int option + val sendVecNB' : ('af, active stream) sock * Word8VectorSlice.slice * out_flags -> int option + val sendArrNB : ('af, active stream) sock * Word8ArraySlice.slice -> int option + val sendArrNB' : ('af, active stream) sock * Word8ArraySlice.slice * out_flags -> int option +*) + + val recvVec : ('af, active stream) sock * int -> Word8Vector.vector + +(* + val recvVec' : ('af, active stream) sock * int * in_flags -> Word8Vector.vector + val recvArr : ('af, active stream) sock * Word8ArraySlice.slice -> int + val recvArr' : ('af, active stream) sock * Word8ArraySlice.slice * in_flags -> int + val recvVecNB : ('af, active stream) sock * int -> Word8Vector.vector option + val recvVecNB' : ('af, active stream) sock * int * in_flags -> Word8Vector.vector option + val recvArrNB : ('af, active stream) sock * Word8ArraySlice.slice -> int option + val recvArrNB' : ('af, active stream) sock * Word8ArraySlice.slice * in_flags -> int option + + val sendVecTo : ('af, dgram) sock * 'af sock_addr * Word8VectorSlice.slice -> unit + val sendArrTo : ('af, dgram) sock * 'af sock_addr * Word8ArraySlice.slice -> unit + val sendVecTo' : ('af, dgram) sock * 'af sock_addr * Word8VectorSlice.slice * out_flags -> unit + val sendArrTo' : ('af, dgram) sock * 'af sock_addr * Word8ArraySlice.slice * out_flags -> unit + val sendVecToNB : ('af, dgram) sock * 'af sock_addr * Word8VectorSlice.slice -> bool + val sendVecToNB' : ('af, dgram) sock * 'af sock_addr * Word8VectorSlice.slice * out_flags -> bool + val sendArrToNB : ('af, dgram) sock * 'af sock_addr * Word8ArraySlice.slice -> bool + val sendArrToNB' : ('af, dgram) sock * 'af sock_addr * Word8ArraySlice.slice * out_flags -> bool + + val recvVecFrom : ('af, dgram) sock * int -> Word8Vector.vector * 'st sock_addr + val recvVecFrom' : ('af, dgram) sock * int * in_flags -> Word8Vector.vector * 'st sock_addr + val recvArrFrom : ('af, dgram) sock * Word8ArraySlice.slice -> int * 'af sock_addr + val recvArrFrom' : ('af, dgram) sock * Word8ArraySlice.slice * in_flags -> int * 'af sock_addr + val recvVecFromNB : ('af, dgram) sock * int -> (Word8Vector.vector * 'st sock_addr) option + val recvVecFromNB' : ('af, dgram) sock * int * in_flags -> + (Word8Vector.vector * 'st sock_addr) option + val recvArrFromNB : ('af, dgram) sock * Word8ArraySlice.slice -> (int * 'af sock_addr) option + val recvArrFromNB' : ('af, dgram) sock * Word8ArraySlice.slice * in_flags + -> (int * 'af sock_addr) option +*) +end + +(** + +Description: + +type ('af,'st) sock + The type of a socket. Sockets are polymorphic over both the address family + and the socket type. The type parameter 'af is instantiated with the + appropriate address family type (INetSock.inet or UnixSock.unix). The type + parameter 'st is instantiated with the appropriate socket type + (dgram or stream). + +type 'af sock_addr + The type of a socket address. The type parameter 'af describes the address + family of the address (INetSock.inet or UnixSock.unix). + +type dgram + The witness type for datagram sockets. + +type 'mode stream + The witness type for stream sockets. The type parameter 'mode describes the + mode of the stream socket: active or passive. + +structure AF + The AF substructure defines an abstract type that represents the different + network-address families. + + val list : unit -> (string * addr_family) list + This returns a list of all the available address families. Every + element of the list is a pair (name,af) where name is the name of the + address family, and af is the actual address family value. + + The names of the address families are taken from the symbolic constants + used in the C Socket API and stripping the leading ``AF_.'' For + example, the Unix-domain address family is named "UNIX", the + Internet-domain address family is named "INET", and the Apple Talk + address family is named "APPLETALK". + + val toString : addr_family -> string + val fromString : string -> addr_family option + These convert between address family values and their names. For + example, the expression toString (INetSock.inetAF) returns the string + "INET". fromString returns NONE if no family value corresponds to the + given name. + + If a pair (name,af) is in the list returned by list, then it is the + case that name is equal to toString(af). + +structure SOCK + The SOCK substructure provides an abstract type and operations for the + different types of sockets. This type is used by the getTYPE function. + + eqtype sock_type + The type of socket types. + + val stream : sock_type + The stream socket type value. + + val dgram : sock_type + The datagram socket type value. + + val list : unit -> (string * sock_type) list + A list of the available socket types. Every element of the list is of + the form (name,sty) where name is the name of the socket type, and sty + is the actual socket type value. + + The list of possible socket type names includes "STREAM" for stream + sockets, "DGRAM" for datagram sockets, and "RAW" for raw sockets. These + names are formed by taking the symbolic constants from the C API and + removing the leading ``SOCK_.'' + + val toString : sock_type -> string + val fromString : string -> sock_type option + These convert between a socket type value and its name (e.g., + "STREAM"). fromString returns NONE if no socket type value corresponds + to the name. + + If a pair (name,sty) is in the list returned by list, then it is the + case that name is equal to toString(sty). + +structure Ctl + The Ctl substructure provides support for manipulating the options + associated with a socket. These functions raise the SysErr exception when + the argument socket has been closed. + + val getDEBUG : ('af, 'st) sock -> bool + val setDEBUG : ('af, 'st) sock * bool -> unit + These functions query and set the SO_DEBUG flag for the socket. This + flag enables or disables low-level debugging within the kernel. + Enabled, it allows the kernel to maintain a history of the recent + packets that have been received or sent. + + val getREUSEADDR : ('af, 'st) sock -> bool + val setREUSEADDR : ('af, 'st) sock * bool -> unit + These query and set the SO_REUSEADDR flag for the socket. When true, + this flag instructs the system to allow reuse of local socket addresses + in bind calls. + + val getKEEPALIVE : ('af, 'st) sock -> bool + val setKEEPALIVE : ('af, 'st) sock * bool -> unit + These query and set the SO_KEEPALIVE flag for the socket. When true, + the system will generate periodic transmissions on a connected socket, + when no other data is being exchanged. + + val getDONTROUTE : ('af, 'st) sock -> bool + val setDONTROUTE : ('af, 'st) sock * bool -> unit + These query and set the SO_DONTROUTE flag for the socket. When this + flag is true, outgoing messages bypass the normal routing mechanisms of + the underlying protocol, and are instead directed to the appropriate + network interface as specified by the network portion of the + destination address. Note that this option can be specified on a per + message basis by using one of the sendVec', sendArr', sendVecTo', or + sendArrTo' functions. + + val getLINGER : ('af, 'st) sock -> Time.time option + val setLINGER : ('af, 'st) sock * Time.time option + -> unit + These functions query and set the SO_LINGER flag for the socket sock. + This flag controls the action taken when unsent messages are queued on + socket and a close is performed. If the flag is set to NONE, then the + system will close the socket as quickly as possible, discarding data if + necessary. If the flag is set to SOME(t) and the socket promises + reliable delivery, then the system will block the close operation until + the data is delivered or the timeout t expires. If t is negative or too + large, then the Time is raised. + + val getBROADCAST : ('af, 'st) sock -> bool + val setBROADCAST : ('af, 'st) sock * bool -> unit + These query and set the SO_BROADCAST flag for the socket sock, which + enables or disables the ability of the process to send broadcast + messages over the socket. + + val getOOBINLINE : ('af, 'st) sock -> bool + val setOOBINLINE : ('af, 'st) sock * bool -> unit + These query and set the SO_OOBINLINE flag for the socket. When set, + this indicates that out-of-band data should be placed in the normal + input queue of the socket. Note that this option can be specified on a + per message basis by using one of the sendVec', sendArr', sendVecTo', + or sendArrTo' functions. + + val getSNDBUF : ('af, 'st) sock -> int + val setSNDBUF : ('af, 'st) sock * int -> unit + These query and set the size of the send queue buffer for the socket. + + val getRCVBUF : ('af, 'st) sock -> int + val setRCVBUF : ('af, 'st) sock * int -> unit + These query and set the size of receive queue buffer for the socket. + + val getTYPE : ('af, 'st) sock -> SOCK.sock_type + This returns the socket type of the socket. + + val getERROR : ('af, 'st) sock -> bool + This indicates whether or not an error has occurred. + + val getPeerName : ('af, 'st) sock -> 'af sock_addr + This returns the socket address to which the socket is connected. + + val getSockName : ('af, 'st) sock -> 'af sock_addr + This returns the socket address to which the socket is bound. + + val getNREAD : ('af, 'st) sock -> int + This returns the number of bytes available for reading on the socket. + + val getATMARK : ('af, active stream) sock -> bool + This indicates whether or not the read pointer on the socket is + currently at the out-of-band mark. + +val sameAddr : 'af sock_addr * 'af sock_addr -> bool + This tests whether two socket addresses are the same address. + +familyOfAddr addr + returns the address family of the socket address addr. + +bind (sock, sa) + binds the address sa to the passive socket sock. This function raises + SysErr when the address sa is already in use, when sock is already bound to + an address, or when sock has been closed. + +listen (sock, n) + creates a queue (of size n) for pending questions associated to the socket + sock. The size of queue is limited by the underlying system, but requesting + a queue size larger than the limit does not cause an error (a typical limit + is 128, but older systems use a limit of 5). + + This function raises the SysErr exception if sock has been closed. + +accept sock + extracts the first connection request from the queue of pending connections + for the socket sock. The socket must have been bound to an address via bind + and enabled for listening via listen. If a connection is present, accept + returns a pair (s,sa) consisting of a new active socket s with the same + properties as sock and the address sa of the connecting entity. If no + pending connections are present on the queue then accept blocks until a + connection is requested. One can test for pending connection requests by + using the select function to test the socket for reading. + + This function raises the SysErr exception if sock has not been properly + bound and enabled, or it sock has been closed. + +val acceptNB : ('af, passive stream) sock + -> (('af, active stream) sock + * 'af sock_addr) option + This function is the nonblocking form of the accept operation. If the + operation can complete without blocking (i.e., there is a pending + connection), then this function returns SOME(s,sa), where s is a new active + socket with the same properties as sock and sa is the the address of the + connecting entity. If there are no pending connections, then this function + returns NONE. + + This function raises the SysErr exception if sock has not been properly + bound and enabled, or it sock has been closed. + +connect (sock, sa) + attempts to connect the socket sock to the address sa. If sock is a + datagram socket, the address specifies the peer with which the socket is to + be associated; sa is the address to which datagrams are to be sent, and the + only address from which datagrams are to be received. If sock is a stream + socket, the address specifies another socket to which to connect. + + This function raises the SysErr exception when the address specified by sa + is unreachable, when the connection is refused or times out, when sock is + already connected, or when sock has been closed. + +val connectNB : ('af, 'st) sock * 'af sock_addr + -> bool + This function is the nonblocking form of connect. If the connection can be + established without blocking the caller (which is typically true for + datagram sockets, but not stream sockets), then true is returned. + Otherwise, false is returned and the connection attempt is started; one can + test for the completion of the connection by testing the socket for writing + using the select function. This function will raise SysErr if it is called + on a socket for which a previous connection attempt has not yet been + completed. + +close sock + closes the connection to the socket sock. This function raises the SysErr + exception if the socket has already been closed. + +shutdown (sock, mode) + shuts down all or part of a full-duplex connection on socket sock. If mode + is NO_RECVS, further receives will be disallowed. If mode is NO_SENDS, + further sends will be disallowed. If mode is NO_RECVS_OR_SENDS, further + sends and receives will be disallowed. This function raises the SysErr + exception if the socket is not connected or has been closed. + +type sock_desc + This type is an abstract name for a socket, which is used to support + polling on collections of sockets. + +sockDesc sock + returns a socket descriptor that names the socket sock. + +sameDesc (sd1, sd2) + returns true if the two socket descriptors sd1 and sd2 describe the same + underlying socket. Thus, the expression sameDesc(sockDesc sock, sockDesc + sock) will always return true for any socket sock. + +select {rds, wrs, exs, timeout} + examines the sockets in rds, wrs, and exs to see if they are ready for + reading, writing, or have an exceptional condition pending, respectively. + The calling program is blocked until either one or more of the named + sockets is ``ready '' or the specified timeout expires (where a timeout of + NONE never expires). The result of select is a record of three lists of + socket descriptors containing the ready sockets from the corresponding + argument lists. The order in which socket descriptors appear in the + argument lists is preserved in the result lists. A timeout is signified by + a result of three empty lists. + + This function raises SysErr if any of the argument sockets have been closed + or if the timeout value is negative. + + Note that one can test if a call to accept will block by using select to + see if the socket is ready to read. Similarly, one can use select to test + if a call to connect will block by seeing if the socket is ready to write. + +ioDesc sock + returns the I/O descriptor corresponding to socket sock. This descriptor + can be used to poll the socket via pollDesc and poll in the OS.IO + structure. Using the polling mechanism from OS.IO has the advantage that + different kinds of I/O objects can be mixed, but not all systems support + polling on sockets this way. If an application is only polling sockets, + then it is more portable to use the select function defined above. + +type out_flags = {don't_route : bool, oob : bool} + Flags used in the general form of socket output operations. + +type in_flags = {peek : bool, oob : bool} + Flags used in the general form of socket input operations. + +sendVec (sock, slice) +sendArr (sock, slice) + These functions send the bytes in the slice slice on the active stream + socket sock. They return the number of bytes actually sent. + + These functions raise SysErr if sock has been closed. + +sendVec' (sock, slice, {don't_route, oob}) +sendArr' (sock, slice, {don't_route, oob}) + These functions send the bytes in the slice slice on the active stream + socket sock. They return the number of bytes actually sent. If the + don't_route flag is true, the data is sent bypassing the normal routing + mechanism of the protocol. If oob is true, the data is sent out-of-band, + that is, before any other data which may have been buffered. + + These functions raise SysErr if sock has been closed. + +val sendVecNB : ('af, active stream) sock + * Word8VectorSlice.slice -> int option +val sendVecNB' : ('af, active stream) sock + * Word8VectorSlice.slice + * out_flags -> int option +val sendArrNB : ('af, active stream) sock + * Word8ArraySlice.slice -> int option +val sendArrNB' : ('af, active stream) sock + * Word8ArraySlice.slice + * out_flags -> int option + These functions are the nonblocking versions of sendVec, sendVec', sendArr, + and sendArr' (resp.). They have the same semantics as their blocking forms, + with the exception that when the operation can complete without blocking, + then the result is wrapped in SOME and if the operation would have to wait + to send the data, then NONE is returned instead. + +recvVec (sock, n) +recvVec'(sock, n, {peek,oob}) + These functions receive up to n bytes from the active stream socket sock. + The size of the resulting vector is the number of bytes that were + successfully received, which may be less than n. If the connection has been + closed at the other end (or if n is 0), then the empty vector will be + returned. + + In the second version, if peek is true, the data is received but not + discarded from the connection. If oob is true, the data is received + out-of-band, that is, before any other incoming data that may have been + buffered. + + These functions raise SysErr if the socket sock has been closed and they + raise Size if n < 0 or n > Word8Vector.maxLen. + +recvArr (sock, slice) +recvArr' (sock, slice, {peek, oob}) + These functions read data from the socket sock into the array slice slice. + They return the number of bytes actually received. If the connection has + been closed at the other end or the slice is empty, then 0 is returned. + + For recvArr', if peek is true, the data is received but not discarded from + the connection. If oob is true, the data is received out-of-band, that is, + before any other incoming data that may have been buffered. + + These functions raise SysErr if sock has been closed. + +val recvVecNB : ('af, active stream) sock * int + -> Word8Vector.vector option +val recvVecNB' : ('af, active stream) sock * int * in_flags + -> Word8Vector.vector option +val recvArrNB : ('af, active stream) sock + * Word8ArraySlice.slice -> int option +val recvArrNB' : ('af, active stream) sock + * Word8ArraySlice.slice + * in_flags -> int option + These functions are the nonblocking versions of recvVec, recvVec', recvArr, + and recvArr' (resp.). They have the same semantics as their blocking forms, + with the exception that when the operation can complete without blocking, + then the result is wrapped in SOME and if the operation would have to wait + for input, then NONE is returned instead. + +sendVecTo (sock, sa, slice) +sendArrTo (sock, sa, slice) + These functions send the message specified by the slice slice on the + datagram socket sock to the address sa. + + These functions raise SysErr if sock has been closed or if the socket has + been connected to a different address than sa. + +sendVecTo' (sock, sa, slice, {don't_route, oob}) +sendArrTo' (sock, sa, slice, {don't_route, oob}) + These functions send the message specified by the slice slice on the + datagram socket sock to the address + + If the don't_route flag is true, the data is sent bypassing the normal + routing mechanism of the protocol. If oob is true, the data is sent + out-of-band, that is, before any other data which may have been buffered. + + These functions raise SysErr if sock has been closed or if the socket has + been connected to a different address than sa. + +val sendVecToNB : ('af, dgram) sock + * 'af sock_addr + * Word8VectorSlice.slice -> bool +val sendVecToNB' : ('af, dgram) sock + * 'af sock_addr + * Word8VectorSlice.slice + * out_flags -> bool +val sendArrToNB : ('af, dgram) sock + * 'af sock_addr + * Word8ArraySlice.slice -> bool +val sendArrToNB' : ('af, dgram) sock + * 'af sock_addr + * Word8ArraySlice.slice + * out_flags -> bool + These functions are the nonblocking versions of sendVecTo, sendVecTo', + sendArrTo, and sendArrTo' (resp.). They have the same semantics as their + blocking forms, with the exception that if the operation can complete + without blocking, then the operation is performed and true is returned. + Otherwise, false is returned and the message is not sent. + +recvVecFrom (sock, n) +recvVecFrom' (sock, n, {peek, oob}) + These functions receive up to n bytes on the datagram socket sock, and + return a pair (vec,sa), where the vector vec is the received message, and + sa is the socket address from the which the data originated. If the message + is larger than n, then data may be lost. + + In the second form, if peek is true, the data is received but not discarded + from the connection. If oob is true, the data is received out-of-band, that + is, before any other incoming data that may have been buffered. + + These functions raise SysErr if sock has been closed; they raise Size if n + < 0 or n > Word8Vector.maxLen. + +recvArrFrom (sock, slice) +recvArrFrom' (sock, slice) + These functions read a message from the datagram socket sock into the array + slice slice. If the message is larger than the size of the slice, then + data may be lost. They return the number of bytes actually received. If the + connection has been closed at the other end or the slice is empty, then 0 + is returned. + + For recvArrFrom', if peek is true, the data is received but not discarded + from the connection. If oob is true, the data is received out-of-band, that + is, before any other incoming data that may have been buffered. + + These functions raise SysErr if sock has been closed. + +val recvVecFromNB : ('af, dgram) sock * int + -> (Word8Vector.vector + * 'st sock_addr) option +val recvVecFromNB' : ('af, dgram) sock * int * in_flags + -> (Word8Vector.vector + * 'st sock_addr) option +val recvArrFromNB : ('af, dgram) sock + * Word8ArraySlice.slice + -> (int * 'af sock_addr) option +val recvArrFromNB' : ('af, dgram) sock + * Word8ArraySlice.slice + * in_flags + -> (int * 'af sock_addr) option + These functions are the nonblocking versions of recvVecFrom, recvVecFrom', + recvArrFrom, and recvArrFrom' (resp.). They have the same semantics as + their blocking forms, with the exception that when the operation can + complete without blocking, then the result is wrapped in SOME and if the + operation would have to wait for input, then NONE is returned instead. + +*) diff --git a/basis/SOCKET.sml b/basis/SOCKET.sml index f6347d589..a719cb425 100644 --- a/basis/SOCKET.sml +++ b/basis/SOCKET.sml @@ -1,648 +1,330 @@ -signature SOCKET = - sig - type ('af,'sock_type) sock - type 'af sock_addr - type dgram - type 'mode stream - type passive - type active +local - structure AF : sig - type addr_family = NetHostDB.addr_family - val list : unit -> (string * addr_family) list - val toString : addr_family -> string - val fromString : string -> addr_family option + fun not_impl s = raise Fail ("not implemented: " ^ s) + + fun getCtx () : foreignptr = prim("__get_ctx",()) + + (* error utilities *) + + fun failure s = + let fun errno () : int = prim("sml_errno",()) + fun errmsg (i : int) : string = prim("sml_errormsg", i) + in raise Fail (s ^ ": " ^ errmsg(errno())) end + fun maybe_failure s i = + if i < 0 then failure s + else () + + structure Socket : sig + datatype af = Inet_af | Unix_af + datatype sock_addr0 = + Inet_sa of {addr:int,port:int} + | Unix_sa of {name:string} + type sock0 = {fd:int,af:af} + include SOCKET + where type ('af,'sd) sock = sock0 + where type 'af sock_addr = sock_addr0 + val INADDR_ANY : int + val AF_INET : int + val SO_REUSEADDR : int + val SOCK_STREAM : int + end = struct + + (* see socket.c *) + + val { AF_INET : int + , AF_UNIX : int + , INADDR_ANY : int + , SHUT_RD : int + , SHUT_RDWR : int + , SHUT_WR : int + , SOCK_DGRAM : int + , SOCK_RAW : int + , SOCK_STREAM : int + , SO_BROADCAST : int + , SO_DEBUG : int + , SO_DONTROUTE : int + , SO_ERROR : int + , SO_KEEPALIVE : int + , SO_LINGER : int + , SO_OOBINLINE : int + , SO_RCVBUF : int + , SO_REUSEADDR : int + , SO_SNDBUF : int + , SO_TYPE : int + } = prim("sml_sock_getDefines",()) + + datatype af = Inet_af | Unix_af + + type sock0 = {fd:int, af:af} + + datatype sock_addr0 = + Inet_sa of {addr:int,port:int} + | Unix_sa of {name:string} + + type ('af,'st) sock = sock0 + type 'af sock_addr = sock_addr0 + datatype 'm stream = STREAM + datatype passive = PASSIVE + datatype active = ACTIVE + + structure AF : sig + type addr_family + val list : unit -> (string * addr_family) list + val toString : addr_family -> string + val fromString : string -> addr_family option + end = struct + type addr_family = int + fun list () = + [("INET", AF_INET), + ("UNIX", AF_UNIX)] + fun toString i = + if i = AF_INET then "INET" + else if i = AF_UNIX then "UNIX" + else raise Fail "Socket.AF.toString: impossible" + fun fromString "INET" = SOME AF_INET + | fromString "UNIX" = SOME AF_UNIX + | fromString _ = NONE + end + structure SOCK : sig - eqtype sock_type - val stream : sock_type - val dgram : sock_type - val list : unit -> (string * sock_type) list - val toString : sock_type -> string - val fromString : string -> sock_type option - end + eqtype sock_type + val stream : sock_type + val dgram : sock_type + val list : unit -> (string * sock_type) list + val toString : sock_type -> string + val fromString : string -> sock_type option + end = struct + type sock_type = int + val stream = SOCK_STREAM + val dgram = SOCK_DGRAM + fun list () = [("DGRAM",SOCK_DGRAM), + ("RAW",SOCK_RAW), + ("STREAM",SOCK_STREAM)] + fun toString i = + if i = SOCK_DGRAM then "DGRAM" + else if i = SOCK_RAW then "RAM" + else if i = SOCK_STREAM then "STREAM" + else raise Fail "Socket.SOCK.toString: impossible" + fun fromString "DGRAM" = SOME SOCK_DGRAM + | fromString "RAW" = SOME SOCK_RAW + | fromString "STREAM" = SOME SOCK_STREAM + | fromString _ = NONE + end + + structure Ctl = struct + fun getSockOptInt0 (s:('af, 'st) sock, opt:int) : int = + prim("sml_sock_getsockopt", (#fd s,opt)) + + fun getSockOptInt (opt:int) str (s:('af, 'st) sock) : int = + let val ret = getSockOptInt0(s,opt) + in maybe_failure str ret + ; ret + end + + fun setSockOptInt (opt:int) (str:string) (s:('af, 'st) sock, v:int) : unit = + let val ret = prim("sml_sock_setsockopt", (#fd s,opt,v)) + in maybe_failure str ret + end + + fun getSockOptBool (opt:int) (str:string) (s:('af, 'st) sock) : bool = + let val ret = getSockOptInt0(s,opt) + in maybe_failure str ret + ; ret > 0 + end + + fun setSockOptBool (opt:int) (str:string) (s:('af, 'st) sock, b:bool) : unit = + let val ret = prim("sml_sock_setsockopt", (#fd s,opt,b)) + in maybe_failure str ret + end + + fun getDEBUG s = getSockOptBool SO_DEBUG "Socket.Ctl.getDEBUG" s + fun setDEBUG (s,b) = setSockOptBool SO_DEBUG "Socket.Ctl.setDEBUG" (s,b) + + fun getREUSEADDR s = getSockOptBool SO_REUSEADDR "Socket.Ctl.getREUSEADDR" s + fun setREUSEADDR (s,b) = setSockOptBool SO_REUSEADDR "Socket.Ctl.setREUSEADDR" (s,b) + + fun getKEEPALIVE s = getSockOptBool SO_KEEPALIVE "Socket.Ctl.getKEEPALIVE" s + fun setKEEPALIVE (s,b) = setSockOptBool SO_KEEPALIVE "Socket.Ctl.setKEEPALIVE" (s,b) + + fun getDONTROUTE s = getSockOptBool SO_DONTROUTE "Socket.Ctl.getDONTROUTE" s + fun setDONTROUTE (s,b) = setSockOptBool SO_DONTROUTE "Socket.Ctl.setDONTROUTE" (s,b) + + fun getBROADCAST s = getSockOptBool SO_BROADCAST "Socket.Ctl.getBROADCAST" s + fun setBROADCAST (s,b) = setSockOptBool SO_BROADCAST "Socket.Ctl.setBROADCAST" (s,b) + + fun getOOBINLINE s = getSockOptBool SO_OOBINLINE "Socket.Ctl.getOOBINLINE" s + fun setOOBINLINE (s,b) = setSockOptBool SO_OOBINLINE "Socket.Ctl.setOOBINLINE" (s,b) + + fun getERROR s = getSockOptBool SO_ERROR "Socket.Ctl.getERROR" s - structure Ctl : sig - val getDEBUG : ('af, 'sock_type) sock -> bool - val setDEBUG : ('af, 'sock_type) sock * bool -> unit - val getREUSEADDR : ('af, 'sock_type) sock -> bool - val setREUSEADDR : ('af, 'sock_type) sock * bool - -> unit - val getKEEPALIVE : ('af, 'sock_type) sock -> bool - val setKEEPALIVE : ('af, 'sock_type) sock * bool - -> unit - val getDONTROUTE : ('af, 'sock_type) sock -> bool - val setDONTROUTE : ('af, 'sock_type) sock * bool - -> unit - val getLINGER : ('af, 'sock_type) sock - -> Time.time option - val setLINGER : ('af, 'sock_type) sock - * Time.time option -> unit - val getBROADCAST : ('af, 'sock_type) sock -> bool - val setBROADCAST : ('af, 'sock_type) sock * bool - -> unit - val getOOBINLINE : ('af, 'sock_type) sock -> bool - val setOOBINLINE : ('af, 'sock_type) sock * bool - -> unit - val getSNDBUF : ('af, 'sock_type) sock -> int - val setSNDBUF : ('af, 'sock_type) sock * int -> unit - val getRCVBUF : ('af, 'sock_type) sock -> int - val setRCVBUF : ('af, 'sock_type) sock * int -> unit - val getTYPE : ('af, 'sock_type) sock -> SOCK.sock_type - val getERROR : ('af, 'sock_type) sock -> bool - val getPeerName : ('af, 'sock_type) sock - -> 'af sock_addr - val getSockName : ('af, 'sock_type) sock - -> 'af sock_addr - val getNREAD : ('af, 'sock_type) sock -> int - val getATMARK : ('af, active stream) sock -> bool - end +(* + val getLINGER : ('af, 'st) sock -> Time.time option + val setLINGER : ('af, 'st) sock * Time.time option -> unit +*) - val sameAddr : 'af sock_addr * 'af sock_addr -> bool - val familyOfAddr : 'af sock_addr -> AF.addr_family - - val bind : ('af, 'sock_type) sock * 'af sock_addr -> unit - val listen : ('af, passive stream) sock * int -> unit - val accept : ('af, passive stream) sock - -> ('af, active stream) sock * 'af sock_addr - val acceptNB : ('af, passive stream) sock - -> (('af, active stream) sock - * 'af sock_addr) option - val connect : ('af, 'sock_type) sock * 'af sock_addr - -> unit - val connectNB : ('af, 'sock_type) sock * 'af sock_addr - -> bool - - val close : ('af, 'sock_type) sock -> unit - datatype shutdown_mode - = NO_RECVS - | NO_SENDS - | NO_RECVS_OR_SENDS - val shutdown : ('af, 'mode stream) sock * shutdown_mode - -> unit - - type sock_desc - val sockDesc : ('af, 'sock_type) sock -> sock_desc - val sameDesc : sock_desc * sock_desc -> bool - val select : { - rds : sock_desc list, - wrs : sock_desc list, - exs : sock_desc list, - timeout : Time.time option - } - -> { - rds : sock_desc list, + fun getSNDBUF s = getSockOptInt SO_SNDBUF "Socket.Ctl.getSNDBUF" s + fun setSNDBUF (s,b) = setSockOptInt SO_SNDBUF "Socket.Ctl.setSNDBUF" (s,b) + + fun getRCVBUF s = getSockOptInt SO_RCVBUF "Socket.Ctl.getRCVBUF" s + fun setRCVBUF (s,b) = setSockOptInt SO_RCVBUF "Socket.Ctl.setRCVBUF" (s,b) + + fun getTYPE s : SOCK.sock_type = getSockOptInt SO_TYPE "Socket.Ctl.getTYPE" s + +(* + val getPeerName : ('af, 'st) sock -> 'af sock_addr + val getSockName : ('af, 'st) sock -> 'af sock_addr + val getNREAD : ('af, 'st) sock -> int + val getATMARK : ('af, active stream) sock -> bool +*) + end + + type sock_desc = int + fun sockDesc (s: ('af, 'st) sock) : sock_desc = #fd s + fun sameDesc (s1: sock_desc, s2: sock_desc) : bool = s1 = s2 + + fun select { rds : sock_desc list, + wrs : sock_desc list, + exs : sock_desc list, + timeout : Time.time option + } : { rds : sock_desc list, wrs : sock_desc list, exs : sock_desc list - } - val ioDesc : ('af, 'sock_type) sock -> OS.IO.iodesc + } = + let val t = case timeout of NONE => ~1.0 + | SOME t => Time.toReal t + val (rds, wrs, exs) = prim("sml_sock_select", (getCtx(),rds,wrs,exs,t)) + in {rds=List.rev rds, wrs=List.rev wrs, exs=List.rev exs} + end + + fun ioDesc (s: ('af, 'st) sock) : OS.IO.iodesc = + prim("id", #fd s) type out_flags = {don't_route : bool, oob : bool} type in_flags = {peek : bool, oob : bool} - val sendVec : ('af, active stream) sock - * Word8VectorSlice.slice -> int - val sendArr : ('af, active stream) sock - * Word8ArraySlice.slice -> int - val sendVec' : ('af, active stream) sock - * Word8VectorSlice.slice - * out_flags -> int - val sendArr' : ('af, active stream) sock - * Word8ArraySlice.slice - * out_flags -> int - val sendVecNB : ('af, active stream) sock - * Word8VectorSlice.slice -> int option - val sendVecNB' : ('af, active stream) sock - * Word8VectorSlice.slice - * out_flags -> int option - val sendArrNB : ('af, active stream) sock - * Word8ArraySlice.slice -> int option - val sendArrNB' : ('af, active stream) sock - * Word8ArraySlice.slice - * out_flags -> int option - - val recvVec : ('af, active stream) sock * int - -> Word8Vector.vector - val recvVec' : ('af, active stream) sock * int * in_flags - -> Word8Vector.vector - val recvArr : ('af, active stream) sock - * Word8ArraySlice.slice -> int - val recvArr' : ('af, active stream) sock - * Word8ArraySlice.slice - * in_flags -> int - val recvVecNB : ('af, active stream) sock * int - -> Word8Vector.vector option - val recvVecNB' : ('af, active stream) sock * int * in_flags - -> Word8Vector.vector option - val recvArrNB : ('af, active stream) sock - * Word8ArraySlice.slice -> int option - val recvArrNB' : ('af, active stream) sock - * Word8ArraySlice.slice - * in_flags -> int option - - val sendVecTo : ('af, dgram) sock - * 'af sock_addr - * Word8VectorSlice.slice -> unit - val sendArrTo : ('af, dgram) sock - * 'af sock_addr - * Word8ArraySlice.slice -> unit - val sendVecTo' : ('af, dgram) sock - * 'af sock_addr - * Word8VectorSlice.slice - * out_flags -> unit - val sendArrTo' : ('af, dgram) sock - * 'af sock_addr - * Word8ArraySlice.slice - * out_flags -> unit - val sendVecToNB : ('af, dgram) sock - * 'af sock_addr - * Word8VectorSlice.slice -> bool - val sendVecToNB' : ('af, dgram) sock - * 'af sock_addr - * Word8VectorSlice.slice - * out_flags -> bool - val sendArrToNB : ('af, dgram) sock - * 'af sock_addr - * Word8ArraySlice.slice -> bool - val sendArrToNB' : ('af, dgram) sock - * 'af sock_addr - * Word8ArraySlice.slice - * out_flags -> bool - - val recvVecFrom : ('af, dgram) sock * int - -> Word8Vector.vector - * 'sock_type sock_addr - val recvVecFrom' : ('af, dgram) sock * int * in_flags - -> Word8Vector.vector - * 'sock_type sock_addr - val recvArrFrom : ('af, dgram) sock - * Word8ArraySlice.slice - -> int * 'af sock_addr - val recvArrFrom' : ('af, dgram) sock - * Word8ArraySlice.slice - * in_flags -> int * 'af sock_addr - val recvVecFromNB : ('af, dgram) sock * int - -> (Word8Vector.vector - * 'sock_type sock_addr) option - val recvVecFromNB' : ('af, dgram) sock * int * in_flags - -> (Word8Vector.vector - * 'sock_type sock_addr) option - val recvArrFromNB : ('af, dgram) sock - * Word8ArraySlice.slice - -> (int * 'af sock_addr) option - val recvArrFromNB' : ('af, dgram) sock - * Word8ArraySlice.slice - * in_flags - -> (int * 'af sock_addr) option + fun sendVec ({fd,...} : ('af, active stream) sock, + slc : Word8VectorSlice.slice) : int = + let val (v,i,n) = Word8VectorSlice.base slc + val ret = prim("sml_sock_sendvec", (fd,v,i,n)) + in maybe_failure "sendVec" ret + ; ret + end + + (* Word8ArraySlices are represented the same as Word8VectorSlices *) + fun sendArr ({fd,...} : ('af, active stream) sock, + slc : Word8ArraySlice.slice) : int = + let val (v,i,n) = Word8ArraySlice.base slc + val ret = prim("sml_sock_sendvec", (fd,v,i,n)) + in maybe_failure "sendArr" ret + ; ret + end + + fun recvVec ({fd,...} : ('af, active stream) sock, + i : int) : Word8Vector.vector = + prim("sml_sock_recvvec",(getCtx(),fd,i)) + handle Overflow => failure "recvVec" + + fun close ({fd,...} : ('af, 'st) sock) : unit = + prim("@close", fd) + + datatype shutdown_mode = NO_RECVS + | NO_SENDS + | NO_RECVS_OR_SENDS + + fun shutdown (s: ('af, 'mode stream) sock, + sm: shutdown_mode) : unit = + let val ret = prim("@shutdown", + (#fd s, + case sm of + NO_RECVS => SHUT_RD + | NO_SENDS => SHUT_WR + | NO_RECVS_OR_SENDS => SHUT_RDWR)) + in maybe_failure "Socket.shutdown" ret + end + + fun sameAddr (a1: 'af sock_addr, a2: 'af sock_addr) : bool = + a1 = a2 + + fun familyOfAddr (sa: 'af sock_addr) : AF.addr_family = + case sa of + Inet_sa _ => AF_INET + | Unix_sa _ => AF_UNIX + + fun bind ({fd,af} : ('af, 'st) sock, a: 'af sock_addr) : unit = + case (af, a) of + (Inet_af, Inet_sa {addr,port}) => + let val ret : int = prim("sml_sock_bind_inet", (fd,addr,port)) + in maybe_failure "bind" ret + end + | (Unix_af, Unix_sa {name}) => + let val ret : int = prim("sml_sock_bind_unix", (fd,name)) + in maybe_failure "bind" ret + end + | _ => raise Fail "Socket.impossible" + + fun listen ({fd,...} : ('af, passive stream) sock, i: int) : unit = + let val ret : int = prim("sml_sock_listen", (fd,i)) + in maybe_failure "listen" ret + end + + fun accept ({fd,af} : ('af, passive stream) sock) + : ('af, active stream) sock * 'af sock_addr = + case af of + Inet_af => + let val (fd', addr, port) = prim("sml_sock_accept_inet",(getCtx(),fd)) + handle Overflow => failure "accept" + in ({fd=fd',af=af}, Inet_sa{addr=addr,port=port}) + end + | Unix_af => + let val (fd', name) = prim("sml_sock_accept_unix",(getCtx(),fd)) + handle Overflow => failure "accept" + in ({fd=fd',af=af}, Unix_sa{name=name}) + end + end -(* -type ('af,'sock_type) sock - The type of a socket. Sockets are polymorphic over both the address family - and the socket type. The type parameter 'af is instantiated with the - appropriate address family type (INetSock.inet or UnixSock.unix). The type - parameter 'sock_type is instantiated with the appropriate socket type - (dgram or stream). - -type 'af sock_addr - The type of a socket address. The type parameter 'af describes the address - family of the address (INetSock.inet or UnixSock.unix). - -type dgram - The witness type for datagram sockets. - -type 'mode stream - The witness type for stream sockets. The type parameter 'mode describes the - mode of the stream socket: active or passive. - -structure AF - The AF substructure defines an abstract type that represents the different - network-address families. - - val list : unit -> (string * addr_family) list - This returns a list of all the available address families. Every - element of the list is a pair (name,af) where name is the name of the - address family, and af is the actual address family value. - - The names of the address families are taken from the symbolic constants - used in the C Socket API and stripping the leading ``AF_.'' For - example, the Unix-domain address family is named "UNIX", the - Internet-domain address family is named "INET", and the Apple Talk - address family is named "APPLETALK". - - val toString : addr_family -> string - val fromString : string -> addr_family option - These convert between address family values and their names. For - example, the expression toString (INetSock.inetAF) returns the string - "INET". fromString returns NONE if no family value corresponds to the - given name. - - If a pair (name,af) is in the list returned by list, then it is the - case that name is equal to toString(af). - -structure SOCK - The SOCK substructure provides an abstract type and operations for the - different types of sockets. This type is used by the getTYPE function. - - eqtype sock_type - The type of socket types. - - val stream : sock_type - The stream socket type value. - - val dgram : sock_type - The datagram socket type value. - - val list : unit -> (string * sock_type) list - A list of the available socket types. Every element of the list is of - the form (name,sty) where name is the name of the socket type, and sty - is the actual socket type value. - - The list of possible socket type names includes "STREAM" for stream - sockets, "DGRAM" for datagram sockets, and "RAW" for raw sockets. These - names are formed by taking the symbolic constants from the C API and - removing the leading ``SOCK_.'' - - val toString : sock_type -> string - val fromString : string -> sock_type option - These convert between a socket type value and its name (e.g., - "STREAM"). fromString returns NONE if no socket type value corresponds - to the name. - - If a pair (name,sty) is in the list returned by list, then it is the - case that name is equal to toString(sty). - -structure Ctl - The Ctl substructure provides support for manipulating the options - associated with a socket. These functions raise the SysErr exception when - the argument socket has been closed. - - val getDEBUG : ('af, 'sock_type) sock -> bool - val setDEBUG : ('af, 'sock_type) sock * bool -> unit - These functions query and set the SO_DEBUG flag for the socket. This - flag enables or disables low-level debugging within the kernel. - Enabled, it allows the kernel to maintain a history of the recent - packets that have been received or sent. - - val getREUSEADDR : ('af, 'sock_type) sock -> bool - val setREUSEADDR : ('af, 'sock_type) sock * bool -> unit - These query and set the SO_REUSEADDR flag for the socket. When true, - this flag instructs the system to allow reuse of local socket addresses - in bind calls. - - val getKEEPALIVE : ('af, 'sock_type) sock -> bool - val setKEEPALIVE : ('af, 'sock_type) sock * bool -> unit - These query and set the SO_KEEPALIVE flag for the socket. When true, - the system will generate periodic transmissions on a connected socket, - when no other data is being exchanged. - - val getDONTROUTE : ('af, 'sock_type) sock -> bool - val setDONTROUTE : ('af, 'sock_type) sock * bool -> unit - These query and set the SO_DONTROUTE flag for the socket. When this - flag is true, outgoing messages bypass the normal routing mechanisms of - the underlying protocol, and are instead directed to the appropriate - network interface as specified by the network portion of the - destination address. Note that this option can be specified on a per - message basis by using one of the sendVec', sendArr', sendVecTo', or - sendArrTo' functions. - - val getLINGER : ('af, 'sock_type) sock -> Time.time option - val setLINGER : ('af, 'sock_type) sock * Time.time option - -> unit - These functions query and set the SO_LINGER flag for the socket sock. - This flag controls the action taken when unsent messages are queued on - socket and a close is performed. If the flag is set to NONE, then the - system will close the socket as quickly as possible, discarding data if - necessary. If the flag is set to SOME(t) and the socket promises - reliable delivery, then the system will block the close operation until - the data is delivered or the timeout t expires. If t is negative or too - large, then the Time is raised. - - val getBROADCAST : ('af, 'sock_type) sock -> bool - val setBROADCAST : ('af, 'sock_type) sock * bool -> unit - These query and set the SO_BROADCAST flag for the socket sock, which - enables or disables the ability of the process to send broadcast - messages over the socket. - - val getOOBINLINE : ('af, 'sock_type) sock -> bool - val setOOBINLINE : ('af, 'sock_type) sock * bool -> unit - These query and set the SO_OOBINLINE flag for the socket. When set, - this indicates that out-of-band data should be placed in the normal - input queue of the socket. Note that this option can be specified on a - per message basis by using one of the sendVec', sendArr', sendVecTo', - or sendArrTo' functions. - - val getSNDBUF : ('af, 'sock_type) sock -> int - val setSNDBUF : ('af, 'sock_type) sock * int -> unit - These query and set the size of the send queue buffer for the socket. - - val getRCVBUF : ('af, 'sock_type) sock -> int - val setRCVBUF : ('af, 'sock_type) sock * int -> unit - These query and set the size of receive queue buffer for the socket. - - val getTYPE : ('af, 'sock_type) sock -> SOCK.sock_type - This returns the socket type of the socket. - - val getERROR : ('af, 'sock_type) sock -> bool - This indicates whether or not an error has occurred. - - val getPeerName : ('af, 'sock_type) sock -> 'af sock_addr - This returns the socket address to which the socket is connected. - - val getSockName : ('af, 'sock_type) sock -> 'af sock_addr - This returns the socket address to which the socket is bound. - - val getNREAD : ('af, 'sock_type) sock -> int - This returns the number of bytes available for reading on the socket. - - val getATMARK : ('af, active stream) sock -> bool - This indicates whether or not the read pointer on the socket is - currently at the out-of-band mark. - -val sameAddr : 'af sock_addr * 'af sock_addr -> bool - This tests whether two socket addresses are the same address. - -familyOfAddr addr - returns the address family of the socket address addr. - -bind (sock, sa) - binds the address sa to the passive socket sock. This function raises - SysErr when the address sa is already in use, when sock is already bound to - an address, or when sock has been closed. - -listen (sock, n) - creates a queue (of size n) for pending questions associated to the socket - sock. The size of queue is limited by the underlying system, but requesting - a queue size larger than the limit does not cause an error (a typical limit - is 128, but older systems use a limit of 5). - - This function raises the SysErr exception if sock has been closed. - -accept sock - extracts the first connection request from the queue of pending connections - for the socket sock. The socket must have been bound to an address via bind - and enabled for listening via listen. If a connection is present, accept - returns a pair (s,sa) consisting of a new active socket s with the same - properties as sock and the address sa of the connecting entity. If no - pending connections are present on the queue then accept blocks until a - connection is requested. One can test for pending connection requests by - using the select function to test the socket for reading. - - This function raises the SysErr exception if sock has not been properly - bound and enabled, or it sock has been closed. - -val acceptNB : ('af, passive stream) sock - -> (('af, active stream) sock - * 'af sock_addr) option - This function is the nonblocking form of the accept operation. If the - operation can complete without blocking (i.e., there is a pending - connection), then this function returns SOME(s,sa), where s is a new active - socket with the same properties as sock and sa is the the address of the - connecting entity. If there are no pending connections, then this function - returns NONE. - - This function raises the SysErr exception if sock has not been properly - bound and enabled, or it sock has been closed. - -connect (sock, sa) - attempts to connect the socket sock to the address sa. If sock is a - datagram socket, the address specifies the peer with which the socket is to - be associated; sa is the address to which datagrams are to be sent, and the - only address from which datagrams are to be received. If sock is a stream - socket, the address specifies another socket to which to connect. - - This function raises the SysErr exception when the address specified by sa - is unreachable, when the connection is refused or times out, when sock is - already connected, or when sock has been closed. - -val connectNB : ('af, 'sock_type) sock * 'af sock_addr - -> bool - This function is the nonblocking form of connect. If the connection can be - established without blocking the caller (which is typically true for - datagram sockets, but not stream sockets), then true is returned. - Otherwise, false is returned and the connection attempt is started; one can - test for the completion of the connection by testing the socket for writing - using the select function. This function will raise SysErr if it is called - on a socket for which a previous connection attempt has not yet been - completed. - -close sock - closes the connection to the socket sock. This function raises the SysErr - exception if the socket has already been closed. - -shutdown (sock, mode) - shuts down all or part of a full-duplex connection on socket sock. If mode - is NO_RECVS, further receives will be disallowed. If mode is NO_SENDS, - further sends will be disallowed. If mode is NO_RECVS_OR_SENDS, further - sends and receives will be disallowed. This function raises the SysErr - exception if the socket is not connected or has been closed. - -type sock_desc - This type is an abstract name for a socket, which is used to support - polling on collections of sockets. - -sockDesc sock - returns a socket descriptor that names the socket sock. - -sameDesc (sd1, sd2) - returns true if the two socket descriptors sd1 and sd2 describe the same - underlying socket. Thus, the expression sameDesc(sockDesc sock, sockDesc - sock) will always return true for any socket sock. - -select {rds, wrs, exs, timeout} - examines the sockets in rds, wrs, and exs to see if they are ready for - reading, writing, or have an exceptional condition pending, respectively. - The calling program is blocked until either one or more of the named - sockets is ``ready '' or the specified timeout expires (where a timeout of - NONE never expires). The result of select is a record of three lists of - socket descriptors containing the ready sockets from the corresponding - argument lists. The order in which socket descriptors appear in the - argument lists is preserved in the result lists. A timeout is signified by - a result of three empty lists. - - This function raises SysErr if any of the argument sockets have been closed - or if the timeout value is negative. - - Note that one can test if a call to accept will block by using select to - see if the socket is ready to read. Similarly, one can use select to test - if a call to connect will block by seeing if the socket is ready to write. - -ioDesc sock - returns the I/O descriptor corresponding to socket sock. This descriptor - can be used to poll the socket via pollDesc and poll in the OS.IO - structure. Using the polling mechanism from OS.IO has the advantage that - different kinds of I/O objects can be mixed, but not all systems support - polling on sockets this way. If an application is only polling sockets, - then it is more portable to use the select function defined above. - -type out_flags = {don't_route : bool, oob : bool} - Flags used in the general form of socket output operations. - -type in_flags = {peek : bool, oob : bool} - Flags used in the general form of socket input operations. - -sendVec (sock, slice) -sendArr (sock, slice) - These functions send the bytes in the slice slice on the active stream - socket sock. They return the number of bytes actually sent. - - These functions raise SysErr if sock has been closed. - -sendVec' (sock, slice, {don't_route, oob}) -sendArr' (sock, slice, {don't_route, oob}) - These functions send the bytes in the slice slice on the active stream - socket sock. They return the number of bytes actually sent. If the - don't_route flag is true, the data is sent bypassing the normal routing - mechanism of the protocol. If oob is true, the data is sent out-of-band, - that is, before any other data which may have been buffered. - - These functions raise SysErr if sock has been closed. - -val sendVecNB : ('af, active stream) sock - * Word8VectorSlice.slice -> int option -val sendVecNB' : ('af, active stream) sock - * Word8VectorSlice.slice - * out_flags -> int option -val sendArrNB : ('af, active stream) sock - * Word8ArraySlice.slice -> int option -val sendArrNB' : ('af, active stream) sock - * Word8ArraySlice.slice - * out_flags -> int option - These functions are the nonblocking versions of sendVec, sendVec', sendArr, - and sendArr' (resp.). They have the same semantics as their blocking forms, - with the exception that when the operation can complete without blocking, - then the result is wrapped in SOME and if the operation would have to wait - to send the data, then NONE is returned instead. - -recvVec (sock, n) -recvVec'(sock, n, {peek,oob}) - These functions receive up to n bytes from the active stream socket sock. - The size of the resulting vector is the number of bytes that were - successfully received, which may be less than n. If the connection has been - closed at the other end (or if n is 0), then the empty vector will be - returned. - - In the second version, if peek is true, the data is received but not - discarded from the connection. If oob is true, the data is received - out-of-band, that is, before any other incoming data that may have been - buffered. - - These functions raise SysErr if the socket sock has been closed and they - raise Size if n < 0 or n > Word8Vector.maxLen. - -recvArr (sock, slice) -recvArr' (sock, slice, {peek, oob}) - These functions read data from the socket sock into the array slice slice. - They return the number of bytes actually received. If the connection has - been closed at the other end or the slice is empty, then 0 is returned. - - For recvArr', if peek is true, the data is received but not discarded from - the connection. If oob is true, the data is received out-of-band, that is, - before any other incoming data that may have been buffered. - - These functions raise SysErr if sock has been closed. - -val recvVecNB : ('af, active stream) sock * int - -> Word8Vector.vector option -val recvVecNB' : ('af, active stream) sock * int * in_flags - -> Word8Vector.vector option -val recvArrNB : ('af, active stream) sock - * Word8ArraySlice.slice -> int option -val recvArrNB' : ('af, active stream) sock - * Word8ArraySlice.slice - * in_flags -> int option - These functions are the nonblocking versions of recvVec, recvVec', recvArr, - and recvArr' (resp.). They have the same semantics as their blocking forms, - with the exception that when the operation can complete without blocking, - then the result is wrapped in SOME and if the operation would have to wait - for input, then NONE is returned instead. - -sendVecTo (sock, sa, slice) -sendArrTo (sock, sa, slice) - These functions send the message specified by the slice slice on the - datagram socket sock to the address sa. - - These functions raise SysErr if sock has been closed or if the socket has - been connected to a different address than sa. - -sendVecTo' (sock, sa, slice, {don't_route, oob}) -sendArrTo' (sock, sa, slice, {don't_route, oob}) - These functions send the message specified by the slice slice on the - datagram socket sock to the address - - If the don't_route flag is true, the data is sent bypassing the normal - routing mechanism of the protocol. If oob is true, the data is sent - out-of-band, that is, before any other data which may have been buffered. - - These functions raise SysErr if sock has been closed or if the socket has - been connected to a different address than sa. - -val sendVecToNB : ('af, dgram) sock - * 'af sock_addr - * Word8VectorSlice.slice -> bool -val sendVecToNB' : ('af, dgram) sock - * 'af sock_addr - * Word8VectorSlice.slice - * out_flags -> bool -val sendArrToNB : ('af, dgram) sock - * 'af sock_addr - * Word8ArraySlice.slice -> bool -val sendArrToNB' : ('af, dgram) sock - * 'af sock_addr - * Word8ArraySlice.slice - * out_flags -> bool - These functions are the nonblocking versions of sendVecTo, sendVecTo', - sendArrTo, and sendArrTo' (resp.). They have the same semantics as their - blocking forms, with the exception that if the operation can complete - without blocking, then the operation is performed and true is returned. - Otherwise, false is returned and the message is not sent. - -recvVecFrom (sock, n) -recvVecFrom' (sock, n, {peek, oob}) - These functions receive up to n bytes on the datagram socket sock, and - return a pair (vec,sa), where the vector vec is the received message, and - sa is the socket address from the which the data originated. If the message - is larger than n, then data may be lost. - - In the second form, if peek is true, the data is received but not discarded - from the connection. If oob is true, the data is received out-of-band, that - is, before any other incoming data that may have been buffered. - - These functions raise SysErr if sock has been closed; they raise Size if n - < 0 or n > Word8Vector.maxLen. - -recvArrFrom (sock, slice) -recvArrFrom' (sock, slice) - These functions read a message from the datagram socket sock into the array - slice slice. If the message is larger than the size of the slice, then - data may be lost. They return the number of bytes actually received. If the - connection has been closed at the other end or the slice is empty, then 0 - is returned. - - For recvArrFrom', if peek is true, the data is received but not discarded - from the connection. If oob is true, the data is received out-of-band, that - is, before any other incoming data that may have been buffered. - - These functions raise SysErr if sock has been closed. - -val recvVecFromNB : ('af, dgram) sock * int - -> (Word8Vector.vector - * 'sock_type sock_addr) option -val recvVecFromNB' : ('af, dgram) sock * int * in_flags - -> (Word8Vector.vector - * 'sock_type sock_addr) option -val recvArrFromNB : ('af, dgram) sock - * Word8ArraySlice.slice - -> (int * 'af sock_addr) option -val recvArrFromNB' : ('af, dgram) sock - * Word8ArraySlice.slice - * in_flags - -> (int * 'af sock_addr) option - These functions are the nonblocking versions of recvVecFrom, recvVecFrom', - recvArrFrom, and recvArrFrom' (resp.). They have the same semantics as - their blocking forms, with the exception that when the operation can - complete without blocking, then the result is wrapped in SOME and if the - operation would have to wait for input, then NONE is returned instead. + structure INetSock = struct + datatype inet = INET + type 'st sock = (inet, 'st) Socket.sock + type 'm stream_sock = 'm Socket.stream sock + type sock_addr = inet Socket.sock_addr + val inetAF = Socket.AF_INET + fun any (p:int) : sock_addr = + Socket.Inet_sa {addr=Socket.INADDR_ANY,port=p} + structure TCP = struct + fun socket () : 'm stream_sock = + let val res = prim("sml_sock_socket", (Socket.AF_INET,Socket.SOCK_STREAM)) + in maybe_failure "socket" res + ; {fd=res,af=Socket.Inet_af} + end + end + end -*) + structure All :> + sig + structure Socket : SOCKET + structure INetSock : + sig + type inet + type 'st sock = (inet,'st) Socket.sock + type 'm stream_sock = 'm Socket.stream sock + type sock_addr = inet Socket.sock_addr + val inetAF : Socket.AF.addr_family + val any : int -> sock_addr + structure TCP : + sig + val socket : unit -> 'm stream_sock + end + end + end = + struct + structure Socket = Socket + structure INetSock = INetSock + end + +in + structure Socket = All.Socket + structure INetSock = All.INetSock +end diff --git a/basis/TextIO.sml b/basis/TextIO.sml index 4992b2951..24aefbb78 100644 --- a/basis/TextIO.sml +++ b/basis/TextIO.sml @@ -1,4 +1,4 @@ - + structure TextIO : TEXT_IO = struct @@ -9,6 +9,8 @@ structure TextIO : TEXT_IO = type instream = {ic: int, name: string} type outstream = {oc: int, name: string} + fun getCtx () : foreignptr = prim("__get_ctx",()) + (* Primitives *) fun sub_ (s:vector,i:int) : elem = prim ("__bytetable_sub", (s,i)) fun size (s:vector): int = prim ("__bytetable_size", s) @@ -22,30 +24,30 @@ structure TextIO : TEXT_IO = fun closeIn ({ic,...} : instream) : unit = prim ("closeStream", ic) - fun inputN_ (ic:int, n:int) : string = prim ("inputStream", (ic, n)) - fun input1_ (ic:int) : int = prim ("input1Stream", ic) + fun inputN_ (ic:int, n:int) : string = prim ("inputStream", (ic, n)) + fun input1_ (ic:int) : int = prim ("input1Stream", ic) - fun lookahead_ (ic: int): int = prim ("lookaheadStream", ic) + fun lookahead_ (ic: int): int = prim ("lookaheadStream", ic) exception CannotOpen - fun raiseIo fcn nam exn = - raise IO.Io {function = fcn^"", name = nam^"", cause = exn} - fun openIn (f: string) : instream = - {ic=prim("openInStream",(f, CannotOpen)), + fun raiseIo fcn nam exn = + raise IO.Io {function = fcn^"", name = nam^"", cause = exn} + fun openIn (f: string) : instream = + {ic=prim("openInStream",(getCtx(), f, CannotOpen)), name=f} handle exn => raiseIo "openIn" f exn - fun openOut(f: string): outstream = - {oc=prim("openOutStream",(f, CannotOpen)), + fun openOut (f: string): outstream = + {oc=prim("openOutStream",(getCtx(), f, CannotOpen)), name=f} handle exn => raiseIo "openOut" f exn - fun openAppend(f: string): outstream = - {oc=prim("openAppendStream",(f, CannotOpen)), + fun openAppend (f: string): outstream = + {oc=prim("openAppendStream",(getCtx(), f, CannotOpen)), name=f} handle exn => raiseIo "openAppend" f exn - fun closeOut({oc, name}: outstream) : unit = prim ("closeStream", oc) + fun closeOut ({oc, name}: outstream) : unit = prim ("closeStream", oc) - fun flushOut({oc,name}: outstream) : unit = prim ("flushStream", oc) + fun flushOut ({oc,name}: outstream) : unit = prim ("flushStream", oc) - fun output0(os as {oc,name},str,function):unit = - (prim ("outputStream", (oc, str, IO.ClosedStream)); + fun output0 (os as {oc,name},str,function):unit = + (prim ("outputStream", (getCtx(), oc, str, IO.ClosedStream)); if os = stdErr then flushOut os else ()) handle exn as IO.ClosedStream => raiseIo function name exn @@ -62,10 +64,10 @@ structure TextIO : TEXT_IO = fun inputN ({ic, name} : instream, n) = if n < 0 orelse n > String.maxSize then raise Size - else + else if n <= 64 then inputN_ (ic, n) else - let + let fun loop(n,acc) = if n <= 64 then concat(rev (inputN_(ic, n) :: acc)) else @@ -104,14 +106,14 @@ structure TextIO : TEXT_IO = of SOME c => (update_ (buf, charno mod 512, c); read := !read + 1; SOME(c, charno+1)) - | NONE => NONE - in case scan getc 0 + | NONE => NONE + in case scan getc 0 of NONE => NONE | SOME(res, _) => SOME res end fun scanStream scan is = scanStream0(scan, is) -(* +(* fun inputNoBlock (is : instream) : vector option = raise Fail "not implemented" *) @@ -124,18 +126,18 @@ structure TextIO : TEXT_IO = fun endOfStream is = (lookahead is = NONE) - fun inputLine(is) = - let fun loop(acc) = + fun inputLine is = + let fun loop(acc) = case input1 is of SOME (c as #"\n") => SOME(implode(rev(c :: acc))) | SOME c => loop(c::acc) - | NONE => case acc + | NONE => case acc of [] => NONE | _ => SOME(implode(rev(#"\n" :: acc))) in loop([]) end - fun output(os, str) = output0(os, str, "output") + fun output (os, str) = output0(os, str, "output") fun outputSubstr (os, sus) = let val str = Substring.string sus diff --git a/basis/io/.cvsignore b/basis/io/.cvsignore deleted file mode 100644 index 49475740a..000000000 --- a/basis/io/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -MLB *.log *.vcg diff --git a/basis/socket.mlb b/basis/socket.mlb new file mode 100644 index 000000000..0a393a559 --- /dev/null +++ b/basis/socket.mlb @@ -0,0 +1,11 @@ + +local + $(SML_LIB)/basis/basis.mlb +in + NET_HOST_DB.sig + NetHostDb.sml + SOCKET.sig + Socket.sml + INET_SOCK.sig + +end diff --git a/configure.ac b/configure.ac index 72d344b1e..3979a98a8 100644 --- a/configure.ac +++ b/configure.ac @@ -1,23 +1,18 @@ AC_INIT(MLKit, [v4.5.10]) AC_CONFIG_HEADERS([src/config.h]) AC_REVISION($Revision$) -AC_CONFIG_FILES([src/SMLserver/apache/Makefile - src/Runtime/Makefile +AC_CONFIG_FILES([src/Runtime/Makefile src/Makefile Makefile doc/README_BIN - doc/README_SMLSERVER_BIN man/man1/mlkit-mllex.1 man/man1/mlkit-mlyacc.1 man/man1/rp2ps.1 man/man1/kittester.1 - smlserver_demo/Makefile src/Tools/MlbMake/Makefile src/Tools/Rp2ps/Makefile - src/Tools/GenOpcodes/Makefile src/Tools/ml-lex/Makefile src/Tools/ml-yacc/Makefile - src/Tools/UlWrapUp/Makefile src/Tools/Tester/Makefile src/Version.sml]) @@ -28,26 +23,18 @@ AC_PROG_MAKE_SET # Checks for header files. AC_HEADER_DIRENT -AC_HEADER_STDC +m4_warn([obsolete], +[The preprocessor macro `STDC_HEADERS' is obsolete. + Except in unusual embedded environments, you can safely include all + ISO C90 headers unconditionally.])dnl +# Autoupdate added the next two lines to ensure that your configure +# script's behavior did not change. They are probably safe to remove. +AC_CHECK_INCLUDES_DEFAULT +AC_PROG_EGREP + AC_HEADER_SYS_WAIT AC_CHECK_HEADERS([fcntl.h fenv.h float.h limits.h malloc.h netdb.h stddef.h stdlib.h string.h strings.h sys/ioctl.h sys/param.h sys/time.h sys/timeb.h termios.h unistd.h utime.h]) - -AC_ARG_ENABLE(SMLserver,AS_HELP_STRING(--enable-SMLserver,compile with SMLserver), - AC_DEFINE(SMLSERVER,1,[Smlserver requested]), - []) - -AC_ARG_ENABLE(KAM,AS_HELP_STRING(--enable-KAM,compile with KAM backend)) - -AC_ARG_ENABLE(threaded, - AS_HELP_STRING(--disable-threaded,Don't use threaded interpreter),[], - AC_DEFINE(THREADED,1,[Kam backend should be threaded])) - -AC_SUBST(odbc,no) -AC_ARG_ENABLE(odbc, - AS_HELP_STRING(--enable-odbc,Compile ODBC functionality), - AC_SUBST(odbc,${enable_odbc}),) - AC_ARG_WITH( compiler, AS_HELP_STRING(--with-compiler[=FILE],[SML compiler to build tools and the initial mlkit compiler]), @@ -55,12 +42,6 @@ AC_ARG_WITH( , ) -if test x"${enable_SMLserver}" != x && test "${enable_SMLserver}" = yes; then - APACHE_DIR - ORACLE_DIR - AC_SUBST(oracle_dir) -fi; - AC_MSG_CHECKING(configure date) DATE=`date -u '+%Y-%m-%dT-%H:%M:%S'` AC_SUBST(DATE) diff --git a/doc/.cvsignore b/doc/.cvsignore deleted file mode 100644 index 064b0e90d..000000000 --- a/doc/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -README_BIN \ No newline at end of file diff --git a/doc/README_SMLSERVER_BIN.in b/doc/README_SMLSERVER_BIN.in deleted file mode 100644 index 6e5e4f7ad..000000000 --- a/doc/README_SMLSERVER_BIN.in +++ /dev/null @@ -1,89 +0,0 @@ - - The SMLserver binary distribution - smlserver-@PACKAGE_VERSION@-i386 - -This readme file describes the structure of the SMLserver binary -distribution as well as necessary steps for proper personal and system -wide installation. - -An overview of the directory structure of the distribution -is given in Appendix A. - -1. System-wide Installation ---------------------------- - -Provided you have downloaded a binary distribution to the /tmp -directory and renamed the distribution to smlserver-@PACKAGE_VERSION@-i386.tgz, -execute the following commands in a bash-shell - as root: - - % cd /tmp - % tar xzvf smlserver-@PACKAGE_VERSION@-i386.tgz - % cd smlserver-@PACKAGE_VERSION@-i386 - % cp -pa bin/* /usr/bin/ - % cp -pa lib/smlserver /usr/lib/smlserver - % cp -pa share/man/man1/* /usr/share/man/man1/ - % cp -pa share/doc/smlserver /usr/share/doc/smlserver - % mkdir /etc/smlserver - % echo "SML_LIB /usr/lib/smlserver" > /etc/smlserver/mlb-path-map - -All locations, except the system wide path-map /etc/smlserver/mlb-path-map -can be changed at will. - -Any user on the system should now be able to run the commands -smlserverc, smlserver-wrap, and mspcomp. - -2. Personal Installation ------------------------- -Provided you have downloaded a binary distribution to your home -directory $HOME, and renamed the distribution to -smlserver-@PACKAGE_VERSION@-i386.tgz, execute the following commands: - - $ cd $HOME - $ tar xzvf smlserver-@PACKAGE_VERSION@-i386.tgz - $ ln -s smlserver-@PACKAGE_VERSION@-i386 smlserver - $ mkdir .smlserver - $ echo "SML_LIB $HOME/smlserver/lib/mlkit" > .smlserver/mlb-path-map - -You can now either run the smlserverc command directly by specifying the -complete path or you can modify your personal PATH environment -variable to include $HOME/smlserver/bin. - -Now, that SMLserver is installed, proceed with Chapter 2 of the book -"SMLserver - A Functional Approach to Web Publishing", available from -the SMLserver home page www.smlserver.org. - -3. More Information -------------------- -See the SMLserver home page www.smlserver.org for more -information. SMLserver is based on the MLKit Standard ML compiler and -SMLserver is distributed under the same license as the MLKit. License -information is located in the file -share/doc/smlserver/license/MLKit-LICENSE. - -4. Comments and Bug Reports ---------------------------- -Please see the SMLserver home page for a list of known bugs and -limitations. Send bug reports to smlserver@itu.dk. - -Appendix A: Directory Structure of the Distribution ---------------------------------------------------- - smlserver-@PACKAGE_VERSION@-i386.tgz: - smlserver-@PACKAGE_VERSION@-i386/ - bin/smlserverc - /smlserver-wrap - /mspcomp - lib/smlserver/lib/mod_sml.so - /... - /basis/basis.mlb - /kitlib.mlb - /web/lib.mlb - ... - /web_demo_lib/ - /web_sys/ - /www/ - share/man/man1/smlserverc.1 - share/doc/smlserver/README_SMLSERVER_BIN - /README_SMLSERVER - /licence/ - - diff --git a/doc/license/MLKit-LICENSE b/doc/license/MLKit-LICENSE index 06d49db8b..63525f4f3 100644 --- a/doc/license/MLKit-LICENSE +++ b/doc/license/MLKit-LICENSE @@ -4,7 +4,7 @@ programming language. MLKit COPYRIGHT NOTICE, LICENSE AND DISCLAIMER. Copyright (c) 1998-2012 by Copenhagen University, Edinburgh - University, the IT University of Copenhagen, and 2008-2012 Martin Elsman + University, the IT University of Copenhagen, and 2008-2021 Martin Elsman This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as @@ -19,8 +19,9 @@ General Public License for more details; see the file GPL-LICENSE. For the source distributions, the files in the directories src/Runtime/ and basis/ and js/ are distributed under the MIT license; see the files src/Runtime/MIT-LICENSE and basis/MIT-LICENSE and -js/MIT-LICENSE. All other files are distributed under the GPL license; -see the file GPL-LICENSE. +js/MIT-LICENSE; some exceptions appear in the table below, as some +source code is copied from packages with BSD-style licenses. All other +files are distributed under the GPL license; see the file GPL-LICENSE. For the binary distributions, the files in the directory lib/ are distributed under the MIT license; see the file MIT-LICENSE. All other @@ -31,27 +32,31 @@ Below is an overview of uses of other packages and their licenses: Package License Use --------------------------------------------------------------------- SML/NJ SMLNJ-LICENSE (BSD-style) Ported some libraries for - basis.mlb: IntInf, + basis.mlb: IntInf, Pack32Big, Pack32Little (in basis/). src/Tools/ml-lex, src/Tools/ml-yacc -SML/NJ Lib SMLNJ-LIB-LICENSE (BSD-style) Ported some libraries for +SML/NJ Lib SMLNJ-LIB-LICENSE (BSD-style) Ported some libraries for kitlib.mlb (in basis/); see - individual files for + individual files for details. - copyright.att (BSD-style) 1993 versions of + copyright.att (BSD-style) 1993 versions of Polyhash.sml, POLYHASH.sml (in basis/ and src/Pickle/) MLton MLton-LICENSE (BSD-style) Ported some libraries for - basis.mlb: PrimIO, StreamIO, + basis.mlb: PrimIO, StreamIO, TextIO, ImperativeIO, BinIO (in basis/). -install-sh X-LICENSE (MIT-style) install-sh +MLton MLton-HPND-LICENSE (HPND-style) Made use of some functionality for + basis.mlb: NetHostDb scan function, e.g. + (in basis/). + +install-sh X-LICENSE (MIT-style) install-sh CodeMirror CODEMIRROR-LICENSE (BSD-style) Embedded editor in browser- hosted Standard ML compiler diff --git a/doc/license/MLton-HPND-LICENSE b/doc/license/MLton-HPND-LICENSE new file mode 100644 index 000000000..9ea919ef1 --- /dev/null +++ b/doc/license/MLton-HPND-LICENSE @@ -0,0 +1,29 @@ +This is the license for MLton, a whole-program optimizing compiler for +the Standard ML programming language. The license is an instance of +the Historical Permission Notice and Disclaimer (HPND) license, which +is an open source (https://opensource.org/licenses/HPND) and +free software (https://www.gnu.org/licenses/license-list.en.html#HPND) +license. Send comments and questions to MLton@mlton.org. + +MLton COPYRIGHT NOTICE, LICENSE AND DISCLAIMER. + +Copyright (C) 1999-2021 Henry Cejtin, Matthew Fluet, Suresh + Jagannathan, and Stephen Weeks. +Copyright (C) 1997-2000 by the NEC Research Institute + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both the copyright notice and this permission notice and warranty +disclaimer appear in supporting documentation, and that the name of +the above copyright holders, or their entities, not be used in +advertising or publicity pertaining to distribution of the software +without specific, written prior permission. + +The above copyright holders disclaim all warranties with regard to +this software, including all implied warranties of merchantability and +fitness. In no event shall the above copyright holders be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether in an +action of contract, negligence or other tortious action, arising out +of or in connection with the use or performance of this software. \ No newline at end of file diff --git a/doc/manual/.cvsignore b/doc/manual/.cvsignore deleted file mode 100644 index 46b3848fa..000000000 --- a/doc/manual/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -root.log root.idx root.aux root.dvi root.toc auto root.info root.ind root.ilg root.bbl root.out - root.blg -.xvpics diff --git a/kitdemo/.cvsignore b/kitdemo/.cvsignore deleted file mode 100644 index af51ff5c5..000000000 --- a/kitdemo/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -PM MLB *.log run profile.rp region.ps mylibtest-pt mylibtest mylibtest-t mylibtest-p *.auto.mlb diff --git a/kitdemo/utils/.cvsignore b/kitdemo/utils/.cvsignore deleted file mode 100644 index 280ce58ad..000000000 --- a/kitdemo/utils/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -PM diff --git a/kitlib/.cvsignore b/kitlib/.cvsignore deleted file mode 100644 index 1ac43e4d1..000000000 --- a/kitlib/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -MLB *.log run diff --git a/ml-yacc-lib/.cvsignore b/ml-yacc-lib/.cvsignore deleted file mode 100644 index 2a20ec162..000000000 --- a/ml-yacc-lib/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -PM run \ No newline at end of file diff --git a/smlserver/xt/Makefile b/smlserver/xt/Makefile deleted file mode 100644 index f649318c3..000000000 --- a/smlserver/xt/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -CLEAN=rm -rf *~ *.gen.sml PM - -clean: - $(CLEAN) - cd demolib; $(CLEAN) - cd www; $(CLEAN) - cd libxt; $(CLEAN) \ No newline at end of file diff --git a/smlserver/xt/demolib/data0.sml b/smlserver/xt/demolib/data0.sml deleted file mode 100644 index ff50d39a0..000000000 --- a/smlserver/xt/demolib/data0.sml +++ /dev/null @@ -1,24 +0,0 @@ -structure Data0 = - struct - datatype Data = - Int of int - | Ref of Data ref - | Real of real - | Plus of Data * Data - - fun eval t = - let fun eval0 (Int i, acc) = acc + real i - | eval0 (Real r, acc) = acc + r - | eval0 (Plus (t1,t2), acc) = eval0(t1,eval0(t2,acc)) - | eval0 (Ref (ref t), acc) = eval0(t,acc) - in Real.toString(eval0(t,0.0)) - end - - val d1 = Plus(Real 2.3,Int 4) - val v1 = eval d1 - val r = ref d1 - val d2 = Plus(Ref r, Plus(d1,Int 4)) - val _ = r := Int 1000 - val v2 = eval d2 - fun f() : 'a = raise Interrupt - end \ No newline at end of file diff --git a/smlserver/xt/demolib/page.sml b/smlserver/xt/demolib/page.sml deleted file mode 100644 index 294ec1011..000000000 --- a/smlserver/xt/demolib/page.sml +++ /dev/null @@ -1,46 +0,0 @@ - -local open Scripts -in -structure Page : - sig - type blockElt = (nil,nil,aclosed,formclosed, - preclosed,(block,NOT)flow) elt - - val pageWithCookies : SMLserver.Cookie.cookiedata list -> - string -> blockElt -> Http.response - val page : string -> blockElt -> Http.response - - val get : string -> 't SMLserver.Form.var -> 't - end -= - struct - type blockElt = (nil,nil,aclosed,formclosed, - preclosed,(block,NOT)flow) elt - local - open Scripts infix & - val smlserver_link = Unsafe.ahref {src="http://www.smlserver.org"} ($"SMLserver") - in - fun pageWithCookies cookies t bdy = - Http.returnHtml' cookies - (html(head (t,nil), - body (h1 ($t) - & bdy - & hr() - & address ($"Served by " & smlserver_link)))) - fun page t bdy = pageWithCookies nil t bdy - - fun error t bdy = Http.respondExit (page t bdy) - - fun get (s:string) (fv:'t SMLserver.Form.var) : 't = - case SMLserver.Form.get fv of - SMLserver.Form.Ok v => v - | SMLserver.Form.Wrong => - error "Form Field error" - (p($"Error in the field '" & b ($s) & - $"'. Go back using your browser's back button and enter a correct value for this field.")) - | SMLserver.Form.Missing => - error "Missing form variable error" - (p($"Error: Missing form variable - someone is tampering with the system!")) - end - end -end \ No newline at end of file diff --git a/smlserver/xt/libxt/.cvsignore b/smlserver/xt/libxt/.cvsignore deleted file mode 100644 index 50c4817b6..000000000 --- a/smlserver/xt/libxt/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -PM *.gen.sml \ No newline at end of file diff --git a/smlserver/xt/libxt/HTTP.sig b/smlserver/xt/libxt/HTTP.sig deleted file mode 100644 index 12d65f4a8..000000000 --- a/smlserver/xt/libxt/HTTP.sig +++ /dev/null @@ -1,25 +0,0 @@ -signature HTTP = - sig - type response - type html - val returnHtml : html -> response - val returnHtml' : SMLserver.Cookie.cookiedata list - -> html -> response - val respondExit : response -> 'a - end - -(* - [respondExit r] sends a response to the client and exits; this - function never returns. -*) - -signature HTTP_EXTRA = - sig - include HTTP - structure Unsafe : - sig - val toString : response -> string - val redirect : string -> SMLserver.Cookie.cookiedata list -> response - end - end - diff --git a/smlserver/xt/libxt/Http.sml b/smlserver/xt/libxt/Http.sml deleted file mode 100644 index 514d203c2..000000000 --- a/smlserver/xt/libxt/Http.sml +++ /dev/null @@ -1,36 +0,0 @@ -structure HttpHidden__ : HTTP_EXTRA = - struct - structure XHtml = XHtmlHidden__ - type html = XHtml.html - type response = string - fun returnHtml h = - ("HTTP/1.0 200 OK\n\ - \MIME-Version: 1.0\n\ - \Content-Type: text/html\n\n" ^ - XHtml.Unsafe.toString h) - - fun setCookies cookies = - concat (map (fn c => SMLserver.Cookie.setCookie c ^ "\n") cookies) - - fun returnHtml' nil h = returnHtml h - | returnHtml' cookies h = - ("HTTP/1.0 200 OK\n\ - \MIME-Version: 1.0\n\ - \Content-Type: text/html\n" ^ setCookies cookies ^ "\n" ^ - XHtml.Unsafe.toString h) - - fun respondExit (r:response) = - ( SMLserver.Unsafe.write r - ; SMLserver.exit()) - - structure Unsafe = - struct - fun toString x = x - - fun redirect link cookies = - ("HTTP/1.0 302 Found\n\ - \Location: " ^ link ^ "\n\ - \MIME-Version: 1.0\n" ^ setCookies cookies ^ "\n\ - \You should not be seeing this!") - end - end diff --git a/smlserver/xt/libxt/NS_SET.sml b/smlserver/xt/libxt/NS_SET.sml deleted file mode 100644 index 95c9f3d46..000000000 --- a/smlserver/xt/libxt/NS_SET.sml +++ /dev/null @@ -1,52 +0,0 @@ -signature NS_SET = sig - type set - val get : set * string -> string option - val getOpt : set * string * string -> string - val getAll : set * string -> string list - val size : set -> int - val unique : set * string -> bool - val key : set * int -> string option - val value : set * int -> string option - val list : set -> (string * string) list - val filter : (string*string->bool) -> set - -> (string*string) list - val foldl : ((string*string)*'a->'a) -> 'a -> set -> 'a - val foldr : ((string*string)*'a->'a) -> 'a -> set -> 'a -end - -(* - [set] abstract type of sequences of key-value pairs, - returned by some calls to the web-server. - - [get (s,k)] returns SOME(v) if v is the first value - associated with key k in set s; returns NONE if no value is - associated with k in s. - - [getOpt (s,k,v)] returns the first value associated with key - k in set s; returns v if no value is associated with k in s. - - [getAll (s,k)] returns all values associated with key k in - set s; returns the empty list if no values are associated - with k in s. - - [size s] returns the number of elements in a set. - - [unique (s,k)] returns true if key k appears (exactly) once - in s (case sensitive). Returns false otherwise. - - [key (s,i)] returns SOME(k) if k is the key name for the - i'th field in the set s; returns NONE if size s <= i. - - [value (s,i)] returns SOME(v) if v is the value for the - i'th field in the set s; returns NONE if size s <= i. - - [list s] returns the list representation of set s. - - [filter f s] returns the list of key-value pairs in s for - which applying f on the pairs (from left to right) returns - true. - - [foldl f acc s] identical to (foldl o list). - - [foldr f acc s] identical to (foldr o list). -*) diff --git a/smlserver/xt/libxt/NsBasics.sml b/smlserver/xt/libxt/NsBasics.sml deleted file mode 100644 index c98827672..000000000 --- a/smlserver/xt/libxt/NsBasics.sml +++ /dev/null @@ -1,5 +0,0 @@ -structure NsBasics = - struct - type status = int (* see nsthread.h *) - val OK = 0 and ERROR = ~1 and END_DATA = 4 - end diff --git a/smlserver/xt/libxt/NsSet.sml b/smlserver/xt/libxt/NsSet.sml deleted file mode 100644 index 79fb3f9f1..000000000 --- a/smlserver/xt/libxt/NsSet.sml +++ /dev/null @@ -1,56 +0,0 @@ -structure NsSet : NS_SET = - struct - type set = int - - fun isNull(s : string) : bool = prim("nssml_isNullString", s) - - fun get (s :set, key: string): string option = - let val res : string = prim("nssml_SetGet", (s,key)) - in if isNull res then NONE - else SOME res - end - fun getOpt (s:set, key:string, dflt:string): string = - Option.getOpt(get (s, key), dflt) - fun put (s: set, key: string, value: string) : unit = - prim("@Ns_SetPut", (s,key,value)) - fun free (s: set) : unit = - prim("@Ns_SetFree", s) - fun create (name: string) : set = - prim("@Ns_SetCreate", name) - fun size (s: set) : int = - prim("nssml_SetSize", s) - fun unique (s: set, key: string) : bool = - prim("@Ns_SetUnique", (s,key)) - - fun key (s: set, index: int) : string option = - let val res : string = prim("nssml_SetKey", (s, index)) - in if isNull res then NONE - else SOME res - end - - fun value (s: set, index: int) : string option = - let val res : string = prim("nssml_SetValue", (s, index)) - in if isNull res then NONE - else SOME res - end - - fun getPair(s,n) = - case (key(s,n), value(s,n)) of - (SOME k,SOME v) => (k,v) - | (SOME k,NONE) => (k,"") - | _ => raise Fail "Ns.getPair" - fun foldr (f:(string * string) * 'a -> 'a) (b:'a) (s:set) : 'a = - let fun loop (n,acc) = if n < 0 then acc - else loop (n-1, f(getPair(s,n),acc)) - in loop (size s - 1, b) - end - fun foldl (f:(string * string) * 'a -> 'a) (b:'a) (s:set) : 'a = - let fun loop (n,acc) = if n < 0 then acc - else f(getPair(s,n), loop(n-1,acc)) - in loop (size s - 1, b) - end - fun getAll (s:set, key:string): string list = - foldr (fn ((k,v),a) => if k = key then v :: a else a) nil s - fun list s = foldl (op ::) nil s - fun filter p s = foldl (fn (pair,a) => if p pair then pair :: a else a) nil s - end diff --git a/smlserver/xt/libxt/Quot.sml b/smlserver/xt/libxt/Quot.sml deleted file mode 100644 index edf0554b0..000000000 --- a/smlserver/xt/libxt/Quot.sml +++ /dev/null @@ -1,61 +0,0 @@ -signature QUOT = - sig - (* Quotation support. *) - type quot = string frag list - val ^^ : quot * quot -> quot - val fromString : string -> quot - val toString : quot -> string - val size : quot -> int - val concat : quot list -> quot - val concatFn : (quot -> quot) -> quot list -> quot - val concatWith : string -> quot list -> quot - - val implode : Char.char list -> quot - val explode : quot -> Char.char list - val map : (Char.char -> Char.char) -> quot -> quot - val translate : (Char.char -> string) -> quot -> quot - val isPrefix : quot -> quot -> bool - val compare : (quot * quot) -> order - val < : (quot * quot) -> bool - val <= : (quot * quot) -> bool - val == : (quot * quot) -> bool (* Polymorphic equality is not meaningful on quotations! *) - val > : (quot * quot) -> bool - val >= : (quot * quot) -> bool - - val wrapString : (quot -> quot) -> (string -> string) - end - -structure Quot : QUOT = - struct - type quot = string frag list - val op ^^ : quot * quot -> quot = op @ - fun toString (q : quot) : string = - concat(map (fn QUOTE s => s | ANTIQUOTE s => s) q) - fun fromString s = `^s` - val size = String.size o toString - fun concat qs = List.foldr (op ^^) `` qs - fun concatFn f qs = (concat o List.map f) qs - fun concatWith s qs = fromString (String.concatWith s (List.map toString qs)) - val implode = fromString o String.implode - val explode = String.explode o toString - fun map f q = fromString(String.map f (toString q)) - fun translate f q = fromString(String.translate f (toString q)) - fun isPrefix q1 q2 = String.isPrefix (toString q1) (toString q2) - local - fun fixPair (q1,q2) = (toString q1, toString q2) - in - val compare = String.compare o fixPair - val op < = op String.< o fixPair - val op <= = op String.<= o fixPair - val op == = op = o fixPair - val op > = op String.> o fixPair - val op >= = op String.>= o fixPair - - fun wrapString (f:quot -> quot): (string -> string) = toString o f o fromString - end - end - -type quot = Quot.quot -infixr 5 ^^ -val op ^^ = Quot.^^ - diff --git a/smlserver/xt/libxt/SMLSERVER.sig b/smlserver/xt/libxt/SMLSERVER.sig deleted file mode 100644 index 6a01ee0d4..000000000 --- a/smlserver/xt/libxt/SMLSERVER.sig +++ /dev/null @@ -1,62 +0,0 @@ -signature SMLSERVER = sig - - val log : string -> unit - -(* - type exitId - val atExit : (unit -> unit) -> exitId - val exitUnreg : exitId -> unit -*) - val exit : unit -> 'a - - val fetchUrl : string -> string option - val hostAddr : string -> string option - - val headers : unit -> (string * string) list - val mimeType : string -> string - - structure Unsafe : SMLSERVER_UNSAFE - structure Cookie : SMLSERVER_COOKIE - structure Info : SMLSERVER_INFO - structure Cache : SMLSERVER_CACHE - structure Mail : SMLSERVER_MAIL - structure DbOra : SMLSERVER_DB - structure DbPg : SMLSERVER_DB - structure DbMySQL : SMLSERVER_DB - structure Form : SMLSERVER_FORM - sharing type Form.var = Unsafe.Form.var -end - -(* - [log s] write the string s to the log file. - - [exit()] terminates the script by first executing - registered ``at exit'' functions. - - [atExit f] registers the function f to be executed upon - calls to exit(); returns a unique id, which may be given - to the exitUnreg function to unregister the execution of - the function upon exits. - - [exitUnreg eid] unregisters the execution of the ``at - exit'' function identified by eid. - - [fetchUrl u] fetches a remote URL u; connects the Web - server to another HTTP Web server and requests the - specified URL. The URL must be fully qualified. Currently, - the function cannot handle redirects or requests for any - protocol except HTTP. Returns NONE if no page is found. - - [hostAddr ip] converts a numeric IP address ip into a host - name. If no name can be found, NONE is returned. Because - the response time of the Domain Name Service can be slow, - this function may significantly delay the response to a - client. - - [headers()] returns, as a list of string pairs, the HTTP - headers associated with the request. - - [mimeType f] guesses the Mime type based on the extension - of the filename f. Case is ignored. The return value is of - the form "text/html". -*) diff --git a/smlserver/xt/libxt/SMLSERVER_CACHE.sml b/smlserver/xt/libxt/SMLSERVER_CACHE.sml deleted file mode 100644 index a157b6e72..000000000 --- a/smlserver/xt/libxt/SMLSERVER_CACHE.sml +++ /dev/null @@ -1,133 +0,0 @@ -signature SMLSERVER_CACHE = - sig - (* Cache kinds *) - datatype kind = - WhileUsed of int - | TimeOut of int - | Size of int - - (* Cache Type *) - type ('a,'b) cache - type 'a Type - type name = string - - (* Get or create a cache *) - val get : 'a Type * 'b Type * name * kind -> ('a,'b) cache - - (* Entries in a cache *) - val lookup : ('a,'b) cache -> 'a -> 'b option - val insert : ('a,'b) cache * 'a * 'b -> bool - val flush : ('a,'b) cache -> unit - - (* Memoization *) - val memoize : ('a,'b) cache -> ('a -> 'b) -> 'a -> 'b - - (* Build cache types out of predefined cache types *) - val Pair : 'a Type -> 'b Type -> ('a*'b) Type - val Option : 'a Type -> 'a option Type - val List : 'a Type -> 'a list Type - val Triple : 'a Type -> 'b Type -> 'c Type -> ('a*'b*'c) Type - - (* Cache info *) - val pp_type : 'a Type -> string - val pp_cache : ('a,'b) cache -> string - - (* Predefined cache types *) - val Int : int Type - val Real : real Type - val Bool : bool Type - val Char : char Type - val String : string Type - end - -(* - [kind] abstract type for cache kind. A cache kind describes the - strategy used by the cache to insert and emit cache entries. The - following strategies are supported: - - * WhileUsed t : elements are emitted from the cache after - approximately t seconds after the last use. - - * TimeOut t : elements are emitted from the cache after - approximately t seconds after they are inserted. - - * Size n : the cache has a maximum size of n bytes. Elements are - emitted as needed in order to store new elements. The size n - should not be too small, a minimum size of 1 Kb seems to work - fine for small caches; larger cache sizes are also supported. - - [('a,'b) cache] abstract type of cache. A cache is a mapping from - keys of type 'a to elements of type 'b. Only values of type 'a - Type and 'b Type can be used as keys and elements, respectively. - - ['a Type] abstract type of either a key or element that can be - used in a cache. - - [name] abstract type of the name of a cache. - - [get (cn,ck,aType,bType)] returns a cache which is named cn. The - cache will be a mapping from keys of type aType into elements of - type bType. The cache strategy is described by ck. - - * If no cache exists with name cn, then a new cache is created. - - * If a cache c exists with name cn, then there are two - possibilities: - - 1) If c is a mapping from aType to bType, then c is - returned. - - 2) If c is not a mapping from aType to bType, then a new - cache c' is created and returned. - - It is possible to create two caches with the same name, but only - if they describe mappings of different type. - - AOLserver does not support arbitrary long cache names. The cache - name you provide is only part of the constructed name that we use - in AOLserver (i.e., we append typing information to the name you - provide in order to maintain type safety). The function get - raises exception Fail in case the constructed cache name is too - large for AOLserver. This issue is solved in future (version 4) - releases of AOLserver. - - [lookup c k] returns the value associated with the key k in cache - c; returns NONE if k is not in the cache. - - [insert (c,k,v)] associates a key k with a value v in the cache c; - overwrites existing entry in cache if k is present, in which case - the function returns false. If no previous entry for the key is - present in the cache, the function returns true. - - [flush c] deletes all entries in cache c. - - [memoize c f] implements memoization on the function f. The - function f must be a mapping of keys and elements that can be - stored in a cache, that is, f is of type 'a Type -> 'b Type. - - [Pair aType bType] returns the pair type representing the pairs - (a,b) where a is of type aType and b is of type bType. - - [Option aType] returns the type aType option, representing a - option where a is of type aType. - - [List aType] returns the list type representing the list of - elements of type aType. - - [Triple aType bType cType] similar to Pair except that the triple - is represented with as one Pair embedded in another Pair: - ((a,b),c) where a is of type aType, b is of type bType and c is of - type cType. - - [pp_type aType] pretty prints the type aType. - - [pp_cache c] pretty prints the cache. - - (* Pre defined cache types *) - [Int] predefined cache type representing integers. - [Real] predefined cache type representing reals. - [Bool] predefined cache type representing booleans. - [Char] predefined cache type representing characters. - [String] predefined cache type representing strings. - -*) diff --git a/smlserver/xt/libxt/SMLSERVER_COOKIE.sml b/smlserver/xt/libxt/SMLSERVER_COOKIE.sml deleted file mode 100644 index 1866937c6..000000000 --- a/smlserver/xt/libxt/SMLSERVER_COOKIE.sml +++ /dev/null @@ -1,47 +0,0 @@ -signature SMLSERVER_COOKIE = sig - exception CookieError of string - type cookiedata = {name : string, - value : string, - expiry : Date.date option, - domain : string option, - path : string option, - secure : bool} - val allCookies : unit -> (string * string) list - val getCookie : string -> (string * string) option - val getCookieValue : string -> string option - val setCookie : cookiedata -> string - val setCookies : cookiedata list -> string - val deleteCookie : {name: string, path: string option} - -> string -end - -(* - [CookieError s] exception raised on error with message s. - - [cookiedata] type of cookie. - - [allCookies()] returns a list [(n1,v1), (n2,v2), ..., - (nm,vm)] of all the name=value pairs of defined cookies. - - [getCookie cn] returns SOME(value) where value is the - 'cn=value' string for the cookie cn, if any; otherwise - returns NONE. - - [getCookieValue cn] returns SOME(v) where v is the value - associated with the cookie cn, if any; otherwise returns - NONE. - - [setCookie {name,value,expiry,domain,path,secure}] returns - a string which (when transmitted to a browser as part of - the HTTP response header) sets a cookie with the given name, - value, expiry date, domain, path, and security level. - - [setCookies ckds] returns a string which (when transmitted - to a browser as part of the HTTP response header) sets the - specified cookies. - - [deleteCookie {name,path}] returns a string that (when - transmitted to a browser as part of the HTTP response - header) deletes the specified cookie by setting its expiry - to some time in the past. -*) diff --git a/smlserver/xt/libxt/SMLSERVER_DB.sml b/smlserver/xt/libxt/SMLSERVER_DB.sml deleted file mode 100644 index 95f361d79..000000000 --- a/smlserver/xt/libxt/SMLSERVER_DB.sml +++ /dev/null @@ -1,173 +0,0 @@ -signature SMLSERVER_DB = - sig - structure Handle : SMLSERVER_DB_HANDLE - - (* Data manipulation language *) - val dml : quot -> unit - val exec : quot -> unit - val maybeDml : quot -> unit - val panicDml : (quot -> 'a) -> quot -> unit - - (* Stored Procedure *) - val execSp : quot list -> unit - - (* Queries *) - val fold : ((string->string)*'a->'a) -> 'a - -> quot -> 'a - val app : ((string->string)->'a) -> quot - -> unit - val list : ((string->string)->'a) -> quot - -> 'a list - val oneField : quot -> string - val zeroOrOneField: quot -> string option - val oneRow : quot -> string list - val oneRow' : ((string->string)->'a) -> quot -> 'a - val zeroOrOneRow : quot -> string list option - val zeroOrOneRow' : ((string->string)->'a) -> quot - -> 'a option - val existsOneRow : quot -> bool - - (* Sequences *) - val seqNextvalExp : string -> string - val seqNextval : string -> int - val seqCurrvalExp : string -> string - val seqCurrval : string -> int - - (* Miscellaneous *) - val sysdateExp : string - val qq : string -> string - val qqq : string -> string - val toDate : string -> Date.date option - val timestampType : string - val toTimestampExp: string -> string - val toTimestamp : string -> Date.date option - val fromDate : Date.date -> string - val valueList : string list -> string - val setList : (string*string) list -> string - end - -(* - [dml sql] executes the data manipulation language command - sql using a database handle obtained from the next pool. - Raises Fail msg if sql is unsuccessful; msg is the error - message returned from the database. - - [maybeDml sql] executes sql and returns the value unit. Does - not raise Fail - errors are suppressed. - - [panicDml f sql] executes sql and returns the value unit. On - error the function f is applied to an error string. The - function always returns unit. - - [fold f b sql] executes SQL statement sql and folds over the - result set. b is the base and f is the fold function; the - first argument to f is a function that maps column names to - values. Raises Fail msg on error. - - [app f sql] executes SQL statement sql and applies f on each - row in the result set. Raises Fail on error. - - [list f sql] executes SQL statement sql and applies f on - each row in the result set. The result elements are returned - as a list. Raises Fail on error. - - [oneField sql] executes SQL statement sql, which must return - exactly one row with one column, which the function returns - as a string. Raises Fail on error. - - [zeroOrOneField sql] executes SQL statement sql, which must - return either zero or one row. If one row is returned then - there must be exactly one column in the row. Raises Fail on - error. - - [oneRow sql] executes SQL statement sql, which must return - exactly one row. Returns all columns as a list of strings. - Raises Fail on error. - - [oneRow' f sql] executes SQL statement sql, which must - return exactly one row. Returns f applied on the row. Raises - Fail on error. - - [zeroOrOneRow sql] executes SQL statement sql, which must - return either zero or one row. Returns all columns as a list - of strings. Raises Fail on error. - - [zeroOrOneRow' f sql] executes SQL statement sql, which must - return either zero or one row. Returns f applied on the row - if a row exists. Raises Fail on error. - - [existsOneRow sql] executes SQL statement sql and returns - true if the query results in one or more rows; otherwise - returns false. Raises Fail on error. - - [seqNextvalExp seq_name] returns a string to fit in an SQL - statement generating a new number from sequence seq_name. - - [seqNextval seq_name] executes SQL statement to generate a - new number from sequence seq_name. Raise Fail on error. - - [seqCurrvalExp seq_name] returns a string to fit in an SQL - statement returning the current number from the sequence - seq_name. - - [seqCurrval seqName] executes SQL statement to get the - current number from sequence seq_name. Raises Fail on - error. - - [sysdateExp] returns a string representing the current date - to be used in an SQL statement (to have your application - support different database vendors). - - [qq v] returns a string with each quote (') replaced by - double quotes ('') (e.g., qq("don't go") = "don''t go"). - - [qqq v] similar to qq except that the result is encapsulated - by quotes (e.g., qqq("don't go") = "'don''t go'"). - - [toDate d] returns the Date.date representation of d, where - d is the date representation used in the particular - database. Returns NONE if d cannot be converted into a - Date.date. Only year, month and day are considered. - - [timestampType] returns the database type (as a string) - representing a timestamp (to have your application support - different database vendors). - - [toTimestampExp d] returns a string to put in a select - statement, which will return a timestamp representation of - column d. Example: `select ^(Db.toTimestampExp "d") from t` - where d is a column of type date (in oracle) or datatime (in - PostgreSQL and MySQL). - - [toTimestamp t] returns the Date.date representation of t, - where d is the timestap representation from the database. - Returns NONE if t cannot be converted into a Date.date. - Year, month, day, hour, minutes and seconds are considered. - - [fromDate d] returns a string to be used in an SQL statement - to insert the date d in the database. - - [valueList vs] returns a string formatted to be part of an - insert statement: - - `insert into t (f1,f2,f3) - values (^(Db.valueList [f1,f2,f3]))` - - is turned into - - `insert into t (f1,f2,f3) - values ('f1_','f2_','f3_')` - - where fi_ are the properly quoted values. - - [setList nvs] returns a string formatted to be part of an - update statement. Say nvs = [(n1,v1),(n2,v2)], then - - `update t set ^(Db.setList nvs)` - - is turned into - - `update t set n1='v1_',n2='v2_'` - - where vi_ are the properly quoted values. -*) \ No newline at end of file diff --git a/smlserver/xt/libxt/SMLSERVER_DB_HANDLE.sml b/smlserver/xt/libxt/SMLSERVER_DB_HANDLE.sml deleted file mode 100644 index a2f8288e3..000000000 --- a/smlserver/xt/libxt/SMLSERVER_DB_HANDLE.sml +++ /dev/null @@ -1,150 +0,0 @@ -signature SMLSERVER_DB_HANDLE = - sig - (* Database handles *) - type db - - val getHandle : unit -> db - val putHandle : db -> unit - val wrapDb : (db -> 'a) -> 'a - val initPools : string list -> unit - - (* Data manipulation language *) - val dmlDb : db -> quot -> unit - val execDb : db -> quot -> unit - val panicDmlDb : db -> (quot->'a) -> quot -> unit - - (* Transactions *) - val dmlTransDb : db -> (db -> 'a) -> 'a - val dmlTrans : (db -> 'a) -> 'a - val panicDmlTransDb : db -> (quot->'a) -> (db->'a) -> 'a - val panicDmlTrans : (quot->'a) -> (db->'a) -> 'a - - (* Stored Procedure *) - val execSpDb : db -> quot list -> unit - - (* Queries *) - val foldDb : db -> ((string->string)*'a->'a) - -> 'a -> quot -> 'a - val appDb : db -> ((string->string)->'a) - -> quot -> unit - val listDb : db -> ((string->string)->'a) - -> quot -> 'a list - val zeroOrOneRowDb : db -> quot -> string list option - val oneFieldDb : db -> quot -> string - val zeroOrOneFieldDb: db -> quot -> string option - val oneRowDb : db -> quot -> string list - val oneRowDb' : db -> ((string->string)->'a) - -> quot -> 'a - val zeroOrOneRowDb' : db -> ((string->string)->'a) - -> quot -> 'a option - val existsOneRowDb : db -> quot -> bool - - (* Sequences *) - val seqNextvalDb : db -> string -> int - val seqCurrvalDb : db -> string -> int - end - -(* - [db] type of database handle. Whenever the Web server talks - to the database, it is by means of a database handle. - Database handles are kept in the Web server using a - prioritized set of pools. Each Web script obtains and - releases database handles from the set of pools in a stack- - like manner (each script may own at most one database handle - from each pool). This arrangement is to avoid the - possibility of deadlocks in case multiple Web scripts run - simultaneously. - - [getHandle] returns a database handle from the next - available pool. Raises Fail if no more pools are available. - - [putHandle db] returns the database handle db to its pool - and makes the pool available to a subsequent call to - getHandle. - - [initPools pools] initializes the set of pools. The pools - must be defined in the nsd.tcl configuration file. See the - file lib/Db.sml for a use of this function. - - [dmlDb db dml] executes the data manipulation language - command dml using database handle db. Raises Fail msg if dml - is unsuccessful; msg is the error message returned from the - database. - - [panicDmlDb db f sql] executes the data manipulation - language command dml using database handle db. Calls the - function f with with an error message as argument if the dml - command is unsuccessful. panicDmlDb returns unit and raises - an exception only if f does. - - [dmlTransDb db f] executes function f using handle db, which - may send a series of SQL statements to the database. All SQL - statements are executed as one atomic transaction. If any - statement fails or any exception is raised inside f, then - the transaction is rolled back and the exception is raised. - - [dmlTrans f] similar to dmlTransDb, but with a database - handle obtained from the next available pool. - - [panicDmlTransDb db f_panic f_db] same as dmlTransDb except - that on error function f_panic is executed. panicDmlTransDb - returns the value returned by f_panic unless f_panic raises - an exception, in which case panicDmlTransDb raises this - exception. - - [panicDmlTrans f_panic f_db] similar to panicDmlTransDb, but - a database handle is obtained from the next available pool. - - [foldDb db f b sql] executes SQL statement sql and folds - over the result set. b is the base and f is the fold - function; the first argument to f is a function that maps - column names to values. Raises Fail msg on error. - - [appDb db f sql] executes SQL statement sql and applies f on - each row in the result set. Raises Fail on error. - - [listDb db f sql] executes SQL statement sql and applies f - on each row in the result set. The result elements are - returned as a list. Raises Fail on error. - - [zeroOrOneRowDb db sql] executes SQL statement that must - return either zero or one row. Returns all columns as a list - of strings. Raises Fail on error. - - [oneFieldDb db sql] executes SQL statement sql, which must - return exactly one row with one column, which the function - returns as a string. Raises Fail on error. - - [zeroOrOneFieldDb db sql] executes SQL statement sql, which - must return either zero or one row. If one row is returned - then there must be exactly one column in the row. Raises - Fail on error. - - [oneRowDb db sql] executes SQL statement sql, which must - return exactly one row. Returns all columns as a list of - strings. Raises Fail on error. - - [oneRowDb' db f sql] executes SQL statement sql, which must - return exactly one row. Returns f applied on the row. Raises - Fail on error. - - [zeroOrOneRowDb' db f sql] executes SQL statement sql, which - must return either zero or one row. Returns f applied on the - row if it exists. Raises Fail on error. - - [existsOneRowDb db sql] executes SQL statement sql and - returns true if one or more rows are returned; otherwise - returns false. Raises Fail on error. - - [seqNextvalDb db seq_name] executes SQL statement using - database handle db to generate a new number from sequence - seq_name. Raise Fail on error. - - [seqCurrvalDb db seqName] executes SQL statement using - database handle db to get the current number from sequence - seq_name. Raises Fail on error. - - [wrapDb f] obtains a handle db with getHandle. applies f to - db and before returning the result, the handle db is - returned with putHandle. -*) \ No newline at end of file diff --git a/smlserver/xt/libxt/SMLSERVER_FORM.sml b/smlserver/xt/libxt/SMLSERVER_FORM.sml deleted file mode 100644 index 062c6ce39..000000000 --- a/smlserver/xt/libxt/SMLSERVER_FORM.sml +++ /dev/null @@ -1,39 +0,0 @@ -signature SMLSERVER_FORM = - sig - type 't var - - (* Support for extracting values from forms *) - datatype 't arg = Ok of 't | Wrong | Missing - val get : 't var -> 't arg - - (* Support for constructing form content to be used in - * hidden form variables, radio boxes, etc. *) - type 't Type = 't -> 't var - val Int : int Type - val String : string Type - val Bool : bool Type -(* - val Pair : 'a Type * 'b Type -> ('a * 'b) Type - val Option : 'a Type -> 'a option Type - val List : 'a Type -> 'a list Type -*) - end - -signature SMLSERVER_FORM_UNSAFE = - sig - include SMLSERVER_FORM - - (* The function toString is used for generating actual - * XHTML to send to clients *) - val toString : 't var -> string - - (* The following functions are used for scriptlet - * functor instantiations *) - val fromBool : string -> bool var - val fromString : string -> string var - val fromInt : string -> int var - val fromList : (string -> 'a var) -> string list -> 'a list var - val fromOption : (string -> 'a var) -> string option -> 'a option var - - val missing : unit -> 'a var - end diff --git a/smlserver/xt/libxt/SMLSERVER_INFO.sml b/smlserver/xt/libxt/SMLSERVER_INFO.sml deleted file mode 100644 index c306179e7..000000000 --- a/smlserver/xt/libxt/SMLSERVER_INFO.sml +++ /dev/null @@ -1,27 +0,0 @@ -signature SMLSERVER_INFO = sig - - val hostname : unit -> string - val host : unit -> string - val port : unit -> int - - val pageRoot : unit -> string - val location : unit -> string - val url : unit -> string -end - -(* - [hostname()] returns the host name of the machine. - - [host()] returns the IP address associated with the server. - - [port()] returns the port number associated with the server. - - [pageRoot()] returns the directory for which the server - serves pages. - - [location()] returns the HTTP location associated with the - server. For example: http://www.avalon.com:81. - - [url()] return the url (relative to pageRoot) associated - with the request. -*) diff --git a/smlserver/xt/libxt/SMLSERVER_MAIL.sml b/smlserver/xt/libxt/SMLSERVER_MAIL.sml deleted file mode 100644 index 4d13b0db1..000000000 --- a/smlserver/xt/libxt/SMLSERVER_MAIL.sml +++ /dev/null @@ -1,16 +0,0 @@ -signature SMLSERVER_MAIL = sig - val sendmail : {to: string list, cc: string list, - bcc: string list, from: string, - subject: string, body: string, - extra_headers: string list} -> unit - val send : {to: string, from: string, - subject: string, body: string} -> unit -end - -(* - [sendmail {to,cc,bcc,from,subject,body,extra_headers}] sends - an email to the addresses in to, cc, and bcc. - - [send {to,from,subject,body}] abbreviated version of - sendmail. -*) diff --git a/smlserver/xt/libxt/SMLSERVER_UNSAFE.sml b/smlserver/xt/libxt/SMLSERVER_UNSAFE.sml deleted file mode 100644 index 47af23b08..000000000 --- a/smlserver/xt/libxt/SMLSERVER_UNSAFE.sml +++ /dev/null @@ -1,81 +0,0 @@ -signature SMLSERVER_UNSAFE = sig - - exception MissingConnection - - eqtype status - val OK : status - val ERROR : status - val END_DATA : status - - val write : string -> status - val returnFileMime : string -> string -> status - val returnFile : string -> status - - val formvar : string -> string option - val formvarAll : string -> string list - - val registerTrap : string -> unit - val scheduleScript : string -> int -> unit - val scheduleDaily : string -> {hour:int, minute:int} - -> unit - val scheduleWeekly : string -> {day:int, hour:int, minute:int} - -> unit - - structure Form : SMLSERVER_FORM_UNSAFE -end - -(* - [status] abstract type of status code returned by - functions. - - [OK] status code indicating success. - - [ERROR] status code indicating failure. - - [END_DATA] status code indicating end of data. - - [return q] sends string q to browser with status code - 200, adding HTTP headers. Returns OK on success and ERROR - on failure. - - [write q] sends string q to browser. Returns OK on success - and ERROR on failure. - - [returnFileMime mimetype file] returns the entire contents - of the given file to the client. In addition to setting the - HTTP status response line to 200 and the Content-Type header - from the given parameter, the function also uses the stat - system call to generate the appropriate Last-Modified and - Content-Length headers. The function returns a status of OK - or ERROR. - - [returnFile file] as returnFileMime, but gets the - Content-Type (mimetype) argument from calling the function - getMimeType with the given file as parameter. - - [registerTrap p] after a call to this function, requests for - files that matches the path p, which may contain globs, are - trapped. The effect of a file being trapped is that the - script ../sys/trap.sml is executed instead. Usually, calls - to the registerTrap function appears in the initialization - script ../sys/init.sml to control access to web content. - - [scheduleScript f d] after a call to this function, the - script determined by the file f is scheduled to execute - every d seconds. Usually, calls to the scheduleScript - function appears in the initialization script - ../sys/init.sml to setup scheduled execution. - - [scheduleDaily f {hour,minute}] after a call to this - function, the script determined by the file f is scheduled - to execute every day at the specified time (hour and - minute). The hour can be an integer from 0 to 23, and the - minute an integer from 0 to 59. - - [scheduleWeekly f {day,hour,minute}] after a call to this - function, the script determined by the file f is scheduled - to execute every week at the specified time (day, hour, and - minute). The day can be an integer from 0 to 6, where 0 - represents Sunday. The hour can be an integer from 0 to 23, - and the minute an integer from 0 to 59. -*) \ No newline at end of file diff --git a/smlserver/xt/libxt/SMLserver.sml b/smlserver/xt/libxt/SMLserver.sml deleted file mode 100644 index a413d5d3c..000000000 --- a/smlserver/xt/libxt/SMLserver.sml +++ /dev/null @@ -1,620 +0,0 @@ -structure SMLserver :> SMLSERVER = - struct - structure Unsafe = SMLserverUnsafe - - local - type LogSeverity = int - val Notice=0 and Warning=1 and Error=2 and Fatal=3 - and Bug=4 and Debug=5 - fun log' (ls: LogSeverity, s: string) : unit = - prim("@Ns_Log", (ls, s)) - in - fun log s = log' (Notice, s) - end - - (* exit(): execute registered ``at exit'' functions and halt - * the evaluation. The byte code backend translates the - * OS.Process.terminate function into a HALT instruction, - * which takes care of freeing region pages. The functions - * atExit and exitUnreg may be used, for instance, to close - * database connections in case of errors. - *) - - structure Exit = - struct - type exitId = int - local - fun terminate () = OS.Process.terminate OS.Process.success - val tasks : (int * (unit -> unit)) list ref = ref nil - val c : int ref = ref 0 - in - fun atExit f : exitId = - let val i = !c - in c := i + 1 - ; tasks := (i,f) :: !tasks - ; i - end - fun exitUnreg (eid: exitId) : unit = - let fun loop ((x as (e,_))::xs) = if e = eid then xs else x :: loop xs - | loop nil = nil - in tasks := loop (!tasks) - end - fun exit() = - ( List.app (fn (_,f) => f()) (!tasks) - ; terminate()) - end - end - open Exit - - fun isNull(s : string) : bool = prim("nssml_isNullString", s) - - fun fetchUrl (url : string) : string option = - let val res:string = prim("nssml_FetchUrl", url) - in if isNull res then NONE else SOME res - end - - fun hostAddr(s: string) : string option = - let val res : string = prim("nssml_GetHostByAddr", s) - in if isNull res then NONE - else SOME res - end - - local - type conn = int - fun getConn0 () : conn = - prim("@Ns_TclGetConn", (0:int)) - in - fun hasConnection() : bool = - getConn0() <> 0 - - fun getConn() : conn = - let val c = getConn0() - in if c = 0 then - (log "SMLserverUnsafe: missing connection"; - raise Unsafe.MissingConnection) - else c - end - end - - - local - fun headers0() : NsSet.set = - prim("@Ns_ConnHeaders", getConn()) - in - fun headers() : (string * string) list = - NsSet.list (headers0()) - end - - fun mimeType(s: string) : string = - prim("nssml_GetMimeType", s) - - structure Cookie = - struct - (* This is an modified implementation of Cookies found in MoscowML. - This is from the MoscowML source: - - (c) Hans Molin, Computing Science Dept., Uppsala University, 1999. - http://www.csd.uu.se/~d97ham/ d97ham@csd.uu.se - - Documentation, cleanup and efficiency improvements by sestoft@dina.kvl.dk - - Anyone is granted the right to copy and/or use this code, provided - that this note is retained, also in modified versions. The code is - provided as is with no guarantee about any functionality. I take no - responsibility for its proper function. *) - - fun encodeUrl(s: string) : string = - prim("nssml_EncodeUrl", s) - - fun decodeUrl(s: string) : string = - prim("nssml_DecodeUrl", s) - - local - fun concatOpt s NONE = "" - | concatOpt s (SOME t) = s ^ t - in - exception CookieError of string - - type cookiedata = - {name : string, - value : string, - expiry : Date.date option, - domain : string option, - path : string option, - secure : bool} - - fun allCookies() : (string * string) list = - case List.filter (fn (k,_) => k = "Cookie") (headers()) of - [] => [] - | ([(k,cv)]) => - let - fun splitNameAndValue sus = - let - val (pref,suff) = Substring.position "=" sus - in - (decodeUrl (Substring.concat (Substring.fields (fn c => c = #" ") pref)), - decodeUrl (Substring.concat (Substring.fields (fn c => c = #" ") (Substring.triml 1 suff)))) - end - in - List.map splitNameAndValue (Substring.tokens (fn c => c = #";") (Substring.all cv)) - end - | _ => raise CookieError "More than one Cookie line in the header" - - fun getCookie cn = List.find (fn (name,value) => cn = name) (allCookies()) - - fun getCookieValue cn = - case getCookie cn of - NONE => NONE - | SOME (n,v) => SOME v - - (* Date must be GMT time, that is, use Date.fromTimeUniv *) - fun setCookie {name : string, value : string, expiry : Date.date option, - domain : string option, path : string option, secure : bool} = - let - fun datefmt date = Date.fmt "%a, %d-%b-%Y %H:%M:%S GMT" date - in - if name = "" orelse value= "" - then raise CookieError "Name or value empty in call to setCookie" - else String.concat - ["Set-cookie: ", encodeUrl name, "=", encodeUrl value, - concatOpt "; expires=" (Option.map datefmt expiry), - concatOpt "; domain=" domain, - concatOpt "; path=" path, - "; ", if secure then "secure" else ""] - end - - fun setCookies cookies = String.concat (List.map setCookie cookies) - - fun deleteCookie { name : string, path : string option } : string = - String.concat["Set-cookie: ", encodeUrl name, "=deleted;", - "expires=Friday, 11-Feb-77 12:00:00 GMT", - concatOpt "; path=" path] - end - end - - structure StringCache (* : NS_STRING_CACHE *) = - struct - type cache = int - fun createTm(n : string, t: int) : cache = - prim("nssml_CacheCreate", (n,t)) - fun createSz(n : string, sz: int) : cache = (* sz is in bytes *) - prim("nssml_CacheCreateSz", (n,sz)) - fun find (n : string) : cache option = - let val res : int = prim("@Ns_CacheFind", n) - in if res = 0 then NONE - else SOME res - end - fun findTm(cn: string, t: int) : cache = - case find cn of - NONE => createTm(cn,t) - | SOME c => c - fun findSz(cn: string, s: int) : cache = - case find cn of - NONE => createSz(cn,s) - | SOME c => c - fun flush(c:cache) : unit = - prim("@Ns_CacheFlush", c) - fun set(c:cache, k:string, v:string) : bool = - let - val res : int = prim("nssml_CacheSet", (c,k,v)) - in res = 1 - end - fun get(c:cache, k:string) : string option = - let val res : string = prim("nssml_CacheGet", (c,k)) - in if isNull res then NONE - else SOME res - end - - local - fun cache_fn (f:string->string, cn: string,t: int) set get = - (fn k => - case find cn of - NONE => let val v = f k in (set (createTm(cn,t),k,v);v) end - | SOME c => (case get (c,k) of - NONE => let val v = f k in (set (c,k,v);v) end - | SOME v => v)) - in - fun cacheWhileUsed (arg as (f:string->string, cn: string, t: int)) = - cache_fn arg set get - fun cacheForAwhile (arg as (f:string->string, cn: string, t: int)) = - let - open Time - fun set'(c,k,v) = set(c,k, toString (now()) ^ ":" ^ v) - fun get'(c,k) = - case get(c,k) of - NONE => NONE - | SOME t0_v => - (case scan Substring.getc (Substring.all t0_v) - of SOME (t0,s) => - (case Substring.getc s - of SOME (#":",v) => - if now() > t0 + (fromSeconds t) - then NONE - else SOME (Substring.string v) - | _ => NONE) - | NONE => NONE) - in - cache_fn arg set' get' - end - end - end - - structure Cache : SMLSERVER_CACHE = - struct - (* This module uses the basic cache functionalities - implemented in NS_STRING_CACHE *) - - val max_cache_name_size = 31 (* Max size of cache name supported by AOLserver pre version 4 is - 32 and we leave one slot for the terminating \0. *) - - datatype kind = - WhileUsed of int - | TimeOut of int - | Size of int - - type name = string - - type 'a Type = {name: string, - to_string: 'a -> string, - from_string: string -> 'a} - - type ('a,'b) cache = {name: string, - kind: kind, - domType: 'a Type, - rangeType: 'b Type, - cache: StringCache.cache} - - (* Cache info *) - fun pp_kind kind = - case kind of - WhileUsed t => "WhileUsed(" ^ (Int.toString t) ^ ")" - | TimeOut t => "TimeOut(" ^ (Int.toString t) ^ ")" - | Size n => "Size(" ^ (Int.toString n) ^ ")" - - fun pp_type (t: 'a Type) = #name t - fun pp_cache (c: ('a,'b)cache) = - "[name:" ^ (#name c) ^ ",kind:" ^ (pp_kind(#kind c)) ^ - ",domType: " ^ (pp_type (#domType c)) ^ - ",rangeType: " ^ (pp_type (#rangeType c)) ^ "]" - - fun get (domType:'a Type,rangeType: 'b Type,name,kind) = - let - fun pp_kind kind = - case kind of - WhileUsed t => "W" - | TimeOut t => "T" - | Size n => "S" - val c_name = name ^ (pp_kind kind) ^ #name(domType) ^ #name(rangeType) - val _ = - if String.size c_name > max_cache_name_size then - raise Fail ("Ns.Cache.get: Can't create cache because cache name " ^ - c_name ^ " is larger than " ^ (Int.toString max_cache_name_size)) - else () - val cache = - case kind of - Size n => StringCache.findSz(c_name,n) - | WhileUsed t => StringCache.findTm(c_name,t) - | TimeOut t => StringCache.findTm(c_name,t) - - in - {name=c_name, - kind=kind, - domType=domType, - rangeType=rangeType, - cache=cache} - end - - local - open Time - fun getWhileUsed (c: ('a,'b) cache) k = - StringCache.get(#cache c,#to_string(#domType c) k) - fun getTimeOut (c: ('a,'b) cache) k t = - case StringCache.get(#cache c,#to_string(#domType c) k) of - NONE => NONE - | SOME t0_v => - (case scan Substring.getc (Substring.all t0_v) - of SOME (t0,s) => - (case Substring.getc s - of SOME (#":",v) => - if now() > t0 + (fromSeconds t) - then NONE - else SOME (Substring.string v) - | _ => NONE) - | NONE => NONE) - in - fun lookup (c:('a,'b) cache) (k: 'a) = - let - val v = - case #kind c of - Size n => StringCache.get(#cache c,#to_string(#domType c) k) - | WhileUsed t => getWhileUsed c k - | TimeOut t => getTimeOut c k t - in - case v of - NONE => NONE - | SOME s => SOME ((#from_string (#rangeType c)) s) - end - end - - fun insert (c: ('a,'b) cache, k: 'a, v: 'b) = - case #kind c of - Size n => StringCache.set(#cache c, - #to_string (#domType c) k, - #to_string (#rangeType c) v) - | WhileUsed t => StringCache.set(#cache c, - #to_string (#domType c) k, - #to_string (#rangeType c) v) - | TimeOut t => StringCache.set(#cache c, - #to_string(#domType c) k, - Time.toString (Time.now()) ^ ":" ^ ((#to_string (#rangeType c)) v)) - - fun flush (c: ('a,'b) cache) = StringCache.flush (#cache c) - - fun memoize (c: ('a,'b) cache) (f:('a -> 'b)) = - (fn k => - (case lookup c k of - NONE => let val v = f k in (insert (c,k,v);v) end - | SOME v => v)) - - fun Pair (t1 : 'a Type) (t2: 'b Type) = - let - (* Type pair is printed: (type1,type2) *) - val name = "(" ^ (#name t1) ^ "," ^ (#name t2) ^ ")" - fun to_string (a,b) = - let - val a_s = (#to_string t1) a - val a_sz = Int.toString (String.size a_s) - val b_s = (#to_string t2) b - in - a_sz ^ ":" ^ a_s ^ b_s - end - fun from_string s = - let - val s' = Substring.all s - val (a_sz,rest) = - Option.valOf (Int.scan StringCvt.DEC Substring.getc s') - val rest = #2(Option.valOf (Substring.getc rest)) (* skip ":" *) - val (a_s,b_s) = (Substring.slice(rest,0,SOME a_sz),Substring.slice(rest,a_sz,NONE)) - val a = (#from_string t1) (Substring.string a_s) - val b = (#from_string t2) (Substring.string b_s) - in - (a,b) - end - in - {name=name, - to_string=to_string, - from_string=from_string} - end - - fun Option (t : 'a Type) = - let - (* Option type is printed: O(type) *) - val name = "O(" ^ (#name t) ^ ")" - fun to_string a = - case a of - NONE => "0:N()" - | SOME v => - let - val v_s = (#to_string t) v - val v_sz = Int.toString (String.size v_s) - in - v_sz ^ ":S(" ^ v_s ^ ")" - end - fun from_string s = - let - val s' = Substring.all s - val (v_sz,rest) = - Option.valOf (Int.scan StringCvt.DEC Substring.getc s') - val rest = #2(Option.valOf (Substring.getc rest)) (* skip ":" *) - val (N_S,rest) = Option.valOf (Substring.getc rest) (* read N og S *) - val rest = #2(Option.valOf (Substring.getc rest)) (* skip "(" *) - in - if N_S = #"S" then - SOME ((#from_string t) (Substring.string (Substring.slice(rest,0,SOME v_sz)))) - else - NONE - end - in - {name=name, - to_string=to_string, - from_string=from_string} - end - - fun List (t : 'a Type ) = - let - (* List type is printed: L(type) *) - val name = "L(" ^ (#name t) ^ ")" - (* Format: [x1_sz:x1...xN_sz:xN] *) - fun to_string xs = - let - fun to_string_x x = - let - val v_x = (#to_string t) x - in - Int.toString (String.size v_x) ^ ":" ^ v_x - end - val xs' = List.map to_string_x xs - in - "[" ^ (String.concat xs') ^ "]" - end - fun from_string s = - let - fun read_x (rest,acc) = - if Substring.size rest = 1 (* "]" *) then - List.rev acc - else - let - val (x_sz,rest) = Option.valOf (Int.scan StringCvt.DEC Substring.getc rest) - val rest = #2(Option.valOf (Substring.getc rest)) (* skip ":" *) - val (x_s,rest) = (Substring.slice(rest,0,SOME x_sz),Substring.slice(rest,x_sz,NONE)) - in - read_x (rest,((#from_string t) (Substring.string x_s)) :: acc) - end - val s' = Substring.all s - val rest = #2(Option.valOf (Substring.getc s')) (* skip "[" *) - in - read_x (rest,[]) - end - in - {name=name, - to_string=to_string, - from_string=from_string} - end - - fun Triple (t1 : 'a Type) (t2: 'b Type) (t3: 'c Type) = - let - (* Type triple is printed (type1,type2,type3) *) - val name = "(" ^ (#name t1) ^ "," ^ (#name t2) ^ "," ^ (#name t3) ^ ")" - fun to_string (a,b,c) = - let - val a_s = (#to_string t1) a - val a_sz = Int.toString (String.size a_s) - val b_s = (#to_string t2) b - val b_sz = Int.toString (String.size b_s) - val c_s = (#to_string t3) c - in - a_sz ^ ":" ^ a_s ^ b_sz ^ ":" ^ b_s ^ c_s - end - fun from_string s = - let - val s' = Substring.all s - val (a_sz,rest) = - Option.valOf (Int.scan StringCvt.DEC Substring.getc s') - val rest = #2(Option.valOf (Substring.getc rest)) (* skip ":" *) - val (a_s,rest) = (Substring.slice(rest,0,SOME a_sz),Substring.slice(rest,a_sz,NONE)) - val (b_sz,rest) = - Option.valOf (Int.scan StringCvt.DEC Substring.getc rest) - val rest = #2(Option.valOf (Substring.getc rest)) (* skip ":" *) - val (b_s,c_s) = (Substring.slice(rest,0,SOME b_sz),Substring.slice(rest,b_sz,NONE)) - val a = (#from_string t1) (Substring.string a_s) - val b = (#from_string t2) (Substring.string b_s) - val c = (#from_string t3) (Substring.string c_s) - in - (a,b,c) - end - in - {name=name, - to_string=to_string, - from_string=from_string} - end - - (* Pre defined cache types *) - val Int = {name="I",to_string=Int.toString,from_string=Option.valOf o Int.fromString} - val Real = {name="R",to_string=Real.toString,from_string=Option.valOf o Real.fromString} - val Bool = {name="B",to_string=Bool.toString,from_string=Option.valOf o Bool.fromString} - val Char = {name="C",to_string=Char.toString,from_string=Option.valOf o Char.fromString} - val String = {name="S",to_string=(fn s => s),from_string=(fn s => s)} - end - - structure Form : SMLSERVER_FORM = Unsafe.Form - - structure Info : SMLSERVER_INFO = - struct - fun hostname() : string = - prim("nssml_InfoHostname", ()) - fun host() : string = - prim("nssml_ConnHost", getConn()) - fun port() : int = - prim("@Ns_ConnPort", getConn()) - fun pageRoot() : string = - prim("nssml_PageRoot", (getConn())) - fun location() : string = - let val res : string = prim("nssml_ConnLocation", getConn()) - in if isNull res then "" - else res - end - fun url () : string = - prim("nssml_ConnUrl", getConn()) - end - - structure Mail = - struct - fun sendmail {to: string list, cc: string list, bcc: string list, - from: string, subject: string, body: string, - extra_headers: string list} : unit = - let - fun sl2s sep [] = "" - | sl2s sep l = concat (tl (foldr (fn (s,acc)=>sep::s::acc) [] l)) - fun header s nil = "" - | header s l = s ^ ": " ^ sl2s "," l ^ "\n" - val mails = concat - ["From: ", from, "\n", - "To: ", sl2s "," to, "\n", - header "Cc" cc, - header "Bcc" bcc, (* stripped by sendmail before sending! *) - concat(map (fn s => s ^ "\n") extra_headers), - "Subject: ", subject, "\n\n", - body] - fun writeFile (filename, str) = - let val os = TextIO.openOut filename - in (TextIO.output (os, str); TextIO.closeOut os) - handle X => (TextIO.closeOut os; raise X) - end - val tmpf = FileSys.tmpName() - val cmd = "/usr/sbin/sendmail -t < " ^ tmpf - in (writeFile (tmpf, mails); - if OS.Process.system cmd = OS.Process.success then () - else raise Fail "") - handle X => - (FileSys.remove tmpf; - raise Fail ("Failed to send email from " ^ from ^ " using Ns.sendmail.")) - end - - fun send {to: string, from: string, subject: string, body: string} : unit = - sendmail {to=[to],from=from,cc=nil,bcc=nil,subject=subject, - extra_headers=nil,body=body} - end - - (* Calling Info.pageRoot requires that the execution knows of a - connection, which it does not if the execution is for an - init-script, executed at server start. *) - - val _ = if hasConnection() then OS.FileSys.chDir (Info.pageRoot()) - else () - - (* Creating the three supported database interfaces *) - structure DbOra = - SMLserverDbFunctor(structure DbBasic = SMLserverDbBasicOra - structure Exit = Exit) - - structure DbPg = - SMLserverDbFunctor(structure DbBasic = SMLserverDbBasicPG - structure Exit = Exit) - - structure DbMySQL : SMLSERVER_DB = - (* We redefine the stucture here because we need a db-handle to - simulate sequences in MySQL *) - struct - local - structure Db = - SMLserverDbFunctor(structure DbBasic = SMLserverDbBasicMySQL - structure Exit = Exit) - - in - open Db - (* seqNextval assumes a table simulating the sequence with one auto-increment field: - create table seqName ( - seqId integer primary key auto_increment - ); *) - fun seqNextval (seqName:string) : int = - let - val _ = Db.dml `insert into ^seqName (seqId) values (null)` - val s = Db.oneField `select max(seqId) from ^seqName` - in case Int.fromString s of - SOME i => i - | NONE => raise Fail "Db.seqNextval.nextval not an integer (MySQL)" - end - handle _ => raise Fail "Db.seqNextval.nextval database error (MySQL)" - - fun seqCurrval (seqName:string) : int = - let val s = oneField `select max(seqId) from ^seqName` - in case Int.fromString s of - SOME i => i - | NONE => raise Fail "Db.seqCurrval.nextval not an integer (MySQL)" - end - handle _ => raise Fail "Db.seqCurrval.nextval database error (MySQL)" - end - end - end - -structure Form = SMLserver.Form \ No newline at end of file diff --git a/smlserver/xt/libxt/SMLserverDbFunctor.sml b/smlserver/xt/libxt/SMLserverDbFunctor.sml deleted file mode 100644 index 346414026..000000000 --- a/smlserver/xt/libxt/SMLserverDbFunctor.sml +++ /dev/null @@ -1,459 +0,0 @@ -signature SMLSERVER_DB_BASIC = - sig - val seqNextvalExp : string -> string (*construct new-sequence expression*) - val seqCurrvalExp : string -> string (*construct last-used sequence expression*) - val fromDual : string - val sysdateExp : string - val beginTrans : quot - val endTrans : quot - val rollback : quot - val fromDate : Date.date -> string - val toTimestampExp: string -> string - val timestampType : string - end - -signature SMLSERVER_EXIT = - sig - type exitId - val atExit : (unit -> unit) -> exitId - val exitUnreg : exitId -> unit - end - -functor SMLserverDbFunctor (structure DbBasic : SMLSERVER_DB_BASIC - structure Exit : SMLSERVER_EXIT) - : SMLSERVER_DB = - struct - type ns_db = int - type set = NsSet.set - type status = NsBasics.status - type quot = string frag list - fun quotToString (q : quot) : string = - concat(map (fn QUOTE s => s | ANTIQUOTE s => s) q) - - structure Pool = - struct - type pool = string - type db = pool * ns_db * Exit.exitId - local - val pools : pool list ref = ref [] - in - fun initPools pns = pools := pns - fun putPool pn = pools := pn :: !pools - fun getPool () = - case !pools of - [] => raise Fail "getPool.no more pools" - | pn::ps => (pools := ps; pn) - fun toList () = !pools - fun pp () = - let - fun sl2s sep [] = "" - | sl2s sep l = concat (tl (foldr (fn (s,acc)=>sep::s::acc) [] l)) - in - sl2s "," (!pools) - end - end - - fun poolPutHandle0 (h : ns_db) : unit = - prim("@Ns_DbPoolPutHandle", h) - - fun poolGetHandle (pool : pool) : db = - let - val h : ns_db = prim("@Ns_DbPoolGetHandle", pool) - in - if h = 0 then raise Fail "poolGetHandle:Can't allocate handle" - else - let val exitId = Exit.atExit (fn() => poolPutHandle0 h) - in (pool,h,exitId) - end - end - - fun poolPutHandle (db : db) : unit = - ( Exit.exitUnreg (#3 db) - ; poolPutHandle0(#2 db)) - end - - type pool = Pool.pool - type db = Pool.db - - open DbBasic - - structure Handle : SMLSERVER_DB_HANDLE = - struct - structure Pool = Pool - type db = Pool.db - type set = NsSet.set - - fun getHandle () : db = Pool.poolGetHandle(Pool.getPool()) - - fun putHandle db : unit = (Pool.poolPutHandle db; Pool.putPool (#1 db)) - - val initPools = Pool.initPools - - fun wrapDb f = - let val db = getHandle() - in (f db before putHandle db) - handle X => (putHandle db; raise X) - end - - fun dmlDb (db : db) (q: quot) : unit = - let - val status = prim("@Ns_DbDML", (#2 db, quotToString q)) - in - if status = NsBasics.ERROR then - raise Fail ("dml: " ^ Quot.toString q ^ " failed") - else () - end - - fun execDb (db : db) (q: quot) : unit = - let - val status = prim("@Ns_DbExec", (#2 db, quotToString q)) - in - if status = NsBasics.ERROR then - raise Fail ("exec: " ^ Quot.toString q ^ " failed") - else () - end - - fun panicDmlDb (db:db) (f_panic: quot -> 'a) (q: quot) : unit = - (dmlDb db q handle X => (f_panic (q ^^ `^("\n") ^(General.exnMessage X)`); ())) - - fun dmlTransDb (db : db) (f : db -> 'a) : 'a = - let - val _ = dmlDb db DbBasic.beginTrans - val res = f db; - in - dmlDb db DbBasic.endTrans; - res - end handle X => (dmlDb db DbBasic.rollback; raise X) - - fun dmlTrans (f: db -> 'a) : 'a = - let - val db = getHandle() - in - let - val res = dmlTransDb db f - in - putHandle db; - res - end handle X => (putHandle db; raise X) - end - - fun panicDmlTransDb (db:db) (f_panic: quot -> 'a) (f: db -> 'a) : 'a = - dmlTransDb db f handle X => (f_panic(`^(General.exnMessage X)`)) - - fun panicDmlTrans (f_panic: quot -> 'a) (f: db -> 'a) : 'a = - dmlTrans f handle X => (f_panic(`^(General.exnMessage X)`)) - - fun selectDb (db: db, q: quot) : set = - let - fun isNull(s : set) : bool = prim("__is_null",s) - val res = prim("@Ns_DbSelect", (#2 db, quotToString q)) - in - if isNull res - then - let - val msg = "selectDb: SQL Error" - in - raise Fail msg - end - else res - end - - fun getRowDb (db : db, s : set) : status = - prim("@Ns_DbGetRow", (#2 db, s)) - - fun foldDb (db:db) (f:(string->string)*'a->'a) (acc:'a) (sql:quot) : 'a = - let - val s : set = selectDb(db, sql) - fun g n = NsSet.getOpt(s, n, "##") - fun loop (acc:'a) : 'a = - if (getRowDb(db,s) <> NsBasics.END_DATA) then loop (f(g,acc)) - else acc - in loop acc - end - - fun appDb (db:db) (f:(string->string)->'a) (sql:quot) : unit = - let - val s : set = selectDb(db, sql) - fun g n = NsSet.getOpt(s, n, "##") - fun loop () : unit = - if (getRowDb(db,s) <> NsBasics.END_DATA) then (f g; loop ()) - else () - in loop () - end - - fun listDb (db:db) (f:(string->string)->'a) (sql: quot) : 'a list = - let - val s : set = selectDb(db, sql) - fun g n = NsSet.getOpt(s, n, "##") - fun loop () : 'a list = - if (getRowDb(db,s) <> NsBasics.END_DATA) then f g :: loop() - else [] - in - loop () - end - - fun oneFieldDb db sql : string = - let - val s : set = selectDb(db, sql) - val res = - if getRowDb(db,s) <> NsBasics.END_DATA then - if NsSet.size s = 1 then - case NsSet.value(s,0) of - SOME s => s - | NONE => raise Fail "Db.oneFieldDb.no value in set" - else raise Fail "Db.oneFieldDb.size of set not one" - else raise Fail "Db.oneFieldDb.no rows" - in - if getRowDb(db,s) = NsBasics.END_DATA then res - else raise Fail "oneFieldDb.more than one row" - end - - fun zeroOrOneFieldDb db sql : string option = - let - val s : set = selectDb(db, sql) - in - if getRowDb(db,s) <> NsBasics.END_DATA then - let - val res = - if NsSet.size s = 1 then - NsSet.value(s,0) - else raise Fail "zeroOrOneFieldDb.size of set is not one" - in - if getRowDb(db,s) = NsBasics.END_DATA then - res - else raise Fail "zeroOrOneFieldDb.more than one row" - end - else NONE (* OK, no rows *) - end - - fun oneRowDb db sql : string list = - let - val s : set = selectDb(db, sql) - val res = - if getRowDb(db,s) <> NsBasics.END_DATA then - NsSet.foldr (fn ((k,v), a) => v :: a) nil s - else raise Fail "Db.oneRowDb.no rows" - in - if getRowDb(db,s) = NsBasics.END_DATA then - res - else raise Fail "oneRowDb.more that one row" - end - - fun oneRowDb' db (f:(string->string)->'a) (sql:quot) : 'a = - let - val s : set = selectDb(db, sql) - fun g n = NsSet.getOpt(s, n, "##") - val res = - if getRowDb(db,s) <> NsBasics.END_DATA then - f g - else raise Fail "Db.oneRowDb'.no rows" - in - if getRowDb(db,s) = NsBasics.END_DATA then - res - else raise Fail "oneRowDb'.more that one row" - end - - fun zeroOrOneRowDb db sql : string list option = - let - val s : set = selectDb(db, sql) - in - if getRowDb(db,s) <> NsBasics.END_DATA then - let - val res = SOME (NsSet.foldr (fn ((k,v), a) => v :: a) nil s) - in - if getRowDb(db,s) = NsBasics.END_DATA then - res - else raise Fail "zeroOrOneRowDb.more than one row" - end - else NONE (* Ok, no rows *) - end - - fun zeroOrOneRowDb' db f sql : 'a option = - let - val s : set = selectDb(db, sql) - fun g n = NsSet.getOpt(s, n, "##") - in - if getRowDb(db,s) <> NsBasics.END_DATA then - let - val res = SOME (f g) - in - if getRowDb(db,s) = NsBasics.END_DATA then - res - else raise Fail "zeroOrOneRowDb'.more than one row" - end - else NONE (* Ok, no rows *) - end - - fun existsOneRowDb db sql : bool = - let val s : set = selectDb(db, sql) - in if getRowDb(db,s) <> NsBasics.END_DATA then true - else false - end - - fun seqNextvalDb db (seqName:string) : int = - let val s = oneFieldDb db `select ^(seqNextvalExp seqName) ^fromDual` - in case Int.fromString s of - SOME i => i - | NONE => raise Fail "Db.seqNextval.nextval not an integer" - end - - fun seqCurrvalDb db (seqName:string) : int = - let val s = oneFieldDb db `select ^(seqCurrvalExp seqName) ^fromDual` - in case Int.fromString s of - SOME i => i - | NONE => raise Fail "Db.seqCurrval.nextval not an integer" - end - - (* Stored Procedures *) - fun execSpDb (db: db) ([]: quot list) : unit = () - | execSpDb (db: db) (qs: quot list) : unit = - let - val body = Quot.concatWith ";\n" qs - in - dmlDb db (`declare begin ` ^^ body ^^ `; end;`) - end - end (* structure Handle *) - - fun dml (q: quot) : unit = Handle.wrapDb (fn db => Handle.dmlDb db q) - fun exec (q: quot) : unit = Handle.wrapDb (fn db => Handle.execDb db q) - - fun maybeDml (q: quot) : unit = dml q handle X => () - - fun panicDml (f_panic: quot -> 'a) (q: quot) : unit = - dml q handle X => (f_panic (q ^^ `^("\n") ^(General.exnMessage X)`); ()) - - (* Stored Procedures *) - fun execSp qs : unit = Handle.wrapDb (fn db => Handle.execSpDb db qs) - - fun fold (f:(string->string)*'a->'a) (acc:'a) (sql:quot) : 'a = - Handle.wrapDb (fn db => Handle.foldDb db f acc sql) - - fun app (f:(string->string)->'a) (sql:quot) : unit = - Handle.wrapDb (fn db => Handle.appDb db f sql) - - fun list (f:(string->string)->'a) (sql:quot) : 'a list = - Handle.wrapDb (fn db => Handle.listDb db f sql) - - fun oneField (sql : quot) : string = - Handle.wrapDb (fn db => Handle.oneFieldDb db sql) - - fun zeroOrOneField (sql : quot) : string option = - Handle.wrapDb (fn db => Handle.zeroOrOneFieldDb db sql) - - fun oneRow sql : string list = - Handle.wrapDb (fn db => Handle.oneRowDb db sql) - - fun oneRow' (f:(string->string)->'a) (sql:quot) : 'a = - Handle.wrapDb (fn db => Handle.oneRowDb' db f sql) - - fun zeroOrOneRow sql : string list option = - Handle.wrapDb (fn db => Handle.zeroOrOneRowDb db sql) - - fun zeroOrOneRow' (f:(string->string)->'a) (sql:quot) : 'a option = - Handle.wrapDb (fn db => Handle.zeroOrOneRowDb' db f sql) - - fun existsOneRow sql : bool = - Handle.wrapDb (fn db => Handle.existsOneRowDb db sql) - - fun qq s = - let - fun qq_s' [] = [] - | qq_s' (x::xs) = if x = #"'" then x :: x :: (qq_s' xs) else x :: (qq_s' xs) - in - implode(qq_s'(explode s)) - end - - fun qqq s = concat ["'", qq s, "'"] - - local - fun mthToName mth = - case mth of - 1 => Date.Jan - | 2 => Date.Feb - | 3 => Date.Mar - | 4 => Date.Apr - | 5 => Date.May - | 6 => Date.Jun - | 7 => Date.Jul - | 8 => Date.Aug - | 9 => Date.Sep - | 10 => Date.Oct - | 11 => Date.Nov - | 12 => Date.Dec - | _ => raise Fail ("DbFunctor.toDate: " ^ (Int.toString mth)) - in - fun toDate s = - (case (RegExp.extract o RegExp.fromString) "([0-9][0-9][0-9][0-9])-([0-9][0-9])-([0-9][0-9]).*" s of - SOME [yyyy,mm,dd] => SOME (Date.date{year=Option.valOf (Int.fromString yyyy), - month=mthToName (Option.valOf (Int.fromString mm)), - day=Option.valOf (Int.fromString dd), - hour=0,minute=0,second=0,offset=NONE}) - | _ => NONE) - handle _ => NONE - - fun toTimestamp t = - (case (RegExp.extract o RegExp.fromString) "([0-9][0-9][0-9][0-9])-([0-9][0-9])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]).*" t of - SOME [yyyy,mm,dd,h,m,s] => SOME (Date.date{year=Option.valOf (Int.fromString yyyy), - month=mthToName (Option.valOf (Int.fromString mm)), - day=Option.valOf (Int.fromString dd), - hour=Option.valOf(Int.fromString h), - minute=Option.valOf(Int.fromString m), - second=Option.valOf(Int.fromString s), - offset=NONE}) - | _ => NONE) - handle _ => NONE - end - - - fun valueList vs = String.concatWith "," (List.map qqq vs) - fun setList vs = String.concatWith "," (List.map (fn (n,v) => n ^ "=" ^ qqq v) vs) - - fun seqNextval (seqName:string) : int = - Handle.wrapDb (fn db => Handle.seqNextvalDb db seqName) - - fun seqCurrval (seqName:string) : int = - Handle.wrapDb (fn db => Handle.seqCurrvalDb db seqName) - end - -structure SMLserverDbBasicOra : SMLSERVER_DB_BASIC = - struct - fun seqNextvalExp seq_name = seq_name ^ ".nextval" - fun seqCurrvalExp seq_name = seq_name ^ ".currval" - val fromDual = "from dual" - val sysdateExp = "sysdate" - val beginTrans = `begin transaction` - val endTrans = `end transaction` - val rollback = `rollback` - fun fromDate d = "to_date('" ^ (Date.fmt "%Y-%m-%d %H:%M:%S" d) ^ "','YYYY-MM-DD HH24:MI:SS')" - fun toTimestampExp d = "to_char(" ^ d ^ ",'YYYY-MM-DD HH24:MI:SS')" - val timestampType = "date" - end - -structure SMLserverDbBasicPG : SMLSERVER_DB_BASIC = - struct - fun seqNextvalExp seq_name = "nextval('" ^ seq_name ^ "')" - fun seqCurrvalExp seq_name = "currval('" ^ seq_name ^ "')" - val fromDual = "" - val sysdateExp = "now()" - val beginTrans = `begin` - val endTrans = `commit` - val rollback = `rollback` - fun fromDate d = "'" ^ (Date.fmt "%Y-%m-%d %H:%M:%S" d) ^ "'" - fun toTimestampExp d = "to_char(" ^ d ^ ",'YYYY-MM-DD HH24:MI:SS')" - val timestampType = "datetime" - end - -structure SMLserverDbBasicMySQL : SMLSERVER_DB_BASIC = - struct - fun seqNextvalExp seq_name = "null" - fun seqCurrvalExp seq_name = raise Fail "seqCurrvalExp not supported on MySQL" - val fromDual = "" - val sysdateExp = "now()" - val beginTrans = `begin` - val endTrans = `commit` - val rollback = `rollback` - fun fromDate d = "'" ^ (Date.fmt "%Y-%m-%d %H:%M:%S" d) ^ "'" - fun toTimestampExp d = d (*"to_char(" ^ d ^ ",'YYYY-MM-DD HH24:MI:SS')"*) - val timestampType = "datetime" - end - diff --git a/smlserver/xt/libxt/SMLserverForm.sml b/smlserver/xt/libxt/SMLserverForm.sml deleted file mode 100644 index 41cc38021..000000000 --- a/smlserver/xt/libxt/SMLserverForm.sml +++ /dev/null @@ -1,47 +0,0 @@ -(* Typed representable objects that may be passed as form - * variables. *) - -structure SMLserverFormUnsafe : SMLSERVER_FORM_UNSAFE = - struct - datatype 't var = BASE of string * (string -> 't option) - | LIST of string list * (string list -> 't option) - | OPTION of string option * (string option -> 't option) - | MISSING - type 't Type = 't -> 't var - fun Int i = BASE (Int.toString i, Int.fromString) - fun String s = BASE (s, fn x => SOME x) - fun Bool b = BASE (Bool.toString b, Bool.fromString) - - datatype 't arg = Ok of 't | Wrong | Missing - fun wrapOk f v = - (case f v of - SOME v => Ok v - | NONE => Wrong) - handle _ => Missing - fun get (BASE(v,f)) = wrapOk f v - | get (LIST(v,f)) = wrapOk f v - | get (OPTION(v,f)) = wrapOk f v - | get (MISSING) = Missing - - fun toString (BASE(v,f)) = v - | toString _ = raise Fail "Form.toString not implemented for non-base objects" - fun fromInt s = BASE (s, Int.fromString) - fun fromString s = BASE (s, fn x => SOME x) - fun fromBool s = BASE (s, Bool.fromString) - fun fromList (f: string -> 'a var) (ss: string list) : 'a list var = - LIST (ss, - foldr (fn (s,NONE) => NONE - | (s,SOME xs) => (case get(f s) of - Ok x => SOME (x::xs) - | _ => NONE)) (SOME nil)) - - fun fromOption (f: string -> 'a var) (so: string option) : 'a option var = - OPTION (so, - fn so => - SOME(case so of - SOME s => (case get (f s) of - Ok x => SOME x - | _ => NONE) - | NONE => NONE)) - fun missing() = MISSING - end diff --git a/smlserver/xt/libxt/SMLserverUnsafe.sml b/smlserver/xt/libxt/SMLserverUnsafe.sml deleted file mode 100644 index 55d6ea27c..000000000 --- a/smlserver/xt/libxt/SMLserverUnsafe.sml +++ /dev/null @@ -1,70 +0,0 @@ -structure SMLserverUnsafe : SMLSERVER_UNSAFE = - struct - open NsBasics - - exception MissingConnection - type conn = int - - local - fun getConn0 () : conn = - prim("@Ns_TclGetConn", (0:int)) - type LogSeverity = int - val Notice=0 and Warning=1 and Error=2 and Fatal=3 - and Bug=4 and Debug=5 - fun log' (ls: LogSeverity, s: string) : unit = - prim("@Ns_Log", (ls, s)) - fun log s = log' (Notice, s) - in - fun getConn() : conn = - let val c = getConn0() - in if c = 0 then - (log "SMLserverUnsafe: missing connection"; - raise MissingConnection) - else c - end - end - - fun write(s: string) : status = - prim("@Ns_ConnPuts", (getConn(), s)) - - fun returnFileMime (mimetype:string) (file:string) : status = - prim("nssml_returnFile", (getConn(),mimetype,file)) - - fun mimeType(s: string) : string = - prim("nssml_GetMimeType", s) - - fun returnFile (file:string):status = - returnFileMime (mimeType file) file - - local - fun getQuery() : NsSet.set option = - let val s : NsSet.set = prim("@Ns_ConnGetQuery", getConn()) - in if s = 0 then NONE - else SOME s - end - in - fun formvar s = - case getQuery() of - SOME set => NsSet.get(set,s) - | NONE => NONE - fun formvarAll s = - case getQuery() of - SOME set => NsSet.getAll(set,s) - | NONE => [] - end - - fun registerTrap (u:string) : unit = - prim("nssml_registerTrap", u) - - fun scheduleScript (f: string) (i:int) : unit = - prim("nssml_scheduleScript", (f,i)) - - fun scheduleDaily (f:string) {hour:int,minute:int} : unit = - prim("nssml_scheduleDaily", (f,hour,minute)) - - fun scheduleWeekly (f:string) {day:int,hour:int,minute:int} : unit = - prim("nssml_scheduleWeekly", (f,day,hour,minute)) - - structure Form = SMLserverFormUnsafe - end - diff --git a/smlserver/xt/libxt/XHTML.sig b/smlserver/xt/libxt/XHTML.sig deleted file mode 100644 index 2ed436f7b..000000000 --- a/smlserver/xt/libxt/XHTML.sig +++ /dev/null @@ -1,281 +0,0 @@ -(* - * Copyright (c) 2003, 2004, Martin Elsman. License: GPL - * - * SMLserver interface for XHTML 1.0 that statically guarantees (1) - * validity of constructed documents and (2) consistent and - * typed use of forms. - *) - -signature XHTML = - sig - structure A : XHTML_ATTR (* Attributes *) - type na = A.na - - (* In XHTML 1.0, pre elements may not contain big, small, sup, - or sub elements. This restriction is modelled using a phantom - type parameter 'p in the type for elements and requires the - abandonned elements to appear in contexts where 'p is - instantiated to preclosed. The type of the pre-element - constructor restricts arguments to have 'p instantiated to - inpre. *) - - type inpre - type preclosed - - (* In XHTML, a elements may not contain other a elements. *) - type ina - type aclosed - - (* In XHTML, form elements may not contain other form elements. *) - type inform - type formclosed - - (* The XHTML DTD distinguishes between block, inline, and flow - elements (block or inline). This distinction is modelled - using a phantom type parameter 'k as follows: - - element type ML type description - block flow(block,NOT) flow-elements not containing inline elements - inline flow(NOT,inline) flow-elements not containing block elements - flow flow(block,inline) combined flow-elements - - Parts of the partial order: - - li dl td tr (NOT,inline)flow (block,inline)flow (block,NOT)flow - \ \ \ | | / \ / - \ | | | ('a,inline)flow -' (block,'i)flow - \| | / ___/-------------------------------/ - 'kind - *) - - type ('b,'i) flow and block and inline and NOT (* 'a flow, inline flow, and block flow *) - type li and dl and td and tr - - type nil - type ('n,'t) fname - type 'a rad - type 'a var = 'a Form.var - - (* Standard elements *) - type ('x,'y,'a,'f,'p,'k) elt - - type ('x,'y,'a,'f,'p,'b) inl2inl = - ('x,'y,'a,'f,'p,(NOT,inline)flow) elt -> ('x,'y,'a,'f,'p,('b,inline)flow) elt - - type ('x,'y,'a,'f,'p,'b) inl2inlpre = - ('x,'y,'a,'f,'p,(NOT,inline)flow) elt -> ('x,'y,'a,'f,preclosed,('b,inline)flow) elt - - type ('x,'y,'a,'f,'p,'i) inl2blk = - ('x,'y,'a,'f,'p,(NOT,inline)flow) elt -> ('x,'y,'a,'f,'p,(block,'i)flow) elt - - val em : ('x,'y,'a,'f,'p,'b) inl2inl (* emphasis *) - val strong : ('x,'y,'a,'f,'p,'b) inl2inl (* strong emphasis *) - val dfn : ('x,'y,'a,'f,'p,'b) inl2inl (* definitional *) - val code : ('x,'y,'a,'f,'p,'b) inl2inl (* program code *) - val samp : ('x,'y,'a,'f,'p,'b) inl2inl (* sample *) - val kbd : ('x,'y,'a,'f,'p,'b) inl2inl (* user input *) - val var : ('x,'y,'a,'f,'p,'b) inl2inl (* variable *) - val cite : ('x,'y,'a,'f,'p,'b) inl2inl (* citation *) - val abbr : string -> ('x,'y,'a,'f,'p,'b) inl2inl (* abbreviation *) - val acronym : ('x,'y,'a,'f,'p,'b) inl2inl (* acronym *) - val sub : ('x,'y,'a,'f,'p,'b) inl2inlpre (* subscript *) - val sup : ('x,'y,'a,'f,'p,'b) inl2inlpre (* superscript *) - val tt : ('x,'y,'a,'f,'p,'b) inl2inl (* fixed pitch *) - val i : ('x,'y,'a,'f,'p,'b) inl2inl (* italic *) - val b : ('x,'y,'a,'f,'p,'b) inl2inl (* bold *) - val big : ('x,'y,'a,'f,'p,'b) inl2inlpre (* bigger *) - val small : ('x,'y,'a,'f,'p,'b) inl2inlpre (* smaller *) - - val $ : string -> ('x,'x,'a,'f,'p,('b,inline)flow) elt - val br : unit -> ('x,'x,'a,'f,'p,('b,inline)flow) elt - - val p : ('x,'y,'a,'f,'p,'i) inl2blk - val h1 : ('x,'y,'a,'f,'p,'i) inl2blk (* most important *) - val h2 : ('x,'y,'a,'f,'p,'i) inl2blk - val h3 : ('x,'y,'a,'f,'p,'i) inl2blk - val h4 : ('x,'y,'a,'f,'p,'i) inl2blk - val h5 : ('x,'y,'a,'f,'p,'i) inl2blk - val h6 : ('x,'y,'a,'f,'p,'i) inl2blk (* least important *) - - val div : ('x,'y,'a,'f,'p,(block,inline)flow) elt - -> ('x,'y,'a,'f,'p,(block,'i)flow) elt - - val address : ('x,'y,'a,'f,'p,'i) inl2blk - val blockquote : ('x,'y,'a,'f,'p,(block,NOT)flow) elt - -> ('x,'y,'a,'f,'p,(block,'i)flow) elt - val pre : ('x,'y,'a,'f,inpre,(NOT,inline)flow) elt (* disallow big, small, *) - -> ('x,'y,'a,'f,preclosed,(block,'i)flow) elt (* sub, sup, and img. *) - - val hr : unit -> ('x,'x,'a,'f,'p,(block,'i)flow) elt - - val & : ('x,'y,'a,'f,'p,'k) elt * ('y,'z,'a,'f,'p,'k) elt - -> ('x,'z,'a,'f,'p,'k) elt - - val flatten : ('x,'y,'a,'f,'p,'k) elt * ('y,'y,'a,'f,'p,'k) elt list - -> ('x,'y,'a,'f,'p,'k) elt - - (* Lists *) - val li : ('x,'y,'a,'f,'p,(block,inline)flow) elt -> ('x,'y,'a,'f,'p,li) elt - val dt : ('x,'y,'a,'f,'p,(NOT,inline)flow) elt -> ('x,'y,'a,'f,'p,dl) elt - val dd : ('x,'y,'a,'f,'p,(block,inline)flow) elt -> ('x,'y,'a,'f,'p,dl) elt - val ol : ('x,'y,'a,'f,'p,li) elt -> ('x,'y,'a,'f,'p,(block,'i)flow) elt - val ul : ('x,'y,'a,'f,'p,li) elt -> ('x,'y,'a,'f,'p,(block,'i)flow) elt - val dl : ('x,'y,'a,'f,'p,dl) elt -> ('x,'y,'a,'f,'p,(block,'i)flow) elt - - (* Images *) - val img : {src:string,alt:string} -> ('x,'x,'a,'f,preclosed,('b,inline)flow) elt - val imga : ('aa, 'bb, A.width,'c, A.height,'d, na,na, - na,na, na,na, na,na) A.attr - -> {src:string, alt:string} -> ('x,'x,'a,'f,preclosed,('b,inline)flow) elt - - (* Tables *) - val td : ('x,'y,'a,'f,'p,(block,inline)flow) elt -> ('x,'y,'a,'f,'p,td) elt - val tda : ('aa, 'b, A.align,'c, A.valign,'d, A.rowspan,'e, - A.colspan,'ff, na,na, na,na) A.attr - -> ('x,'y,'a,'f,'p,(block,inline)flow) elt -> ('x,'y,'a,'f,'p,td) elt - - val th : ('x,'y,'a,'f,'p,(block,inline)flow) elt -> ('x,'y,'a,'f,'p,td) elt - val tha : ('aa, 'b, A.align,'c, A.valign,'d, A.rowspan,'e, - A.colspan,'ff, na,na, na,na) A.attr - -> ('x,'y,'a,'f,'p,(block,inline)flow) elt -> ('x,'y,'a,'f,'p,td) elt - - val tr : ('x,'y,'a,'f,'p,td) elt -> ('x,'y,'a,'f,'p,tr) elt - val tra : ('aa, 'b, A.align,'c, A.valign,'d, na,na, na,na, - na,na, na,na) A.attr -> ('x,'y,'a,'f,'p,td) elt - -> ('x,'y,'a,'f,'p,tr) elt - - val table : ('x,'y,'a,'f,'p,tr) elt -> ('x,'y,'a,'f,'p,(block,'i)flow) elt - val tablea : ('aa, 'b, A.width,'c, A.border,'d, A.cellspacing,'e, - A.cellpadding,'ff, A.frame,'g, A.rules,'h) A.attr - -> ('x,'y,'a,'f,'p,tr) elt -> ('x,'y,'a,'f,'p,(block,'i)flow) elt - - (* Forms *) - type ('x,'y,'a,'p,'k) felt = ('x,'y,'a,inform,'p,'k) elt - type ('x,'a,'p,'k) form = ('x,nil,'a,'p,'k) felt - - (* Functionality for swapping the front name in a name list - * with another name in the list. *) - type ('old,'new) num - val One : unit -> ('n1->'n2->'x,'n2->'n1->'x) num - val Succ : ('n1->'x,'n2->'y) num -> ('n1->'n->'x,'n2->'n->'y) num - val swap : ('x,'xx) num -> ('x,'y,'a,'p,'k) felt - -> ('xx,'y,'a,'p,'k) felt - - (* Input elements *) - val inputText : ('n,'t)fname -> 't var option -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - val inputTexta : ('a1, 'a2, na,na, A.disabled,'a3, A.readonly,'a4, - A.size,'a5, na,na, na,na) A.attr - -> ('n,'t)fname -> 't var option -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - - val inputPassword : ('n,'t)fname -> 't var option -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - val inputPassworda : ('a1, 'a2, na,na, A.disabled,'a3, A.readonly,'a4, - A.size,'a5, na,na, na,na) A.attr - -> ('n,'t)fname -> 't var option -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - - val inputRadio : ('n,'t option)fname -> 't var -> ('n rad->'x,'x,'a,'p,('b,inline)flow) felt - val inputRadioa : ('a1, 'a2, A.checked,'a3, A.disabled,'a4, A.readonly,'a5, - na,na, na,na, na,na)A.attr - -> ('n,'t option)fname -> 't var -> ('n rad->'x,'x,'a,'p,('b,inline)flow) felt - - val inputRadio' : ('n,'t option)fname -> 't var -> ('n rad->'x,'n rad->'x,'a,'p,('b,inline)flow) felt - val inputRadioa' : ('a1, 'a2, A.checked,'a3, A.disabled,'a4, A.readonly,'a5, - na,na, na,na, na,na)A.attr - -> ('n,'t option)fname -> 't var -> ('n rad->'x,'n rad->'x,'a,'p,('b,inline)flow) felt - - val radioDrop : ('n rad->'x,'y,'a,'p,'k) felt -> ('n->'x,'y,'a,'p,'k) felt - - type 'a checkbox - - val inputCheckbox : ('n,'t list)fname -> 't var -> ('n checkbox->'x,'x,'a,'p,('b,inline)flow) felt - val inputCheckboxa : ('a1, 'a2, A.checked,'a3, A.disabled,'a4, A.readonly,'a5, - na,na, na,na, na,na)A.attr - -> ('n,'t list)fname -> 't var -> ('n checkbox->'x,'x,'a,'p,('b,inline)flow) felt - - val inputCheckbox' : ('n,'t list)fname -> 't var - -> ('n checkbox->'x,'n checkbox->'x,'a,'p,('b,inline)flow) felt - val inputCheckboxa': ('a1, 'a2, A.checked,'a3, A.disabled,'a4, A.readonly,'a5, - na,na, na,na, na,na)A.attr - -> ('n,'t list)fname -> 't var - -> ('n checkbox->'x,'n checkbox->'x,'a,'p,('b,inline)flow) felt - - val checkboxDrop : ('n checkbox->'x,'y,'a,'p,'k) felt -> ('n->'x,'y,'a,'p,'k) felt - - val inputHidden : ('n,'t)fname -> 't var -> ('n->'x,'x,'a,'p,('b,inline) flow) felt - val inputHiddena : ('a1,'a2,na,na,na,na,na,na,na,na,na,na,na,na) A.attr - -> ('n,'t)fname -> 't var -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - - val inputSubmit : string -> ('x,'x,'a,'p,('b,inline)flow) felt - val inputSubmita : ('a1, 'a2, na,na, A.disabled,'a3, A.readonly,'a4, - na,na, na,na, na,na)A.attr - -> string -> ('x,'x,'a,'p,('b,inline)flow) felt - - val inputReset : string -> ('x,'x,'a,'p,('b,inline)flow) felt - val inputReseta : ('a1, 'a2, na,na, A.disabled,'a3, A.readonly,'a4, - na,na, na,na, na,na)A.attr - -> string -> ('x,'x,'a,'p,('b,inline)flow) felt - - val textarea : ('n,'t)fname -> {rows:int,cols:int} -> 't var option - -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - val textareaa : ('a1, 'a2, na,na, A.disabled,'a3, A.readonly,'a4, - na,na, na,na, na,na)A.attr - -> ('n,'t)fname -> {rows:int,cols:int} -> 't var option - -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - - type 't select_option = {text: string, value: 't var, - selected: bool, disabled: bool} - - val option : string * 't var -> 't select_option - - val select : ('n,'t)fname -> 't select_option list - -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - val selecta : ('a1, 'a2, na,na, A.disabled,'a3, na,na, - A.size,'a4, na,na, na,na)A.attr - -> ('n,'t)fname -> 't select_option list - -> ('n->'x,'x,'a,'p,('b,inline)flow) felt - - (* Validate link *) - val validLink : unit -> ('x,'x,'a,'f,'p,('b,inline)flow) elt - - (* Head elements *) - type helt - val script : {typ:string} -> string -> helt - val style : {typ:string} -> string -> helt - val meta : {content:string} -> helt - val link : {typ:string,rel:string,href:string} -> helt - - type head - val head : string * helt list -> head - - (* HTML documents *) - type body - val body : (nil,nil,aclosed,formclosed,preclosed,(block,NOT)flow) elt -> body - type html - val html : head * body -> html - - val % : ('a1,'a2, 'b1,'b2, 'c,'c1,'c2, 'd,'d1,'d2, - 'e,'e1,'e2, 'f,'f1,'f2, 'g,'g1,'g2, 'h,'h1,'h2) A.attr0 * - ('a2,'a3, 'b2,'b3, 'c,'c2,'c3, 'd,'d2,'d3, - 'e,'e2,'e3, 'f,'f2,'f3, 'g,'g2,'g3, 'h,'h2,'h3) A.attr0 -> - ('a1,'a3, 'b1,'b3, 'c,'c1,'c3, 'd,'d1,'d3, - 'e,'e1,'e3, 'f,'f1,'f3, 'g,'g1,'g3, 'h,'h1,'h3) A.attr0 - end - -signature XHTML_EXTRA = - sig - include XHTML - structure Unsafe : - sig - val form : {action:string, method:string} - -> ('x,'a,'p,(block,NOT)flow)form - -> (nil,nil,'a,formclosed,'p,(block,'i)flow) elt - - val ahref : {src:string} - -> ('x,'y,ina,'f,'p,(NOT,inline)flow)elt - -> ('x,'y,aclosed,'f,'p,('b,inline)flow)elt - - val toString : html -> string - val urlencode : string -> string - val htmlencode : string -> string - end - end - diff --git a/smlserver/xt/libxt/XHTML_ATTR.sml b/smlserver/xt/libxt/XHTML_ATTR.sml deleted file mode 100644 index 919efeeb0..000000000 --- a/smlserver/xt/libxt/XHTML_ATTR.sml +++ /dev/null @@ -1,185 +0,0 @@ - -signature XHTML_ATTR = - sig - - (* The first two type parameter pairs are reserved for id and - style attributes, thus no ``attribute identification - variables'' ('a and 'b) are used for these. *) - - type ('a1,'a2, 'b1,'b2, 'c,'c1,'c2, 'd,'d1,'d2, - 'e,'e1,'e2, 'f,'f1,'f2, 'g,'g1,'g2, 'h,'h1,'h2) attr0 - - (* Type representing absence of attribute *) - type na - - type ('a2, 'b2, 'c,'c2, 'd,'d2, 'e,'e2, 'f,'f2, - 'g,'g2, 'h,'h2) attr = - (na,'a2, na,'b2, 'c,na,'c2, 'd,na,'d2, - 'e,na,'e2, 'f,na,'f2, 'g,na,'g2, 'h,na,'h2) attr0 - - (* Concatenation of attributes *) - val % : ('a1,'a2, 'b1,'b2, 'c,'c1,'c2, 'd,'d1,'d2, - 'e,'e1,'e2, 'f,'f1,'f2, 'g,'g1,'g2, 'h,'h1,'h2) attr0 * - ('a2,'a3, 'b2,'b3, 'c,'c2,'c3, 'd,'d2,'d3, - 'e,'e2,'e3, 'f,'f2,'f3, 'g,'g2,'g3, 'h,'h2,'h3) attr0 -> - ('a1,'a3, 'b1,'b3, 'c,'c1,'c3, 'd,'d1,'d3, - 'e,'e1,'e3, 'f,'f1,'f3, 'g,'g1,'g3, 'h,'h1,'h3) attr0 - - (* Id *) - type id - val id : string -> (na,id, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, 'e0,'e,'e, - 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Style *) - type style - val style : string -> ('a,'a, na,style, 'c0,'c,'c, 'd0,'d,'d, 'e0,'e,'e, - 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Alignment *) - type align - val left : align - val center : align - val right : align - val justify : align - val char : Char.char -> align - val align : align -> ('a,'a, 'b,'b, align,na,align, 'd0,'d,'d, - 'e0,'e,'e, 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Vertical alignment *) - type valign - val top : valign - val middle : valign - val bottom : valign - val baseline : valign - val valign : valign -> ('a,'a, 'b,'b, 'c0,'c,'c, valign,na,valign, - 'e0,'e,'e, 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Lengths *) - type len - val pct : int -> len - val px : int -> len - - (* Width attribute and height *) - type width - val width : len -> ('a,'a, 'b,'b, width,na,width, 'd0,'d,'d, - 'e0,'e,'e, 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - type height - val height : len -> ('a,'a, 'b,'b, 'c0,'c,'c, height,na,height, - 'e0,'e,'e, 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Checked attribute *) - type checked - val checked : unit -> ('a,'a, 'b,'b, checked,na,checked, 'd0,'d,'d, - 'e0,'e,'e, 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Disabled attribute *) - type disabled - val disabled : unit -> ('a,'a, 'b,'b, 'c0,'c,'c, disabled,na,disabled, - 'e0,'e,'e, 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Readonly attribute *) - type readonly - val readonly : unit -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, - readonly,na,readonly, 'f0,'f,'f, 'g0,'g,'g, - 'h0,'h,'h) attr0 - - (* Size attribute *) - type size - val size : int -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, 'e0,'e,'e, - size,na,size, 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Selected attribute *) - type selected - val selected : unit -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, - selected,na,selected, 'f0,'f,'f, - 'g0,'g,'g, 'h0,'h,'h) attr0 - - (* Tables *) - type border - val border : int -> ('a,'a, 'b,'b, 'c0,'c,'c, border,na,border, - 'e0,'e,'e, 'f0,'f,'f, 'g0,'g,'g, 'h0,'h,'h) attr0 - - type cellspacing - val cellspacing : int -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, - cellspacing,na,cellspacing, 'f0,'f,'f, - 'g0,'g,'g, 'h0,'h,'h) attr0 - - type cellpadding - val cellpadding : int -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, 'e0,'e,'e, - cellpadding,na,cellpadding, 'g0,'g,'g, 'h0,'h,'h) attr0 - - type frame - val void : frame - val above : frame - val below : frame - val hsides : frame - val lhs : frame - val rhs : frame - val vsides : frame - val box : frame - val fborder : frame - val frame : frame -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, 'e0,'e,'e, - 'f0,'f,'f, frame,na,frame, 'h0,'h,'h) attr0 - - type rules - val none : rules - val groups : rules - val rows : rules - val cols : rules - val all : rules - val rules : rules -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, 'e0,'e,'e, - 'f0,'f,'f, 'g0,'g,'g, rules,na,rules) attr0 - - (* Table content *) - type rowspan - val rowspan : int -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, - rowspan,na,rowspan, 'f0,'f,'f, 'g0,'g,'g, - 'h0,'h,'h) attr0 - - type colspan - val colspan : int -> ('a,'a, 'b,'b, 'c0,'c,'c, 'd0,'d,'d, 'e0,'e,'e, - colspan,na,colspan, 'g0,'g,'g, 'h0,'h,'h) attr0 - end - -(* Supported attributes: -all: -a id ID -b style CDATA - -tr, th, td: -c align left|center|right|justify|char -d valign top|middle|bottom|baseline - -img, table: -c width %Length - -img: -d height %Length - -input: -c checked checked - -input,select,option,textarea: -d disabled disabled - -input,textarea: -e readonly readonly - -input,select: -f size %Number - -option: -e selected selected - -table: -d border %Pixels -e cellspacing %Length -f cellpadding %Length -g frame void|above|below|hsides|lhs|rhs|vsides|box|border -h rules none|groups|rows|cols|all - -th,td: -e rowspan %Number -f colspan %Number -*) diff --git a/smlserver/xt/libxt/XHtml.sml b/smlserver/xt/libxt/XHtml.sml deleted file mode 100644 index 1f42f67e1..000000000 --- a/smlserver/xt/libxt/XHtml.sml +++ /dev/null @@ -1,300 +0,0 @@ -(* - * Copyright (c) 2003, Martin Elsman; License: GPL - * - * SMLserver interface for XHtml that statically guarantees (1) - * validity of constructed documents and (2) consistent and - * typed use of forms. - *) - -structure XHtmlHidden__ : XHTML_EXTRA = - struct - structure A : XHTML_ATTR = XHtmlAttr - - type na = A.na - - fun html p = p - - type inform = unit - type formclosed = unit - type preclosed = unit - type inpre = unit - type aclosed = unit - type ina = unit - - type li = unit (* list kinds *) - type dl = unit - type td = unit - type tr = unit - type ('b,'i) flow = unit - and block = unit - and inline = unit - and NOT = unit - - fun htmlencode s : string = - let fun enc #"<" = "<" - | enc #">" = ">" - | enc #"&" = "&" - | enc #"\"" = """ - | enc c = String.str c - in String.translate enc s - end - - fun quotencode s : string = - let fun enc #"\"" = """ - | enc c = String.str c - in String.translate enc s - end - - fun attr t s = [t ^ "=\"" ^ s ^ "\""] - - datatype elem = - txt of string - | elem0 of string * string list - | elem1 of string * string list * elem - | seq of elem * elem - - type ('x,'y,'a,'f,'p,'k) elt = elem - type ('x,'y,'a,'f,'p,'b) inl2inl = elem -> elem - type ('x,'y,'a,'f,'p,'b) inl2inlpre = elem -> elem - type ('x,'y,'a,'f,'p,'i) inl2blk = elem -> elem - - type body = elem - - fun p e = elem1 ("p",nil,e) - fun em e = elem1 ("em",nil,e) - fun strong e = elem1 ("strong",nil,e) - fun small e = elem1 ("small",nil,e) - fun big e = elem1 ("big",nil,e) - fun sup e = elem1 ("sup",nil,e) - fun sub e = elem1 ("sub",nil,e) - fun acronym e = elem1 ("acronym",nil,e) - fun abbr s e = elem1 ("abbr",["title=\"" ^ quotencode s ^ "\""],e) - fun cite e = elem1 ("cite",nil,e) - fun var e = elem1 ("var",nil,e) - fun kbd e = elem1 ("kbd",nil,e) - fun samp e = elem1 ("samp",nil,e) - fun code e = elem1 ("code",nil,e) - fun dfn e = elem1 ("dfn",nil,e) - fun b e = elem1 ("b",nil,e) - fun i e = elem1 ("i",nil,e) - fun u e = elem1 ("u",nil,e) - fun tt e = elem1 ("tt",nil,e) - fun address e = elem1 ("address",nil,e) - fun blockquote e = elem1 ("blockquote",nil,e) - fun pre e = elem1 ("pre",nil,e) - fun ol e = elem1 ("ol",nil,e) - fun ul e = elem1 ("ul",nil,e) - fun dl e = elem1 ("dl",nil,e) - fun hr() = elem0 ("hr",nil) - fun br() = elem0 ("br",nil) - fun $ t = txt (htmlencode t) - fun h1 e = elem1("h1",nil,e) - fun h2 e = elem1("h2",nil,e) - fun h3 e = elem1("h3",nil,e) - fun h4 e = elem1("h4",nil,e) - fun h5 e = elem1("h5",nil,e) - fun h6 e = elem1("h6",nil,e) - nonfix div - fun div e = elem1("div",nil,e) - fun li e = elem1("li",nil,e) - fun dt e = elem1("dt",nil,e) - fun dd e = elem1("dd",nil,e) - fun tda a e = elem1("td",a,e) - fun td e = tda nil e - fun tha a e = elem1("th",a,e) - fun th e = tha nil e - fun tra a e = elem1("tr",a,e) - fun tr e = tra nil e - fun tablea a e = elem1("table",a,e) - fun table e = tablea nil e - - infix & - val op & = seq - fun flatten (x, nil) = x - | flatten (x, op :: p) = seq(x,flatten p) - - fun imga a {src,alt} = elem0("img", attr "src" src @ attr "alt" (quotencode alt) @ a) - fun img r = imga nil r - - fun bodya a e = elem1("body",a,e) - fun body e = bodya nil e - - (* Forms *) - type ('n, 'typ) fname = {script: string, n: string} - type nil = unit - type 't var = 't Form.var - - type ('x,'y,'a,'p,'k) felt = ('x,'y,'a,inform,'p,'k) elt - type ('x,'a,'p,'k) form = ('x,nil,'a,'p,'k) felt - type 'a rad = 'a - - type ('x,'y) num = unit - fun One () = () - fun Succ () = () - fun swap () x = x - - fun input (name,it,value,a) = - let val a = case value of - SOME s => attr "value" s @ a - | NONE => a - val a = case name of - SOME {n,script} => attr "name" n @ a - | NONE => a - in elem0("input", attr "type" it @ a) - end - - fun inputHiddena a n var = - input (SOME n, "hidden", SOME (SMLserver.Unsafe.Form.toString var), a) - fun inputHidden n var = inputHiddena nil n var - - fun inputSubmita a s = - input (NONE, "submit", SOME s, a) - fun inputSubmit s = inputSubmita nil s - - fun inputReseta a s = - input (NONE, "reset", SOME s, a) - fun inputReset s = inputReseta nil s - - fun inputTexta a n var = - input (SOME n, "text", Option.map SMLserver.Unsafe.Form.toString var, a) - fun inputText n var = inputTexta nil n var - - fun inputPassworda a n var = - input (SOME n, "password", Option.map SMLserver.Unsafe.Form.toString var, a) - fun inputPassword n var = inputPassworda nil n var - - fun inputRadioa a n var = - input (SOME n, "radio", SOME (SMLserver.Unsafe.Form.toString var), a) - fun inputRadio n var = inputRadioa nil n var - - fun inputRadio' n var = inputRadio n var - fun inputRadioa' a n var = inputRadioa a n var - - fun radioDrop x = x - - type 'a checkbox = unit - fun inputCheckboxa a n var = - input (SOME n, "checkbox", SOME (SMLserver.Unsafe.Form.toString var), a) - fun inputCheckbox n var = inputCheckboxa nil n var - - fun inputCheckbox' n var = inputCheckbox n var - fun inputCheckboxa' a n var = inputCheckboxa a n var - - fun checkboxDrop x = x - - fun textareaa a {n,script} {rows,cols} var = - let val s = getOpt(Option.map SMLserver.Unsafe.Form.toString var,"") - in elem1("textarea", - a @ attr "name" n - @ attr "rows" (Int.toString rows) - @ attr "cols" (Int.toString cols), - txt s) (* memo: what is to be done with s? *) - end - fun textarea n rc var = textareaa nil n rc var - - type 't select_option = {text: string, value: 't var, - selected: bool, disabled: bool} - - fun option (s,var) = {text=s,value=var,selected=false,disabled=false} - - fun select0 a opts = - let - fun battr s false = nil - | battr s true = attr s s - fun opt {text, value, selected, disabled} = - elem1("option", (attr "value" value - @ battr "selected" selected - @ battr "disabled" disabled), $text) - in - case opts of - nil => elem0("select", a) - | x::xs => elem1("select", a, - foldl (fn (x,a) => a & opt x) (opt x) xs) - end - - fun selecta a {n,script} opts = - let val opts = map (fn {text,value,selected,disabled} => - {text=text,value=SMLserver.Unsafe.Form.toString value, selected=selected, - disabled=disabled}) opts - in select0 (a @ attr "name" n) opts - end - fun select n opts = selecta nil n opts - - (* Head elements *) - type helt = elem - fun script {typ:string} s : helt = - elem1("script", attr "type" typ, txt s) - - fun style {typ:string} s : helt = - elem1("style", attr "type" typ, txt s) - - fun meta {content:string} : helt = - elem0("meta", attr "content" content) - - fun link {typ:string,rel:string,href:string} : helt = - elem0("link", attr "type" typ @ attr "rel" rel @ attr "href" href) - - type head = elem - fun head (t,h) = - elem1("head",nil,foldl seq (elem1("title",nil,txt (htmlencode t))) h) - - type html = elem * elem - - structure Unsafe = - struct - fun form {action,method} e = - elem1 ("form", (attr "action" action - @ attr "method" method), e) - - fun ahref {src} e = elem1("a", attr "href" src, e) - - fun toString (h,e) : string = - let - fun insert_spaces nil = nil - | insert_spaces [a] = [a] - | insert_spaces (a::xs) = a :: " " :: insert_spaces xs - fun pp_a nil = "" - | pp_a l = concat(" " :: insert_spaces l) - fun btag t = "<" ^ t ^ ">" - fun btaga t a = "<" ^ t ^ pp_a a ^ ">" - fun taga t a = "<" ^ t ^ pp_a a ^ " />" - fun etag t = "" - fun pe (txt s, c) = s :: c - | pe (elem0 (t,a), c) = taga t a :: c - | pe (elem1 (t,a,e), c) = btaga t a :: pe (e, etag t :: c) - | pe (seq (e1,e2): elem, c) = pe(e1,pe(e2,c)) - in concat - (["\n\ - \\n\ - \\n"] - @ pe(seq(h,e), [""])) - end - - fun urlencode s : string = - let fun enc #" " = "+" - | enc #"-" = "-" - | enc #"_" = "_" - | enc #"." = "." - | enc c = if Char.isAlphaNum c then String.str c - else "%" ^ StringCvt.padLeft #"0" 2 - (Int.fmt StringCvt.HEX (Char.ord c)) - in String.translate enc s - end - - val htmlencode = htmlencode - end - - local - open A - infix % - in - fun validLink() = - Unsafe.ahref {src="http://validator.w3.org/check/referer"} - (imga (height (px 31) % width (px 88)) - {src="http://www.w3.org/Icons/valid-xhtml10", - alt="Valid XHTML 1.0!"}) - end - - val op % = A.% - end diff --git a/smlserver/xt/libxt/XHtmlAttr.sml b/smlserver/xt/libxt/XHtmlAttr.sml deleted file mode 100644 index 6aa2b06cb..000000000 --- a/smlserver/xt/libxt/XHtmlAttr.sml +++ /dev/null @@ -1,132 +0,0 @@ -structure XHtmlAttr : XHTML_ATTR = - struct - type ('a1,'a2, 'b1,'b2, 'c,'c1,'c2, 'd,'d1,'d2, - 'e,'e1,'e2, 'f,'f1,'f2, 'g,'g1,'g2, 'h,'h1,'h2) attr0 = string list - - type ('a2, 'b2, 'c,'c2, 'd,'d2, 'e,'e2, 'f,'f2, - 'g,'g2, 'h,'h2) attr = string list - - fun % (a,b) = a @ b - - (* Type representing absence of attribute *) - type na = unit - - fun attr a s = [a ^ "=\"" ^ s ^ "\""] - - (* Id *) - type id = unit - fun id s = attr "id" s - - (* Style *) - type style = unit - fun style s = attr "style" s - - (* Alignment *) - type align = string list - val left = attr "align" "left" - val center = attr "align" "center" - val right = attr "align" "right" - val justify = attr "align" "justify" - fun char c = attr "align" "char" @ attr "char" (String.str c) - fun align s = s - - (* Vertical alignment *) - type valign = string - val top = "top" - val middle = "middle" - val bottom = "bottom" - val baseline = "baseline" - fun valign s = attr "valign" s - - (* Char attribute *) - type char = unit - fun char c = attr "char" (String.str c) - - (* Charoff attribute *) - type charoff = unit - fun charoff i = attr "charoff" (Int.toString i) - - (* Lengths *) - type len = string - fun pct i = Int.toString i ^ "%" - fun px i = Int.toString i - - (* Width attribute and height *) - type width = unit - fun width len = attr "width" len - - type height = unit - fun height len = attr "height" len - - fun mattr s = attr s s - - (* Checked attribute *) - type checked = unit - fun checked () = mattr "checked" - - (* Disabled attribute *) - type disabled = unit - fun disabled () = mattr "disabled" - - (* Readonly attribute *) - type readonly = unit - fun readonly () = mattr "readonly" - - (* Size attribute *) - type size = unit - fun size i = attr "size" (Int.toString i) - - (* Selected attribute *) - type selected = unit - fun selected () = mattr "selected" - - (* Tables *) - type border = unit - fun border i = attr "border" (Int.toString i) - - type cellspacing = unit - fun cellspacing i = attr "cellspacing" (Int.toString i) - - type cellpadding = unit - fun cellpadding i = attr "cellpadding" (Int.toString i) - - type frame = string - val void = "void" - val above = "above" - val below = "below" - val hsides = "hsides" - val lhs = "lhs" - val rhs = "rhs" - val vsides = "vsides" - val box = "box" - val fborder = "border" - fun frame s = attr "frame" s - - type rules = string - val none = "none" - val groups = "groups" - val rows = "rows" - val cols = "cols" - val all = "all" - fun rules s = attr "rules" s - - type rowspan = unit - fun rowspan i = attr "rowspan" (Int.toString i) - - type colspan = unit - fun colspan i = attr "colspan" (Int.toString i) - end - -(* -structure XHtmlAttrTest = - struct - local - structure A :> XHTML_ATTR = XHtmlAttr - open A - infix % - in - val test1 = fn() => valign middle % width (pct 5) - val test2 = fn() => valign middle - end - end -*) \ No newline at end of file diff --git a/smlserver/xt/libxt/libxt.pm b/smlserver/xt/libxt/libxt.pm deleted file mode 100644 index fdd021369..000000000 --- a/smlserver/xt/libxt/libxt.pm +++ /dev/null @@ -1,30 +0,0 @@ - Quot.sml - local - SMLSERVER_CACHE.sml - SMLSERVER_COOKIE.sml - SMLSERVER_MAIL.sml - SMLSERVER_INFO.sml - SMLSERVER_DB_HANDLE.sml - SMLSERVER_DB.sml - SMLSERVER_FORM.sml - SMLSERVER_UNSAFE.sml - NsBasics.sml - NS_SET.sml - NsSet.sml - SMLserverForm.sml - SMLserverDbFunctor.sml - SMLserverUnsafe.sml - in - SMLSERVER.sig - SMLserver.sml - end - - local - XHTML_ATTR.sml - XHtmlAttr.sml - in - XHTML.sig - XHtml.sml - HTTP.sig - Http.sml - end diff --git a/smlserver/xt/nsd.demo.tcl b/smlserver/xt/nsd.demo.tcl deleted file mode 100644 index 1e94c5d33..000000000 --- a/smlserver/xt/nsd.demo.tcl +++ /dev/null @@ -1,97 +0,0 @@ -#--------------------------------------- -# Sample AOLserver configuration file -# with SMLserver and Postgresql support -#--------------------------------------- - -set user yourlogin -set port 8080 -set pg_passwd XXXX - -set webdir /home/${user}/web -set nssml_so /usr/share/smlserver/bin/nssml.so -set home /usr/share/aolserver - -set host [ns_info hostname] -set bindir [file dirname [ns_info nsd]] - -ns_section "ns/mimetypes" -ns_param .wml text/vnd.wap.wml -ns_param .wbmp image/vnd.wap.wbmp -ns_param .wmls text/vnd.wap.wmlscript -ns_param .wmlc application/vnd.wap.wmlc -ns_param .wmlsc application/vnd.wap.wmlscriptc - -ns_section "ns/parameters" -ns_param debug off -ns_param Home $home -ns_param serverlog ${webdir}/log/server.log -ns_param pidfile ${webdir}/log/nspid.txt -ns_param user ${user} -ns_param stacksize 500000 - -ns_section "ns/servers" -ns_param ${user} "${user}'s server" - -ns_section "ns/server/${user}" -ns_param directoryfile "index.sml" -ns_param pageroot ${webdir}/www -ns_param enabletclpages off - -ns_section "ns/server/${user}/module/nslog" -ns_param file ${webdir}/log/access.log - -ns_section "ns/server/${user}/module/nssock" -ns_param port ${port} -ns_param hostname $host - -ns_section "ns/server/${user}/module/nssml" -ns_param prjid sources -ns_param extendedtyping enabled - -# Initialization script to schedule script execution and -# register trapping of URL requests; remember to include -# the initialization script in the project file. -#ns_param initscript ../sys/init.sml - -# If you have registered trapping, then this script is -# called. -#ns_param trapscript ../sys/trap.sml - -# -# Database drivers -# -ns_section "ns/db/drivers" -ns_param postgres /usr/share/pgdriver/bin/postgres.so - -ns_section "ns/db/pools" -ns_param pg_main "pg_main" -ns_param pg_sub "pg_sub" - -ns_section "ns/db/pool/pg_main" -ns_param Driver postgres -ns_param Connections 5 -ns_param DataSource localhost::${user} -ns_param User ${user} -ns_param Password ${pg_passwd} -ns_param Verbose Off -ns_param LogSQLErrors On -ns_param ExtendedTableInfo On - -ns_section "ns/db/pool/pg_sub" -ns_param Driver postgres -ns_param Connections 5 -ns_param DataSource localhost::${user} -ns_param User ${user} -ns_param Password ${pg_passwd} -ns_param Verbose Off -ns_param LogSQLErrors On -ns_param ExtendedTableInfo On - -ns_section "ns/server/${user}/db" -ns_param Pools pg_main,pg_sub -ns_param DefaultPool "pg_main" - -ns_section "ns/server/${user}/modules" -ns_param nssock nssock.so -ns_param nslog nslog.so -ns_param nssml ${nssml_so} diff --git a/smlserver/xt/www/.cvsignore b/smlserver/xt/www/.cvsignore deleted file mode 100644 index 50c4817b6..000000000 --- a/smlserver/xt/www/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -PM *.gen.sml \ No newline at end of file diff --git a/smlserver/xt/www/bmi.sml b/smlserver/xt/www/bmi.sml deleted file mode 100644 index 6ff7596ce..000000000 --- a/smlserver/xt/www/bmi.sml +++ /dev/null @@ -1,34 +0,0 @@ - functor bmi (F : sig val h : int Form.var - val w : int Form.var - end) : SCRIPTLET = - struct open Scripts infix & - val response = case (Form.get F.h, Form.get F.w) of - (Form.Ok h, Form.Ok w) => - let val bmi = Int.div(w * 10000, h * h) - val txt = if bmi > 25 then "too high!" - else if bmi < 20 then "too low!" - else "normal" - in Page.page "Body Mass Index" - (p ($ ("Your BMI is " ^ txt))) - end - | _ => Page.page "Form Error" (p($"Go Back")) - end - -(*functor bmi2 (F : sig val h : int Form.var - val w : int Form.var - end) : SCRIPTLET = - struct - open Scripts infix & - - val h = Page.get "Height" F.h - val w = Page.get "Weight" F.w - - val bmi = Int.div(w * 10000, h * h) - val txt = if bmi > 25 then "too high!" - else if bmi < 20 then "too low!" - else "normal" - - val response = Page.page "Body Mass Index" - (h2 ($"Your BMI is " & $txt)) - end -*) \ No newline at end of file diff --git a/smlserver/xt/www/bmi2.sml b/smlserver/xt/www/bmi2.sml deleted file mode 100644 index 410ab6d7a..000000000 --- a/smlserver/xt/www/bmi2.sml +++ /dev/null @@ -1,17 +0,0 @@ -functor bmi2 (F : sig val h : int Form.var - val w : int Form.var - end) : SCRIPTLET = - struct - open Scripts infix & - - val h = Page.get "Height" F.h - val w = Page.get "Weight" F.w - - val bmi = Int.div(w * 10000, h * h) - val txt = if bmi > 25 then "too high!" - else if bmi < 20 then "too low!" - else "normal" - - val response = Page.page "Body Mass Index" - (h2 ($"Your BMI is " & $txt)) - end diff --git a/smlserver/xt/www/bmiform.sml b/smlserver/xt/www/bmiform.sml deleted file mode 100644 index 55e1c5be2..000000000 --- a/smlserver/xt/www/bmiform.sml +++ /dev/null @@ -1,13 +0,0 @@ -functor bmiform () : SCRIPTLET = - struct - open Scripts infix & % attr - - val response = - Page.page "BMI Form" - (bmi.form - (p($"Enter height (in cm) " & - inputTexta (A.size 5) bmi.h NONE & br() & - $"Enter weight (in kg) " & - inputTexta (A.size 5) bmi.w NONE & - inputSubmit "Compute BMI"))) - end diff --git a/smlserver/xt/www/bmiform2.sml b/smlserver/xt/www/bmiform2.sml deleted file mode 100644 index a30e27034..000000000 --- a/smlserver/xt/www/bmiform2.sml +++ /dev/null @@ -1,14 +0,0 @@ -functor bmiform2 () : SCRIPTLET = - struct - open Scripts infix & % attr - - val response = - Page.page "BMI Form 2" - (bmi.form - (swap (One()) - (p($"Enter weight (in kg) " & - inputTexta (A.size 5) bmi.w NONE & br() & - $"Enter height (in cm) " & - inputTexta (A.size 5) bmi.h NONE & - inputSubmit "Compute BMI")))) - end diff --git a/smlserver/xt/www/count.sml b/smlserver/xt/www/count.sml deleted file mode 100644 index 4c5c9e09a..000000000 --- a/smlserver/xt/www/count.sml +++ /dev/null @@ -1,18 +0,0 @@ -functor count (F : sig val c : int Form.var - end) : SCRIPTLET = - struct - open Scripts infix & - - fun action s c = - td (count.form (p(inputHidden count.c (Form.Int c) - & inputSubmit s))) - - val c = Page.get "Count" F.c - - val response = - Page.page ("Count: " ^ Int.toString c) - (table (tr (action "Up" (c+1) & - action "Down" (c-1)) - ) - ) - end diff --git a/smlserver/xt/www/countreload.sml b/smlserver/xt/www/countreload.sml deleted file mode 100644 index 2d322b5d1..000000000 --- a/smlserver/xt/www/countreload.sml +++ /dev/null @@ -1,20 +0,0 @@ -functor countreload () : SCRIPTLET = - struct - open Scripts infix && - - fun page i = - let val c = {name="counter", value=Int.toString i, - expiry=NONE,domain=NONE, - path=NONE, secure=false} - in Page.pageWithCookies [c] "Count Reloads" - (p($("Count: " ^ Int.toString i))) - end - - val response = - case SMLserver.Cookie.getCookieValue "counter" of - NONE => page 0 - | SOME v => - case Int.fromString v of - SOME n => page (n+1) - | NONE => page 0 - end diff --git a/smlserver/xt/www/data.sml b/smlserver/xt/www/data.sml deleted file mode 100644 index 3ba7f285f..000000000 --- a/smlserver/xt/www/data.sml +++ /dev/null @@ -1,18 +0,0 @@ -functor data () : SCRIPTLET = - struct - open Scripts infix & - - val response = Http.returnHtml - (html(head ("Data persistence test",nil), - body ( h1 ($"Data persistence test") - & table ( tr(th($"Test") & th($"Lib") & th($"Script")) - & tr(td($"v1") & td($Data0.v1) & td($(Data0.eval Data0.d1))) - & tr(td($"v2") & td($Data0.v2) & td($(Data0.eval Data0.d2)))) - & hr() - & address ($"Served by SMLserver") - ) - ) - ) - - val a = ( (* Data0.f(); *) Data0.r := Data0.Int 200000) - end \ No newline at end of file diff --git a/smlserver/xt/www/index.sml b/smlserver/xt/www/index.sml deleted file mode 100644 index 039c44469..000000000 --- a/smlserver/xt/www/index.sml +++ /dev/null @@ -1,20 +0,0 @@ -functor index () : SCRIPTLET = - struct - open Scripts infix & - - val response = Page.page "Examples" - (ul - ( li (time_of_day.link ($"Time of day")) - & li (data.link ($"Data persistence test")) - & li (mul.link {sz=12} ($"Multiplication table")) - & li (temp.link ($"Temperature conversion")) - & li (count.link {c=0} ($"Counter")) - & li (sum.link {n=5,sum=0} ($"HTTP Sum")) - & li (questionnaire.link ($"Sample questionnaire")) - & li (toppings.link ($"Pizza toppings")) - & li (bmiform.link ($"Body Mass Index")) - & li (bmiform2.link ($"Body Mass Index 2")) - & li (countreload.link ($"Count Reloads")) - ) - ) - end diff --git a/smlserver/xt/www/mul.sml b/smlserver/xt/www/mul.sml deleted file mode 100644 index ec25abb68..000000000 --- a/smlserver/xt/www/mul.sml +++ /dev/null @@ -1,24 +0,0 @@ -functor mul (F : sig val sz : int Form.var - end) : SCRIPTLET = - struct - open Scripts infix & % attr - - fun iter f n = if n <= 1 then flatten(f 1,nil) - else iter f (n-1) & f n - fun col r c = - (td (* attr (A.align A.center) *)) - ($(Int.toString ( r * c ))) - - fun row sz r = - tr (iter (col r) sz) - - fun tab sz = - (tablea (A.border 4 % A.width (A.pct 90) - % A.frame A.vsides % A.rules A.rows)) - (iter (row sz) sz) - - val sz = Page.get "Size" F.sz - - val response = - Page.page "Multiplication table" (tab sz) - end diff --git a/smlserver/xt/www/questionnaire.sml b/smlserver/xt/www/questionnaire.sml deleted file mode 100644 index 0dd793d16..000000000 --- a/smlserver/xt/www/questionnaire.sml +++ /dev/null @@ -1,20 +0,0 @@ -functor questionnaire () : SCRIPTLET = - struct - open Scripts infix & % attr - - fun head s = tha (A.align A.left) ($s) - val radioGroup = radioDrop - (tr (head "Male:" & td(inputRadioa' (A.checked()) questionnaire2.male (Form.Bool true))) & - tr (head "Female:" & td(inputRadio questionnaire2.male (Form.Bool false)))) - - val response = - Page.page "Please answer the following form" - (questionnaire2.form - (swap (Succ(One())) - (swap (One()) - (table (tr (head "Name:" & td(inputText questionnaire2.name NONE)) & - tr (head "Email:" & td(inputText questionnaire2.email NONE)) & - radioGroup & - tr (tda (A.colspan 2) - (inputSubmit "Submit information"))))))) - end diff --git a/smlserver/xt/www/questionnaire2.sml b/smlserver/xt/www/questionnaire2.sml deleted file mode 100644 index 7064ee39e..000000000 --- a/smlserver/xt/www/questionnaire2.sml +++ /dev/null @@ -1,25 +0,0 @@ -functor questionnaire2 (F : sig val male : bool option Form.var - val name : string Form.var - val email: string Form.var - end) : SCRIPTLET = - struct - open Scripts infix & - - fun sexFromMale true = "Male" - | sexFromMale false = "Female" - - val male = Page.get "Male" F.male - val name = Page.get "Name" F.name - val email = Page.get "Email" F.email - - val response = - case male of - SOME male => - Page.page "Your Answer" - (table (tr (th ($"Sex:") & td ($(sexFromMale male))) & - tr (th ($"Name:") & td ($name)) & - tr (th ($"Email:") & td ($email))) - ) - | NONE => - Page.page "Make a choice!" (p($"You must be either a male or a female")) - end diff --git a/smlserver/xt/www/sources.pm b/smlserver/xt/www/sources.pm deleted file mode 100644 index 3d3e22057..000000000 --- a/smlserver/xt/www/sources.pm +++ /dev/null @@ -1,25 +0,0 @@ -import ../libxt/libxt.pm -in - local ../demolib/page.sml - ../demolib/data0.sml - in - [ - index.sml - bmiform.sml - bmiform2.sml - bmi.sml - time_of_day.sml - mul.sml - temp.sml - temp2.sml - count.sml - sum.sml - questionnaire.sml - questionnaire2.sml - toppings.sml - toppings2.sml - countreload.sml - data.sml - ] - end -end diff --git a/smlserver/xt/www/sum.sml b/smlserver/xt/www/sum.sml deleted file mode 100644 index 80070b05f..000000000 --- a/smlserver/xt/www/sum.sml +++ /dev/null @@ -1,15 +0,0 @@ -functor sum (F : sig val sum : int Form.var - val n : int Form.var - end) : SCRIPTLET = - struct - open Scripts infix & % - - val response = - case (Form.get F.sum, Form.get F.n) of - (Form.Ok sum, Form.Ok n) => - if n <= 0 then - Page.page "Sum" - (p ($ ("Sum is " ^ Int.toString sum))) - else sum.redirect {sum=sum+n,n=n-1} nil - | _ => Page.page "Error" (p($"Wrong sum, count, or both")) - end diff --git a/smlserver/xt/www/temp.sml b/smlserver/xt/www/temp.sml deleted file mode 100644 index cc543e3de..000000000 --- a/smlserver/xt/www/temp.sml +++ /dev/null @@ -1,12 +0,0 @@ -functor temp () : SCRIPTLET = - struct - open Scripts infix & % attr - - val response = - Page.page "Temperature Conversion" - (temp2.form - (p( $ "Enter a temperature in degrees Celcius:" - & br() - & inputTexta (A.size 5) temp2.tempC NONE - & inputSubmit "Compute Fahrenheit Temperature"))) - end diff --git a/smlserver/xt/www/temp2.sml b/smlserver/xt/www/temp2.sml deleted file mode 100644 index 0e6bf2fa8..000000000 --- a/smlserver/xt/www/temp2.sml +++ /dev/null @@ -1,17 +0,0 @@ -functor temp2 (F : sig val tempC : int Form.var - end) : SCRIPTLET = - struct - open Scripts infix & - - fun calculate c = - $(Int.toString c ^ " degrees Celcius equals " - ^ Int.toString ( Int.div(9*c,5) + 32 ) - ^ " degrees Fahrenheit.") - - val tempC = Page.get "Temperature" F.tempC - - val response = - Page.page "Temperature Conversion (result)" - ( p ( calculate tempC ) - & p ( $"Go " & temp.link ($"again") & $"?")) - end diff --git a/smlserver/xt/www/time_of_day.sml b/smlserver/xt/www/time_of_day.sml deleted file mode 100644 index 4950ffb20..000000000 --- a/smlserver/xt/www/time_of_day.sml +++ /dev/null @@ -1,17 +0,0 @@ -functor time_of_day () : SCRIPTLET = - struct - open Scripts infix & - - val time_of_day = - Date.fmt "%H.%M.%S" (Date.fromTimeLocal(Time.now())) - - val response = Http.returnHtml - (html(head ("Time of day",nil), - body ( h1 ($"Time of day") - & p($("The time of day is " ^ time_of_day)) - & hr() - & address ($"Served by SMLserver") - ) - ) - ) - end \ No newline at end of file diff --git a/smlserver/xt/www/toppings.sml b/smlserver/xt/www/toppings.sml deleted file mode 100644 index be85d1968..000000000 --- a/smlserver/xt/www/toppings.sml +++ /dev/null @@ -1,19 +0,0 @@ -functor toppings () : SCRIPTLET = - struct - open Scripts infix & - - val response = - Page.page "Pizza Order Form" - (p (toppings2.link {toppings=["cheese", "pepperoni"]} ($"Cheese-Pepperoni Quick Order")) - & - toppings2.form - (p( $ "What toppings would you like on your pizza?") - & checkboxDrop - (table (tr (td ($"Cheese") & - td (inputCheckbox' toppings2.toppings (Form.String "cheese"))) & - tr (td ($"Pepperoni") & - td(inputCheckbox' toppings2.toppings (Form.String "pepperoni"))) & - tr (td ($"Ananas") & - td(inputCheckbox toppings2.toppings (Form.String "ananas")))) - & p(inputSubmit "Order pizza")))) - end diff --git a/smlserver/xt/www/toppings2.sml b/smlserver/xt/www/toppings2.sml deleted file mode 100644 index b5547738e..000000000 --- a/smlserver/xt/www/toppings2.sml +++ /dev/null @@ -1,19 +0,0 @@ -functor toppings2 (F : sig val toppings : string list Form.var - end) : SCRIPTLET = - struct - open Scripts infix & - - val response = - case Form.get F.toppings of - Form.Ok nil => - Page.page "Pizza Order" (p($"You ordered a pizza with no toppings.")) - | Form.Ok (all as (t :: ts)) => - Page.page "Pizza Order" - (p($ ("You ordered a pizza with the following " - ^ Int.toString (length all) - ^ " toppings:")) & - ul (flatten (li($t), map (li o $) ts))) - | _ => - Page.page "Error" (p($"impossible - unless you are tampering the request")) - - end diff --git a/smlserver_demo/.cvsignore b/smlserver_demo/.cvsignore deleted file mode 100644 index 33ceb8f07..000000000 --- a/smlserver_demo/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -Makefile \ No newline at end of file diff --git a/smlserver_demo/.gitignore b/smlserver_demo/.gitignore deleted file mode 100644 index 33ceb8f07..000000000 --- a/smlserver_demo/.gitignore +++ /dev/null @@ -1 +0,0 @@ -Makefile \ No newline at end of file diff --git a/smlserver_demo/Makefile.in b/smlserver_demo/Makefile.in deleted file mode 100644 index ccca1533b..000000000 --- a/smlserver_demo/Makefile.in +++ /dev/null @@ -1,55 +0,0 @@ - -SHELL=@SHELL@ - -prefix=@prefix@ -srcdir=@srcdir@ -top_srcdir=@top_srcdir@ -exec_prefix=@exec_prefix@ -LIBDIR=$(DESTDIR)@libdir@ -VPATH=@srcdir@ - - -MKDIR=@top_srcdir@/mkinstalldirs -INSTALL=@INSTALL@ -INSTALLDATA=@INSTALL_DATA@ - -.PHONY: install all - -all: - $(MAKE) -C www - -install: - $(MKDIR) $(LIBDIR)/web_sys - $(MKDIR) $(LIBDIR)/web_demo_lib - $(MKDIR) $(LIBDIR)/web_demo_lib/mysql - $(MKDIR) $(LIBDIR)/web_demo_lib/orasql - $(MKDIR) $(LIBDIR)/web_demo_lib/pgsql - $(MKDIR) $(LIBDIR)/www - $(MKDIR) $(LIBDIR)/www/images - $(MKDIR) $(LIBDIR)/www/web - $(MKDIR) $(LIBDIR)/www/web/employee - $(MKDIR) $(LIBDIR)/www/web/link - $(MKDIR) $(LIBDIR)/www/web/rating - $(MKDIR) $(LIBDIR)/www/web/secret - $(MKDIR) $(LIBDIR)/www/web/upload - $(MKDIR) $(LIBDIR)/www/web/upload/files - $(INSTALLDATA) web_sys/*.sml $(LIBDIR)/web_sys - $(INSTALLDATA) www/web.mlb $(LIBDIR)/www - $(INSTALLDATA) www/Makefile $(LIBDIR)/www - $(INSTALLDATA) www/web/*.{sml,msp,html,jpg} $(LIBDIR)/www/web - $(INSTALLDATA) www/web/Makefile $(LIBDIR)/www/web - $(INSTALLDATA) www/web/employee/*.{sql,sml} $(LIBDIR)/www/web/employee - $(INSTALLDATA) www/web/link/*.sml $(LIBDIR)/www/web/link - $(INSTALLDATA) www/web/rating/*.{sql,sml,jpg} $(LIBDIR)/www/web/rating - $(INSTALLDATA) www/web/secret/*.sml $(LIBDIR)/www/web/secret - $(INSTALLDATA) www/web/upload/*.sml $(LIBDIR)/www/web/upload - $(INSTALLDATA) www/web/upload/files/*.png $(LIBDIR)/www/web/upload/files - $(INSTALLDATA) www/images/*.{png,html} $(LIBDIR)/www/images - $(INSTALLDATA) web_demo_lib/*.sml $(LIBDIR)/web_demo_lib - $(INSTALLDATA) web_demo_lib/mysql/*.sql $(LIBDIR)/web_demo_lib/mysql - $(INSTALLDATA) web_demo_lib/orasql/*.sql $(LIBDIR)/web_demo_lib/orasql - $(INSTALLDATA) web_demo_lib/pgsql/*.sql $(LIBDIR)/web_demo_lib/pgsql - -clean: - $(MAKE) -C www clean - rm -rf *~ MLB */MLB */*/MLB */*/*/MLB */*~ */*/*~ */*/*/*~ diff --git a/smlserver_demo/web_demo_lib/Auth.sml b/smlserver_demo/web_demo_lib/Auth.sml deleted file mode 100644 index 4903c5baf..000000000 --- a/smlserver_demo/web_demo_lib/Auth.sml +++ /dev/null @@ -1,125 +0,0 @@ -signature AUTH = - sig - type person_id = int - - val loginPage : string - val defaultHome : string - val siteName : string - - val verifyPerson : unit -> person_id option - val isLoggedIn : unit -> bool - - val newPassword : int -> string - val sendPassword : person_id -> unit - (* - [person_id] type of value that uniquely identifies a user. - - [loginPage] absolute path to login page. - - [defaultHome] absolute path to the page. - - [siteName] name of the web-site. - - [verifyPerson()] returns SOME(p) if the user with - person_id p is logged in; otherwise NONE is returned. - - [isLoggedIn()] returns true if the user is logged in; - returns false otherwise. - - [newPassword n] generates a new password constructed from n - characters chosen randomly from the set {a-zA-Z2-9} \ {loO}. - - [sendPassword p] sends an email to the user with person_id p - containing the user's password. - *) - end - -structure Auth : AUTH = - struct - (* Configuration *) - val emailFrom = "anonymous@it.edu" - val defaultHome = "/web/link/index.sml" - val siteName = "SMLserver.org" - val loginPage = "/web/auth_form.sml" - - type person_id = int - - (* verifyPerson; return SOME(p) if user with person_id p - * is logged in; returns NONE otherwise. *) - fun verifyPerson0 (getPasswd: string -> string option) - : person_id option = - (case (Web.Cookie.getCookieValue "auth_person_id", - Web.Cookie.getCookieValue "auth_password") - of (SOME person_id, SOME psw) => - (case getPasswd person_id - of NONE => NONE - | SOME db_psw => - if db_psw = psw then Int.fromString person_id - else NONE) - | _ => NONE) - handle Web.Cookie.CookieError _ => NONE -(* - fun verifyPerson() = - verifyPerson0 (fn p => Db.zeroOrOneField - `select password from person - where person_id = ^p`) -*) - fun verifyPerson() = - let fun f p = - Db.zeroOrOneField - `select password from person - where person_id = ^p` - val cache = Web.Cache.get (Web.Cache.String, Web.Cache.String,"auth", - Web.Cache.WhileUsed (SOME (Time.fromSeconds 600), SOME 10000)) - val g = Web.Cache.memoizePartial cache f - in verifyPerson0 g - end - - fun isLoggedIn() : bool = case verifyPerson() - of SOME _ => true - | NONE => false - - val okchs = "abcdefghijkmnpqrstuvwxyzABCDEFGHIJKLMNPQRSTUVWXYZ23456789" - fun newPassword n : string = - let val gen = Random.newgen() - val range = size okchs - fun ch() = CharVector.sub(okchs, Random.range(0,range) gen) - fun loop (0,acc) = implode(rev acc) - | loop (n,acc) = loop (n-1, ch()::acc) - in loop (n, nil) - end - - fun sendPassword (pid : person_id) : unit = - let val query = `select email, name, password - from person - where person_id = ^(Int.toString pid)` - val (email, name, passwd) = - case Db.zeroOrOneRow query - of NONE => raise Fail "sendPassword: no such user" - | SOME [e, n, p] => (e, n, p) - | _ => raise Fail "sendPassword: database error" - val subject = "welcome to " ^ siteName - val loginPage = Web.Conn.location() ^ loginPage - val body = Quot.toString -`Dear ^name, - -To login to ^siteName, visit the page - - ^loginPage - -and provide your email address and password: - - email : ^email - password : ^passwd - -Best Regards, - -The ^siteName administrator` - - in Web.Mail.send {to=email, from=emailFrom, - subject=subject,body=body} - end - end - - - diff --git a/smlserver_demo/web_demo_lib/Db.sml b/smlserver_demo/web_demo_lib/Db.sml deleted file mode 100644 index c42f2fe6f..000000000 --- a/smlserver_demo/web_demo_lib/Db.sml +++ /dev/null @@ -1,7 +0,0 @@ -(* Default Db structure *) - -structure Db = DbFunctor(struct - structure DbBackend = Web.DbPostgreSQLBackend - (* Web.DbOraBackend *) - val name = "DefaultDatabase" - end) diff --git a/smlserver_demo/web_demo_lib/DbClob.sml b/smlserver_demo/web_demo_lib/DbClob.sml deleted file mode 100644 index 031ea5766..000000000 --- a/smlserver_demo/web_demo_lib/DbClob.sml +++ /dev/null @@ -1,81 +0,0 @@ -signature DB_CLOB = - sig - (* [insert q] return fresh clob_id and inserts in db_clob table *) - val insert : quot -> string - - (* [insert_fn q] lamba version of insert to use as part of a - larger transaction *) - val insert_fn : quot -> (Db.Handle.db -> string) - - (* [update clob_id q] update the clob identified as clob_id with - quotation q *) - val update : string -> quot -> unit - - (* [update_fn clob_id q] lambda version of update to use as part - of a larger transaction *) - val update_fn : string -> quot -> (Db.Handle.db -> unit) - - (* [select clob_id] select a clob given a clob_id *) - val select : string -> quot - - (* [select_fn clob_id] lamda version of select - to use in a - larger transaction *) - val select_fn : string -> (Db.Handle.db -> quot) - - (* [delete clob_id] delete clob given a clob_id *) - val delete : string -> unit - - (* [delete_fn clob_id] lambda version of delete - to use in a - larger transaction *) - val delete_fn : string -> (Db.Handle.db -> unit) - - (* [gToStringOpt g field_name] is used to extract text from - database (clob) fields that are nullable. returns (SOME clob_text) - if g field_name contains an integer *) - val gToStringOpt : (string->string) -> string -> string option - end - -structure DbClob :> DB_CLOB = - struct - fun insert_fn' (clob_id:string) (q:quot) : Db.Handle.db -> string = - let - fun split s = if Substring.size s <= 4000 - then [Substring.string s] - else - let - val (s1,s2) = Substring.splitAt(s,4000) - in - Substring.string s1 :: split s2 - end - val strs = split (Substring.full (Quot.toString q)) - in - fn db => - (List.foldl (fn (s,idx) => - (Db.Handle.dmlDb db `insert into db_clob (clob_id,idx,text) - values (^(Db.valueList[clob_id,Int.toString idx,s]))`; - idx+1)) 0 strs; - clob_id) - end - fun insert_fn q = insert_fn' (Int.toString (Db.seqNextval "db_clob_id_seq")) q - val insert = Db.Handle.dmlTrans o insert_fn - - fun delete_fn (clob_id : string) : Db.Handle.db -> unit = - fn db => Db.Handle.dmlDb db `delete from db_clob where clob_id = ^(Db.qqq clob_id)` - fun delete clob_id = Db.Handle.dmlTrans (delete_fn clob_id) - - fun update_fn clob_id q = fn db => (delete_fn clob_id db; insert_fn' clob_id q db; ()) - fun update clob_id q = Db.Handle.dmlTrans (update_fn clob_id q) - - fun select_fn clob_id = - fn db => - Db.Handle.foldDb db - (fn (g,acc) => acc ^^ `^(g "text")`) `` `select text from db_clob - where clob_id=^(Db.qqq clob_id) - order by idx` - fun select clob_id = Db.Handle.wrapDb (select_fn clob_id) - - fun gToStringOpt g field_name = case Int.fromString( g field_name ) of - SOME cid => SOME (Quot.toString (select (g field_name))) - | NONE => NONE - - end diff --git a/smlserver_demo/web_demo_lib/FormVar.sml b/smlserver_demo/web_demo_lib/FormVar.sml deleted file mode 100644 index 31c62dd94..000000000 --- a/smlserver_demo/web_demo_lib/FormVar.sml +++ /dev/null @@ -1,376 +0,0 @@ -signature FORM_VAR = - sig - - (* Checking form variables is an important part of implementing a - secure and stable web-site, but it is often a tedious job, - because the same kind of code is written in all files that - verify form variables. This module overcomes the tedious part - by defining several functions that may be used to test form - variables consistently throughout a large system. - - The idea is to define a set of functions, corresponding to each - type of value used in forms. Each function is defined to access - values contained in form variables of the particular type. For - instance, a function is defined for accessing all possible - email addresses in a form variable. In case the given form - variable does not contain a valid email address, errors are - accumulated and presented to the user when all form variables - have been checked. So as to deal with error accumulation - properly, each function takes three arguments: - - (1) The name of the form-variable holding the value, - (2) The name of the field in the form; the user may - be presented with an errorpage with more than one - error and it is important that the error message - refer to a given field in the form - (3) An error container of type errs used to hold - the error messages sent back to the user - - The functions are named getFormtypeErr, where Formtype range - over possible form types. In each script, when all form - variables have been checked using calls to particular - getFormtypeErr functions, a call to the function any_errors - returns an error-page if any errors occurred and otherwise - proceeds with the remainder of the script. If an error-page is - returned, then the script is terminated. - - The type formvar_fn represents the type of functions used to - check form variables. If it is not desirable to return an error - page, the programmer may use one of the wrapper functions to - obtain appropriate behavior: - - wrapOpt : On success returns SOME v where v is the - form value; otherwise NONE - wrapExn : Raises exception FormVar if it fails to - parse the form variable - wrapPanic: Executes a function on fail; this may - be used to control system failures. Say, - you have a hidden form variable seq_id - (a sequence id in the database) and it - can't be parsed then the function may - log the error, send mail to the system - maintainer etc. - wrapFail: On failure, a page is returned. The - difference from the getFormtypeErr - functions is that with wrapFail only - one error is shown on the error page - at the time. - The file /www/formvar_chk shows how to use the - wrap-functions. *) - - exception FormVar of string - type errs - type 'a formvar_fn = string * string * errs -> 'a * errs - - val emptyErr : errs - val addErr : Quot.quot * errs -> errs - val buildErrMsg : errs -> Quot.quot - val anyErrors : errs -> unit - val isErrors : errs -> bool - - val getIntErr : int formvar_fn - val getNatErr : int formvar_fn - val getRealErr : real formvar_fn - val getStringErr : string formvar_fn - val getIntRangeErr : int -> int -> int formvar_fn - val getEmailErr : string formvar_fn - val getNameErr : string formvar_fn - val getAddrErr : string formvar_fn - val getLoginErr : string formvar_fn - val getPhoneErr : string formvar_fn - val getHtmlErr : string formvar_fn - val getUrlErr : string formvar_fn - val getEnumErr : string list -> string formvar_fn - val getYesNoErr : string formvar_fn - val getTableName : string formvar_fn - - (* val wrapQQ : string formvar_fn -> (string * string) formvar_fn *) - val wrapOpt : 'a formvar_fn -> (string -> 'a option) - val wrapMaybe : 'a formvar_fn -> 'a formvar_fn - val wrapExn : 'a formvar_fn -> (string -> 'a) - val wrapFail : 'a formvar_fn -> (string * string -> 'a) - val wrapPanic : (Quot.quot -> 'a) -> 'a formvar_fn -> (string -> 'a) - val wrapIntAsString : int formvar_fn -> string formvar_fn - - val getStrings : string -> string list - - (* For extensions *) - val trim : string -> string - val getErr : 'a -> (string->'a) -> string -> (string->Quot.quot) -> (string->bool) -> 'a formvar_fn - end - -structure FormVar :> FORM_VAR = - struct - type quot = Quot.quot - type errs = quot list - type 'a formvar_fn = string * string * errs -> 'a * errs - - val regExpMatch = RegExp.match o RegExp.fromString - val regExpExtract = RegExp.extract o RegExp.fromString - - exception FormVar of string - - val emptyErr : errs = [] - - fun addErr (emsg:quot,errs:errs) = emsg :: errs - fun B a = "" ^ a ^ "" - fun genErrMsg (f_msg:string,msg:quot) : quot = `Error in field ^(B f_msg). ` ^^ msg - fun errNoFormVar(f_msg:string,ty:string) : quot = `Error in field ^(B f_msg). You must provide a valid ^ty.` - fun errTypeMismatch(f_msg:string,ty:string,v:string) : quot = - `Error in field ^(B f_msg). You must provide a valid ^ty - ^v is not a valid ^ty.` - fun errTooLarge(f_msg:string,ty:string,v:string) : quot = - `Error in field ^(B f_msg). The provided ^ty (^v) is too large.` - fun errTooMany(f_msg:string) : quot = - `Error in field ^(B f_msg). More than one data item is provided.` - - fun buildErrMsg (errs: errs) : quot = - `We had a problem processing your entry: - - Please back up using your browser, correct the form, and resubmit your entry.

- Thank you.` - - fun returnErrors (errs: errs) = - (Page.return "Form Error" (buildErrMsg errs); - Web.exit()) - - fun anyErrors ([]:errs) = () - | anyErrors (errs) = returnErrors errs - - fun isErrors ([]:errs) = false - | isErrors (errs) = true - - fun wrapOpt (f : 'a formvar_fn) : string -> 'a option = - fn fv => - case f (fv,"",[]) of - (v,[]) => SOME v - | _ => NONE - - fun wrapIntAsString (f : int formvar_fn) = - (fn (fv,emsg,errs) => - case f(fv,emsg,[]) of - (i,[]) => (Int.toString i,errs) - |(_,[e]) => ("",addErr(e,errs)) - | _ => Page.panic `FormVar.wrapIntAsString failed on ^fv`) - - fun trim s = Substring.string (Substring.dropr Char.isSpace (Substring.dropl Char.isSpace (Substring.full s))) - fun wrapMaybe (f : 'a formvar_fn) = - (fn (fv,emsg,errs) => - (case Web.Conn.formvarAll fv of - [] => (case f(fv,emsg,[]) of (v,_) => (v,errs)) (* No formvar => don't report error *) - | [v] => - (if trim v = "" then - (case f(fv,emsg,[]) of (v,_) => (v,errs)) (* Don't report error *) - else f(fv,emsg,errs)) - | _ => f(fv,emsg,errs))) (* Multiple formvars => report error *) - - fun wrapExn (f : 'a formvar_fn) : string -> 'a = - fn fv => - case f (fv,fv,[]) of - (v,[]) => v - | (_,x::xs) => raise FormVar (Quot.toString x) - - fun wrapFail (f : 'a formvar_fn) : string * string -> 'a = - fn (fv:string,emsg:string) => - case f (fv,emsg,[]) of - (v,[]) => v - | (_,errs) => returnErrors errs - - fun wrapPanic (f_panic: quot -> 'a) (f : 'a formvar_fn) : string -> 'a = - fn fv => - ((case f (fv,fv,[]) of - (v,[]) => v - | (_,x::xs) => f_panic(`^("\n") ^fv : ` ^^ x)) - handle X => f_panic(`^("\n") ^fv : ^(General.exnMessage X)`)) - - local - - fun getFormVar fv = Web.Conn.formvarAll fv - - fun getErrWithOverflow (empty_val:'a) (ty:string) (chk_fn:string->'a option) = - fn (fv:string,emsg:string,errs:errs) => - (case getFormVar (*Web.Conn.formvarAll*) fv of - [] => (empty_val,addErr(errNoFormVar(emsg,ty),errs)) - | [""] => (empty_val,addErr(errNoFormVar(emsg,ty),errs)) - | [v] => - ((case chk_fn v of - SOME v => (v,errs) - | NONE => (empty_val, addErr(errTypeMismatch(emsg,ty,v),errs))) - handle Overflow => (empty_val, addErr(errTooLarge(emsg,ty,v),errs))) - | _ => (empty_val, addErr(errTooMany emsg,errs))) - in - val getIntErr = getErrWithOverflow 0 "number" - (fn v => let val l = explode v - in - case l - of c::_ => - if Char.isDigit c orelse c = #"-" orelse c = #"~" then - (case Int.scan StringCvt.DEC List.getItem l - of SOME (n, nil) => SOME n - | _ => NONE) - else NONE - | nil => NONE - end handle Fail s => NONE) - val getNatErr = getErrWithOverflow 0 "positive number" - (fn v => let val l = explode v - in - case l - of c::_ => - if Char.isDigit c then - (case Int.scan StringCvt.DEC List.getItem l - of SOME (n, nil) => SOME n - | _ => NONE) - else NONE - | nil => NONE - end) - - val getRealErr = getErrWithOverflow 0.0 "real" - (fn v => let val l = explode v - in - case l - of c::_ => - if Char.isDigit c orelse c = #"-" orelse c = #"~" then - (case Real.scan List.getItem l - of SOME (n, nil) => SOME n - | _ => NONE) - else NONE - | nil => NONE - end) - - val getStringErr = getErrWithOverflow "" "string" (fn v => if size v = 0 then NONE else SOME v) - end - - fun getIntRangeErr a b (args as (fv:string,emsg:string,errs:errs)) = - let - val (i,errs') = getIntErr args - in - if List.length errs = List.length errs' then - if a <= i andalso i <= b - then (i,errs) - else (0,addErr(genErrMsg(emsg,`The integer ^(Int.toString i) is not within the valid range - [^(Int.toString a),...,^(Int.toString b)].`),errs)) - else - (0,errs') - end - - fun getErr (empty_val:'a) (conv_val:string->'a) (ty:string) (add_fn:string->quot) (chk_fn:string->bool) = - fn (fv:string,emsg:string,errs:errs) => - case Web.Conn.formvarAll fv of - [] => (empty_val,addErr(genErrMsg(emsg,add_fn ("You must provide a valid "^ty^".")),errs)) - | [""] => (empty_val,addErr(genErrMsg(emsg,add_fn ("You must provide a valid "^ty^".")),errs)) - | [v] => - if chk_fn v then - (conv_val v,errs) - else - (empty_val, addErr(genErrMsg(emsg,add_fn ("You must provide a valid "^ty^" - " ^ - v ^ " is not one")), - errs)) - | _ => (empty_val, addErr(errTooMany emsg,errs)) - - local - val getErr' = getErr "" trim - fun msgEmail s = - `^s -

A few examples of valid emails: -
` - - fun msgName s = - `^s -
- A name may contain the letters from the alphabet including: ', \,-,æ, - ø,å,Æ,Ø,Å and space. -
` - - fun msgAddr s = - `^s -
- An address may contain digits, letters from the alphabet including: - ', \\ , -, ., :, ;, ,, - æ,ø,å,Æ,Ø,Å -
` - - fun msgLogin s = - `^s -
- A login may contain lowercase letters from the alphabet and digits - the first - character must not be a digit. Special characters - like æ,ø,å,;,^^,% are not alowed. - A login must be no more than 10 characters and at least three characters. -
` - - fun msgPhone s = - `^s -
- A telephone numer may contain numbers and letters from the alphabet - including -, , and .. -
` - - fun msgHTML s = - `^s -
- You may use the following HTML tags in your text: Not implemented yet. - ` - - fun msgURL s = - `^s -
- URL (Uniform Resource Locator) - - only URL's with prefix http:// are supported (e.g., http://www.it.edu). -
` - - fun msgEnum enums s = - `^s - You must choose among the following enumerations: -
- ^(String.concatWith "," enums) -
` - - fun msgDateIso s = - `^s -
- You must type a date in the ISO format YYYY-MM-DD (e.g., 2001-10-25). -
` - - fun msgDate s = - `^s -
- You must type a date in either the Danish format DD/MM-YYYY (e.g., 25/01-2001) or - the ISO format YYYY-MM-DD (e.g., 2001-01-25). -
` - - fun msgTableName s = - `^s -
- You have not specified a valid table name -
` - - fun chkEnum enums v = - case List.find (fn enum => v = enum) enums - of NONE => false - | SOME _ => true - in - val getEmailErr = getErr' "email" msgEmail - (fn email => regExpMatch "[^@\t ]+@[^@.\t ]+(\\.[^@.\n ]+)+" (trim email)) - val getNameErr = getErr' "name" msgName (regExpMatch "[a-zA-ZAÆØÅaæøå '\\-]+") - val getAddrErr = getErr' "address" msgAddr (regExpMatch "[a-zA-Z0-9ÆØÅæøå '\\-.:;,]+") - val getLoginErr = getErr' "login" msgLogin - (fn login => - regExpMatch "[a-z][a-z0-9\\-]+" login andalso - String.size login >= 3 andalso String.size login <= 10) - val getPhoneErr = getErr' "phone number" msgPhone (regExpMatch "[a-zA-Z0-9ÆØÅæøå '\\-.:;,]+") - (* getHtml : not implemented yet *) - val getHtmlErr = getErr' "HTML text" msgHTML (fn html => html <> "") - val getUrlErr = getErr' "URL" msgURL (regExpMatch "http://[0-9a-zA-Z/\\-\\\\._~]+(:[0-9]+)?") - val getEnumErr = fn enums => getErr' "enumeration" (msgEnum enums) (chkEnum enums) - val getYesNoErr = let val enums = ["Yes","No"] in getErr' "Yes/No" (msgEnum enums) (chkEnum ["t","f"]) end - val getTableName = getErr' "table name" msgTableName (regExpMatch "[a-zA-Z_]+") - end - - fun getStrings fv = List.map trim (Web.Conn.formvarAll fv) - end - diff --git a/smlserver_demo/web_demo_lib/Page.sml b/smlserver_demo/web_demo_lib/Page.sml deleted file mode 100644 index a0f085b76..000000000 --- a/smlserver_demo/web_demo_lib/Page.sml +++ /dev/null @@ -1,37 +0,0 @@ -signature PAGE = - sig - val return : string -> quot -> unit - val panic : quot -> 'a - end - -(* - -[returnPg head body] writes a standard page to the client containing -the heading `head' and the body `body'. - -[panic body] writes a standard error message to the client and reports -the error in the log file, whereafter the function calls Web.exit. - -*) - -structure Page : PAGE = - struct - fun return head body = Web.return - (` - ^head - - -

^head

` ^^ - body ^^ - `
Served by - SMLserver, - Back to index page. - - `) - - fun panic body = - (Web.log (Web.Error, Quot.toString body); - return "Internal Error" body; - Web.exit()) - end - diff --git a/smlserver_demo/web_demo_lib/RatingUtil.sml b/smlserver_demo/web_demo_lib/RatingUtil.sml deleted file mode 100644 index 99b4d5b45..000000000 --- a/smlserver_demo/web_demo_lib/RatingUtil.sml +++ /dev/null @@ -1,54 +0,0 @@ - -signature RATING_UTIL = - sig - val returnPage : string -> string frag list - -> unit - - val returnPageWithTitle : string - -> string frag list -> unit - - val bottleImgs : int -> string - - val mailto : string -> string -> string - - (* - [returnPage title body] returns a page - to a browser. - - [returnPageWithTitle title body] returns a - page to a browser with title as h1-header. - - [bottleImgs n] returns html code for n bottles. - - [mailto email name] returns mailto anchor. - *) - end - -structure RatingUtil : RATING_UTIL = - struct - fun returnPage title body = - Web.return (` - ^title - -
` ^^ body ^^ - `
Served by SMLserver - ,Back to index page. -
- - `) - - fun returnPageWithTitle title body = - returnPage title (`

^title

` ^^ body) - - (* A procedure for generating bottle images *) - fun bottleImgs n = - let fun g (n, acc) = - if n <= 0 then concat acc - else g (n - 1, "" :: acc) - in g(n,nil) - end - - fun mailto email name = - "" ^ name ^ "" - end diff --git a/smlserver_demo/web_demo_lib/mysql/all.sql b/smlserver_demo/web_demo_lib/mysql/all.sql deleted file mode 100644 index ee9b366bf..000000000 --- a/smlserver_demo/web_demo_lib/mysql/all.sql +++ /dev/null @@ -1,7 +0,0 @@ --- Load datamodel: --- mysql dbname -u dbuser < all.sql - -\. person.sql -\. link.sql -\. rating.sql -\. employee.sql \ No newline at end of file diff --git a/smlserver_demo/web_demo_lib/mysql/employee.sql b/smlserver_demo/web_demo_lib/mysql/employee.sql deleted file mode 100644 index 4b24ee700..000000000 --- a/smlserver_demo/web_demo_lib/mysql/employee.sql +++ /dev/null @@ -1,18 +0,0 @@ --- Load datamodel: --- mysql dbname -u dbuser < employee.mysql - - drop table if exists employee; - - create table employee ( - email varchar(200) primary key not null, - name varchar(200) not null, - passwd varchar(200) not null, - note text, - last_modified date - ); - - insert into employee (name, email, passwd) - values ('Martin Elsman', 'mael@it.edu', 'don''t-forget'); - - insert into employee (email, name, passwd, note) - values ('nh@it.edu', 'Niels Hallenberg', 'hi', 'meeting'); diff --git a/smlserver_demo/web_demo_lib/mysql/link.sql b/smlserver_demo/web_demo_lib/mysql/link.sql deleted file mode 100644 index a1b63505b..000000000 --- a/smlserver_demo/web_demo_lib/mysql/link.sql +++ /dev/null @@ -1,19 +0,0 @@ --- Load datamodel: --- mysql dbname -u dbuser < link.sql - --- We do not use a sequence separately in this --- example - we only insert into table link --- each time a new link_id is created, hense, --- we do not create a link_seq table as used in --- file add.sml -drop table if exists link; - -create table link ( - link_id int primary key auto_increment, - person_id int not null, - url varchar(200) not null, - text varchar(200) -); - -insert into link (link_id, person_id, url, text) -values (null, 1, 'http://www.smlserver.org', 'The SMLserver web-site'); diff --git a/smlserver_demo/web_demo_lib/mysql/person.sql b/smlserver_demo/web_demo_lib/mysql/person.sql deleted file mode 100644 index 30e16cd1d..000000000 --- a/smlserver_demo/web_demo_lib/mysql/person.sql +++ /dev/null @@ -1,27 +0,0 @@ --- Load datamodel: --- mysql dbname -u dbuser < person.sql - -drop table if exists person; -drop table if exists person_seq; - -create table person_seq ( - seqId integer not null primary key auto_increment -); - -create table person ( - person_id int primary key, - password varchar(100) not null, - email varchar(20) unique not null, - name varchar(100) not null, - url varchar(200) -); - -insert into person_seq (seqId) values (1); -insert into person (person_id, password, email, name, url) -values (1, 'Martin', 'mael@it.edu', 'Martin Elsman', - 'http://www.dina.kvl.dk/~mael'); - -insert into person_seq (seqId) values (2); -insert into person (person_id, password, email, name, url) -values (2, 'Niels', 'nh@it.edu', 'Niels Hallenberg', - 'http://www.it.edu/~nh'); diff --git a/smlserver_demo/web_demo_lib/mysql/rating.sql b/smlserver_demo/web_demo_lib/mysql/rating.sql deleted file mode 100644 index 3a52e7856..000000000 --- a/smlserver_demo/web_demo_lib/mysql/rating.sql +++ /dev/null @@ -1,27 +0,0 @@ --- Load datamodel: --- mysql dbname -u dbuser < rating.mysql - -drop table if exists rating; -drop table if exists wine; -drop table if exists wid_sequence; - -create table wid_sequence ( - seqId integer primary key auto_increment -); - -create table wine ( - wid integer primary key, - name varchar(100) not null, - year integer, - unique ( name, year ) -); - -create table rating ( - wid integer not null, - comments text, - fullname varchar(100), - email varchar(100), - rating integer -); - - diff --git a/smlserver_demo/web_demo_lib/orasql/all.sql b/smlserver_demo/web_demo_lib/orasql/all.sql deleted file mode 100644 index 83430f31b..000000000 --- a/smlserver_demo/web_demo_lib/orasql/all.sql +++ /dev/null @@ -1,12 +0,0 @@ -drop table link; -drop table rating; -drop table wine; -drop table person; -drop table employee; -drop table guest; -@person.sql -@link.sql -@rating.sql -@employee.sql -@guest.sql - diff --git a/smlserver_demo/web_demo_lib/orasql/clob.sql b/smlserver_demo/web_demo_lib/orasql/clob.sql deleted file mode 100644 index 85b163b3e..000000000 --- a/smlserver_demo/web_demo_lib/orasql/clob.sql +++ /dev/null @@ -1,8 +0,0 @@ ---drop table db_clob; ---drop sequence db_clob_id_seq; -create sequence db_clob_id_seq; -create table db_clob ( - clob_id integer, - idx integer not null, - text varchar(4000), - primary key (clob_id,idx)); diff --git a/smlserver_demo/web_demo_lib/orasql/employee.sql b/smlserver_demo/web_demo_lib/orasql/employee.sql deleted file mode 100644 index fd0238659..000000000 --- a/smlserver_demo/web_demo_lib/orasql/employee.sql +++ /dev/null @@ -1,13 +0,0 @@ -create table employee ( - email varchar(200) primary key not null, - name varchar(200) not null, - passwd varchar(200) not null, - note varchar(2000), - last_modified date -); - -insert into employee (name, email, passwd) -values ('Martin Elsman', 'mael@it.edu', 'don''t-forget'); - -insert into employee (email, name, passwd, note) -values ('nh@it.edu', 'Niels Hallenberg', 'hi', 'meeting'); diff --git a/smlserver_demo/web_demo_lib/orasql/guest.sql b/smlserver_demo/web_demo_lib/orasql/guest.sql deleted file mode 100644 index 200416e11..000000000 --- a/smlserver_demo/web_demo_lib/orasql/guest.sql +++ /dev/null @@ -1,16 +0,0 @@ -drop sequence guest_seq; - -create table guest ( - gid integer primary key not null, - email varchar(100) not null, - name varchar(100) not null, - comments varchar(2000) not null -); - -insert into guest (gid, email, name, comments) -values (1, - 'homer@simpsons.net', - 'Homer Simpson', - 'Quick, give me the number to 911!'); - -create sequence guest_seq start with 2; diff --git a/smlserver_demo/web_demo_lib/orasql/link.sql b/smlserver_demo/web_demo_lib/orasql/link.sql deleted file mode 100644 index 349d3b09f..000000000 --- a/smlserver_demo/web_demo_lib/orasql/link.sql +++ /dev/null @@ -1,13 +0,0 @@ -drop sequence link_seq; - -create table link ( - link_id int primary key, - person_id int references person not null, - url varchar(200) not null, - text varchar(200) -); - -insert into link (link_id, person_id, url, text) -values (1, 1, 'http://www.smlserver.org', 'The SMLserver web-site'); - -create sequence link_seq start with 2; diff --git a/smlserver_demo/web_demo_lib/orasql/person.sql b/smlserver_demo/web_demo_lib/orasql/person.sql deleted file mode 100644 index c64bd10ab..000000000 --- a/smlserver_demo/web_demo_lib/orasql/person.sql +++ /dev/null @@ -1,19 +0,0 @@ -drop sequence person_seq; - -create sequence person_seq start with 3; - -create table person ( - person_id int primary key, - password varchar(100) not null, - email varchar(20) unique not null, - name varchar(100) not null, - url varchar(200) -); - -insert into person (person_id, password, email, name, url) -values (1, 'Martin', 'mael@it.edu', 'Martin Elsman', - 'http://www.dina.kvl.dk/~mael'); - -insert into person (person_id, password, email, name, url) -values (2, 'Niels', 'nh@it.edu', 'Niels Hallenberg', - 'http://www.it.edu/~nh'); diff --git a/smlserver_demo/web_demo_lib/orasql/rating.sql b/smlserver_demo/web_demo_lib/orasql/rating.sql deleted file mode 100644 index 40cde7b50..000000000 --- a/smlserver_demo/web_demo_lib/orasql/rating.sql +++ /dev/null @@ -1,21 +0,0 @@ -drop sequence wid_sequence; -create sequence wid_sequence; - -create table wine ( - wid integer primary key, - name varchar(100) not null, - year integer, - check ( 1 <= year and year <= 3000 ), - unique ( name, year ) -); - -create table rating ( - wid integer references wine, - comments varchar(1000), - fullname varchar(100), - email varchar(100), - rating integer, - check ( 0 <= rating and rating <= 6 ) -); - - diff --git a/smlserver_demo/web_demo_lib/pgsql/all.sql b/smlserver_demo/web_demo_lib/pgsql/all.sql deleted file mode 100644 index 916c9afbb..000000000 --- a/smlserver_demo/web_demo_lib/pgsql/all.sql +++ /dev/null @@ -1,5 +0,0 @@ -\i person.sql -\i link.sql -\i employee.sql -\i rating.sql -\i guest.sql diff --git a/smlserver_demo/web_demo_lib/pgsql/employee.sql b/smlserver_demo/web_demo_lib/pgsql/employee.sql deleted file mode 100644 index 01656598d..000000000 --- a/smlserver_demo/web_demo_lib/pgsql/employee.sql +++ /dev/null @@ -1,15 +0,0 @@ - drop table employee; - - create table employee ( - email varchar(200) primary key not null, - name varchar(200) not null, - passwd varchar(200) not null, - note varchar(2000), - last_modified date - ); - - insert into employee (name, email, passwd) - values ('Martin Elsman', 'mael@it.edu', 'don''t-forget'); - - insert into employee (email, name, passwd, note) - values ('nh@it.edu', 'Niels Hallenberg', 'hi', 'meeting'); diff --git a/smlserver_demo/web_demo_lib/pgsql/guest.sql b/smlserver_demo/web_demo_lib/pgsql/guest.sql deleted file mode 100644 index 3d584b5d4..000000000 --- a/smlserver_demo/web_demo_lib/pgsql/guest.sql +++ /dev/null @@ -1,17 +0,0 @@ -drop table guest; -drop sequence guest_seq; - -create table guest ( - gid integer primary key not null, - email varchar(100) not null, - name varchar(100) not null, - comments varchar(2000) not null -); - -insert into guest (gid, email, name, comments) -values (1, - 'homer@simpsons.net', - 'Homer Simpson', - 'Quick, give me the number to 911!'); - -create sequence guest_seq start 2; diff --git a/smlserver_demo/web_demo_lib/pgsql/link.sql b/smlserver_demo/web_demo_lib/pgsql/link.sql deleted file mode 100644 index 0d564ec1f..000000000 --- a/smlserver_demo/web_demo_lib/pgsql/link.sql +++ /dev/null @@ -1,14 +0,0 @@ -drop table link; -drop sequence link_seq; - -create table link ( - link_id int primary key, - person_id int references person not null, - url varchar(200) not null, - text varchar(200) -); - -insert into link (link_id, person_id, url, text) -values (1, 1, 'http://www.smlserver.org', 'The SMLserver web-site'); - -create sequence link_seq start 2; diff --git a/smlserver_demo/web_demo_lib/pgsql/person.sql b/smlserver_demo/web_demo_lib/pgsql/person.sql deleted file mode 100644 index bca53940c..000000000 --- a/smlserver_demo/web_demo_lib/pgsql/person.sql +++ /dev/null @@ -1,20 +0,0 @@ -drop table person; -drop sequence person_seq; - -create table person ( - person_id int primary key, - password varchar(100) not null, - email varchar(20) unique not null, - name varchar(100) not null, - url varchar(200) -); - -create sequence person_seq start 3; - -insert into person (person_id, password, email, name, url) -values (1, 'Martin', 'mael@it.edu', 'Martin Elsman', - 'http://www.dina.kvl.dk/~mael'); - -insert into person (person_id, password, email, name, url) -values (2, 'Niels', 'nh@it.edu', 'Niels Hallenberg', - 'http://www.it.edu/~nh'); diff --git a/smlserver_demo/web_demo_lib/pgsql/rating.sql b/smlserver_demo/web_demo_lib/pgsql/rating.sql deleted file mode 100644 index 59fc17560..000000000 --- a/smlserver_demo/web_demo_lib/pgsql/rating.sql +++ /dev/null @@ -1,24 +0,0 @@ -drop table rating; -drop table wine; -drop sequence wid_sequence; - -create sequence wid_sequence; - -create table wine ( - wid integer primary key, - name varchar(100) not null, - year integer, - check ( 1 <= year and year <= 3000 ), - unique ( name, year ) -); - -create table rating ( - wid integer references wine, - comments varchar(1000), - fullname varchar(100), - email varchar(100), - rating integer, - check ( 0 <= rating and rating <= 6 ) -); - - diff --git a/smlserver_demo/web_sys/begin.sml b/smlserver_demo/web_sys/begin.sml deleted file mode 100644 index 84c1663c1..000000000 --- a/smlserver_demo/web_sys/begin.sml +++ /dev/null @@ -1,6 +0,0 @@ -(* This file is used only to find a library file containing an error, which is reported - in the log as for instance: - Warning: script file raised exn - - You can simple place this file in source.pm at various places. *) -val _ = Web.log(Web.Notice,"[Begin evaluating library...") diff --git a/smlserver_demo/web_sys/debug.sml b/smlserver_demo/web_sys/debug.sml deleted file mode 100644 index 5c847c0aa..000000000 --- a/smlserver_demo/web_sys/debug.sml +++ /dev/null @@ -1,6 +0,0 @@ -(* This file is used only to find a library file containing an error, which is reported - in the log as for instance: - Warning: script file raised exn - - You can simple place this file in source.pm at various places. *) -val _ = Web.log(Web.Notice,"Was here...") diff --git a/smlserver_demo/web_sys/end.sml b/smlserver_demo/web_sys/end.sml deleted file mode 100644 index 556857c8e..000000000 --- a/smlserver_demo/web_sys/end.sml +++ /dev/null @@ -1,6 +0,0 @@ -(* This file is used only to find a library file containing an error, which is reported - in the log as for instance: - Warning: script file raised exn - - You can simple place this file in source.pm at various places. *) -val _ = Web.log(Web.Notice,"...End evaluating library]") diff --git a/smlserver_demo/web_sys/init.sml b/smlserver_demo/web_sys/init.sml deleted file mode 100644 index 82cfa367c..000000000 --- a/smlserver_demo/web_sys/init.sml +++ /dev/null @@ -1,35 +0,0 @@ -val _ = Web.log (Web.Notice, "executing init.sml...") -(*val _ = Web.registerTrap "/demo/trap.txt" *) -(*val _ = Web.Info.configSetValue(Web.Info.Type.Int, "SchedulePort", 8040) -val _ = Web.scheduleDaily "/web/log_time.sml" NONE {hour = 15, minute = 2} -val _ = Web.scheduleScript "/web/log_time.sml" NONE 20 *) - -val _ = Web.Info.configSetValue(Web.Info.Type.String, "MailRelay", "mail.itu.dk") -(* -val _ = Db.config(Web.Info.Type.Bool, "LazyConnect", true) -val _ = Db.config(Web.Info.Type.String, "UserName", "testuser") -val _ = Db.config(Web.Info.Type.String, "TNSname", "//localhost/test") -val _ = Db.config(Web.Info.Type.String, "PassWord", "test") -val _ = Db.config(Web.Info.Type.Int, "SessionMaxDepth", 3) -val _ = Db.config(Web.Info.Type.Int, "MinimumNumberOfConnections", 4) -val _ = Db.config(Web.Info.Type.Int, "MaximumNumberOfConnections", 10) -*) - -local - fun conf t (k,v) = - (Web.log (Web.Notice, " Db.config: setting " ^ k); - Db.config(t,k,v)) -in - (* Postgresql configuration *) - val _ = conf Web.Info.Type.String ("DSN", "psql") - val _ = conf Web.Info.Type.String ("UserName", "mael") - val _ = conf Web.Info.Type.String ("PassWord", "hi") - val _ = conf Web.Info.Type.Int ("SessionMaxDepth", 3) -(* - val _ = Web.Info.configSetValue(Web.Info.Type.Bool, "DATABASE_PRINT_SELECT", true) - val _ = Web.Info.configSetValue(Web.Info.Type.Bool, "DATABASE_PRINT_DML", true) - val _ = Web.Info.configSetValue(Web.Info.Type.Bool, "DATABASE_PRINT_EXEC", true) -*) -end - -val _ = Web.log (Web.Notice, "...done executing init.sml") diff --git a/smlserver_demo/web_sys/trap.sml b/smlserver_demo/web_sys/trap.sml deleted file mode 100644 index 5800c407d..000000000 --- a/smlserver_demo/web_sys/trap.sml +++ /dev/null @@ -1,2 +0,0 @@ -val _ = Web.log (Web.Notice, "trap.sml: " ^ Web.Info.pageRoot() ^ Web.Conn.url()) -val _ = Web.returnFile (Web.Info.pageRoot() ^ Web.Conn.url()) diff --git a/smlserver_demo/www/.cvsignore b/smlserver_demo/www/.cvsignore deleted file mode 100644 index 90c0cfde7..000000000 --- a/smlserver_demo/www/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -logtofile.log - PM MLB - run -.xvpics diff --git a/smlserver_demo/www/Makefile b/smlserver_demo/www/Makefile deleted file mode 100644 index 20ea001df..000000000 --- a/smlserver_demo/www/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -#SMLSERVERC=smlserverc -all: - $(MAKE) -C web - $(SMLSERVERC) web.mlb - -clean: - $(MAKE) -C web clean - rm -rf *~ MLB */MLB */*/MLB */*/*/MLB \ No newline at end of file diff --git a/smlserver_demo/www/demo.mlb b/smlserver_demo/www/demo.mlb deleted file mode 100644 index 1902dcbf6..000000000 --- a/smlserver_demo/www/demo.mlb +++ /dev/null @@ -1,79 +0,0 @@ -local - ../lib/lib.mlb -in - local - ../sys/begin.sml - ../demo_lib/Page.sml - ../demo_lib/FormVar.sml - ../demo_lib/Auth.sml - ../demo_lib/RatingUtil.sml - ../sys/end.sml - in - scripts - (* SMLserver System Files *) - ../sys/init.sml - ../sys/trap.sml - - demo/log_time.sml - - demo/guest.sml - demo/guest_add.sml - demo/exchange.sml - demo/regexp.sml - - demo/cache.sml - demo/cache_add.sml - demo/cache_lookup.sml - demo/cache_fib.sml - demo/cache_add_list.sml - demo/cache_lookup_list.sml - demo/cache_add_triple.sml - demo/cache_lookup_triple.sml - - demo/cookie.sml - demo/cookie_set.sml - demo/cookie_delete.sml - demo/db_test.sml - (* demo/db_clob_test.sml Testing Oracle Clobs - not yet supported 2002-09-17, nh *) - demo/index.sml - demo/rating/index.sml - demo/rating/add.sml - demo/rating/add0.sml - demo/rating/wine.sml - demo/employee/index.sml - demo/employee/update.sml - demo/employee/search.sml - demo/time_of_day.sml - demo/guess.sml - demo/counter.sml - demo/temp.sml - demo/recipe.sml - demo/hello.msp.sml (* run "make" to create .msp.sml-files from .msp-files *) - demo/calendar.msp.sml - demo/test.msp.sml - demo/server.sml - demo/mail_form.sml - demo/mail.sml - demo/mul.msp.sml - demo/currency_cache.sml - demo/formvar.sml - demo/formvar_chk.sml - demo/return_file.sml - demo/auth_form.sml - demo/auth_logout.sml - demo/auth.sml - demo/auth_new_form.sml - demo/auth_new.sml - demo/auth_send_form.sml - demo/auth_send.sml - demo/link/index.sml - demo/link/add_form.sml - demo/link/add.sml - demo/link/delete.sml - - demo/upload/upload_form.sml - demo/upload/upload.sml - demo/upload/return_file.sml - end (*scripts*) - end -end diff --git a/smlserver_demo/www/images/index.html b/smlserver_demo/www/images/index.html deleted file mode 100644 index e3c69732a..000000000 --- a/smlserver_demo/www/images/index.html +++ /dev/null @@ -1,17 +0,0 @@ - - - -

SMLserver Logo

- - - -
- -

Powered-by Logos

- - - - -
- - \ No newline at end of file diff --git a/smlserver_demo/www/images/itc_logo_white.png b/smlserver_demo/www/images/itc_logo_white.png deleted file mode 100644 index 854e4ac72..000000000 Binary files a/smlserver_demo/www/images/itc_logo_white.png and /dev/null differ diff --git a/smlserver_demo/www/images/poweredby_smlserver_logo1.png b/smlserver_demo/www/images/poweredby_smlserver_logo1.png deleted file mode 100644 index ed489b7b6..000000000 Binary files a/smlserver_demo/www/images/poweredby_smlserver_logo1.png and /dev/null differ diff --git a/smlserver_demo/www/images/poweredby_smlserver_logo2.png b/smlserver_demo/www/images/poweredby_smlserver_logo2.png deleted file mode 100644 index 026ca9d9a..000000000 Binary files a/smlserver_demo/www/images/poweredby_smlserver_logo2.png and /dev/null differ diff --git a/smlserver_demo/www/images/poweredby_smlserver_logo3.png b/smlserver_demo/www/images/poweredby_smlserver_logo3.png deleted file mode 100644 index 28571f20d..000000000 Binary files a/smlserver_demo/www/images/poweredby_smlserver_logo3.png and /dev/null differ diff --git a/smlserver_demo/www/images/smlserver_logo_color.png b/smlserver_demo/www/images/smlserver_logo_color.png deleted file mode 100644 index c19a16111..000000000 Binary files a/smlserver_demo/www/images/smlserver_logo_color.png and /dev/null differ diff --git a/smlserver_demo/www/images/smlserver_logo_color_medium.png b/smlserver_demo/www/images/smlserver_logo_color_medium.png deleted file mode 100644 index ae1eb6316..000000000 Binary files a/smlserver_demo/www/images/smlserver_logo_color_medium.png and /dev/null differ diff --git a/smlserver_demo/www/images/smlserver_logo_grey.png b/smlserver_demo/www/images/smlserver_logo_grey.png deleted file mode 100644 index 71fad9ceb..000000000 Binary files a/smlserver_demo/www/images/smlserver_logo_grey.png and /dev/null differ diff --git a/smlserver_demo/www/web.mlb b/smlserver_demo/www/web.mlb deleted file mode 100644 index e8bdff7ce..000000000 --- a/smlserver_demo/www/web.mlb +++ /dev/null @@ -1,102 +0,0 @@ -local - $(SML_LIB)/basis/web/lib.mlb - ../web_sys/begin.sml - ../web_demo_lib/Db.sml - ../web_demo_lib/DbClob.sml - ../web_demo_lib/Page.sml - ../web_demo_lib/FormVar.sml - ../web_demo_lib/Auth.sml - ../web_demo_lib/RatingUtil.sml - ../web_sys/end.sml -in - scripts - ../web_sys/init.sml - - web/cookie_delete.sml - web/cookie_set.sml - web/cookie.sml - web/counter.sml - web/server.sml - web/testRedirect.sml - web/testsendfile.sml - web/exchange.sml - web/testinternalredirect.sml - web/test.sml - web/formvar.sml - web/formvar_chk.sml - web/guess.sml - web/log_time.sml - web/recipe.sml - web/regexp.sml - web/temp.sml - web/time_of_day.sml - web/index.sml - web/return_file.sml - web/hello.msp.sml - web/calendar.msp.sml - web/mul.msp.sml - web/mail.sml - web/mail_form.sml - web/test.msp.sml - web/encode.sml - - web/currency_cache.sml - - web/cache.sml - web/cache_add.sml - web/cache_lookup.sml - web/cache_flush.sml - web/cache_fib.sml - web/cache_add_list.sml - web/cache_lookup_list.sml - web/cache_add_triple.sml - web/cache_lookup_triple.sml - - - web/upload/upload_form.sml - web/upload/upload.sml - web/upload/return_file.sml - - web/dnsmx.sml - - web/lowmail.sml - (* web/lmail.sml *) - - web/schedule.sml - - web/guest.sml - web/guest_add.sml - - web/secret/pub.sml - - web/employee/index.sml - web/employee/update.sml - web/employee/search.sml - - web/link/index.sml - web/link/add_form.sml - web/link/add.sml - web/link/delete.sml - - web/db_test.sml - web/db_testPostgreSQL.sml - - web/auth_form.sml - web/auth_logout.sml - web/auth.sml - web/auth_new_form.sml - web/auth_new.sml - web/auth_send_form.sml - web/auth_send.sml - - web/rating/index.sml - web/rating/add.sml - web/rating/add0.sml - web/rating/wine.sml - - web/pwcheck.sml - - web/xmlrpc_test_server.sml - web/xmlrpc_test_client.sml - end (*scripts*) -end diff --git a/smlserver_demo/www/web/Makefile b/smlserver_demo/www/web/Makefile deleted file mode 100644 index 48ac11c53..000000000 --- a/smlserver_demo/www/web/Makefile +++ /dev/null @@ -1,12 +0,0 @@ -FILES=hello.msp calendar.msp test.msp mul.msp -GENFILES=$(FILES:%=%.sml) - -#MSPCOMP=mspcomp - -%.msp.sml: %.msp Makefile - $(MSPCOMP) $< $*.msp.sml - -all: $(GENFILES) - -clean: - rm -f *~ $(GENFILES) \ No newline at end of file diff --git a/smlserver_demo/www/web/applepie.jpg b/smlserver_demo/www/web/applepie.jpg deleted file mode 100644 index 28100ecf9..000000000 Binary files a/smlserver_demo/www/web/applepie.jpg and /dev/null differ diff --git a/smlserver_demo/www/web/auth.sml b/smlserver_demo/www/web/auth.sml deleted file mode 100644 index 450f211fe..000000000 --- a/smlserver_demo/www/web/auth.sml +++ /dev/null @@ -1,36 +0,0 @@ -structure FV = FormVar - -fun redirect() = - (Web.log (Web.Notice,"Redirecting from auth"); - Web.returnRedirect (Web.Conn.location() ^ Auth.loginPage); - Web.exit()) - -val target = case FV.wrapOpt FV.getStringErr "target" - of NONE => redirect() - | SOME t => t - -val email = case FV.wrapOpt FV.getStringErr "email" - of NONE => redirect() - | SOME e => e - -val passwd = case FV.wrapOpt FV.getStringErr "passwd" - of NONE => redirect() - | SOME p => p - -val pid = - case Db.zeroOrOneField `select person_id - from person - where email = ^(Db.qqq email)` - of NONE => "0" - | SOME pid => pid - -val _ = Web.Cookie.deleteCookie{name="auth_person_id",path=SOME "/"} -val _ = Web.Cookie.deleteCookie{name="auth_person_id",path=SOME "/"} -val _ = Web.Cookie.setCookie{name="auth_person_id", value=pid,expiry=NONE, - domain=NONE,path=SOME "/",secure=false} -val _ = Web.Cookie.deleteCookie{name="auth_password",path=SOME "/"} -val _ = Web.Cookie.setCookie{name="auth_password", value=passwd,expiry=NONE, - domain=NONE,path=SOME "/",secure=false} - -val _ = Web.returnRedirect target - diff --git a/smlserver_demo/www/web/auth_form.sml b/smlserver_demo/www/web/auth_form.sml deleted file mode 100644 index f743da211..000000000 --- a/smlserver_demo/www/web/auth_form.sml +++ /dev/null @@ -1,27 +0,0 @@ -val target = - case FormVar.wrapOpt FormVar.getStringErr "target" - of SOME t => t - | NONE => Auth.defaultHome - -val _ = Page.return "Login to SMLserver.org" ` -Enter your email address and password. -
- - - - - - - - - - -
Email address
Password -
- -
-
-If you're not already a member, you may register -by filling out a form.

-You may obtain your password -by email, in case you forgot it.` diff --git a/smlserver_demo/www/web/auth_logout.sml b/smlserver_demo/www/web/auth_logout.sml deleted file mode 100644 index 9a0dfbd3e..000000000 --- a/smlserver_demo/www/web/auth_logout.sml +++ /dev/null @@ -1,6 +0,0 @@ -val target = "/web/link/index.sml" - -val _ = Web.Cookie.deleteCookie{name="auth_password",path=SOME "/"} -val _ = Web.Cookie.deleteCookie{name="auth_person_id",path=SOME "/"} - -val _ = Web.returnRedirect (Web.Conn.location() ^ target) diff --git a/smlserver_demo/www/web/auth_new.sml b/smlserver_demo/www/web/auth_new.sml deleted file mode 100644 index e9f4c8001..000000000 --- a/smlserver_demo/www/web/auth_new.sml +++ /dev/null @@ -1,28 +0,0 @@ -structure FV = FormVar -val email = FV.wrapFail FV.getEmailErr ("email", "Email") -val name = FV.wrapFail FV.getStringErr ("name", "Name") -val url = FV.wrapFail FV.getUrlErr ("url", "Home page URL") - -val passwd = Auth.newPassword 6 - -val ins = - `insert into person (person_id, email, - name, url, password) - values (^(Db.seqNextvalExp "person_seq"), - ^(Db.qqq email), - ^(Db.qqq name), - ^(Db.qqq url), - ^(Db.qqq passwd))` - -val _ = Db.dml ins - handle _ => - (Page.return "Already member" - `The email address ^email is already in the - database - you may have the system - send your password by email.` - ; Web.exit()) - -val _ = Web.returnRedirect - ("auth_send.sml?email=" ^ Web.encodeUrl email) - diff --git a/smlserver_demo/www/web/auth_new_form.sml b/smlserver_demo/www/web/auth_new_form.sml deleted file mode 100644 index d01baca59..000000000 --- a/smlserver_demo/www/web/auth_new_form.sml +++ /dev/null @@ -1,23 +0,0 @@ -val _ = Page.return ("Register at " ^ Auth.siteName) ` -Enter your email address, name, -and home page address. -

- - - - - - - - - - - - -
Email address
Name -
Home Page URL -
- -
-
-When you register, a password is sent to you by email.` diff --git a/smlserver_demo/www/web/auth_send.sml b/smlserver_demo/www/web/auth_send.sml deleted file mode 100644 index eec698b25..000000000 --- a/smlserver_demo/www/web/auth_send.sml +++ /dev/null @@ -1,20 +0,0 @@ -structure FV = FormVar -val email = FV.wrapFail FV.getEmailErr ("email", "Email") - -val query = `select person_id from person - where email = ^(Db.qqq email)` - -val _ = - case Db.zeroOrOneField query - of SOME (p) => - (case Int.fromString p - of SOME pid => - (Auth.sendPassword pid; - Page.return "Email has been sent" - `Please check your mail-box and proceed to the - login page.`) - | NONE => raise Fail "int expected") - | _ => - Page.return "Email not in database" - `Please proceed to the - login page.` diff --git a/smlserver_demo/www/web/auth_send_form.sml b/smlserver_demo/www/web/auth_send_form.sml deleted file mode 100644 index 082de225e..000000000 --- a/smlserver_demo/www/web/auth_send_form.sml +++ /dev/null @@ -1,10 +0,0 @@ -val _ = Page.return "Obtain Password by Email" -`Submit your email address below. -
- -
Email address -

-

- -
-
` \ No newline at end of file diff --git a/smlserver_demo/www/web/bill_guess.jpg b/smlserver_demo/www/web/bill_guess.jpg deleted file mode 100644 index fc54721e7..000000000 Binary files a/smlserver_demo/www/web/bill_guess.jpg and /dev/null differ diff --git a/smlserver_demo/www/web/bill_large.jpg b/smlserver_demo/www/web/bill_large.jpg deleted file mode 100644 index f7b159677..000000000 Binary files a/smlserver_demo/www/web/bill_large.jpg and /dev/null differ diff --git a/smlserver_demo/www/web/bill_small.jpg b/smlserver_demo/www/web/bill_small.jpg deleted file mode 100644 index b4373f084..000000000 Binary files a/smlserver_demo/www/web/bill_small.jpg and /dev/null differ diff --git a/smlserver_demo/www/web/bill_yes.jpg b/smlserver_demo/www/web/bill_yes.jpg deleted file mode 100644 index d0f86505f..000000000 Binary files a/smlserver_demo/www/web/bill_yes.jpg and /dev/null differ diff --git a/smlserver_demo/www/web/cache.sml b/smlserver_demo/www/web/cache.sml deleted file mode 100644 index c4544135d..000000000 --- a/smlserver_demo/www/web/cache.sml +++ /dev/null @@ -1,119 +0,0 @@ -val kind = FormVar.wrapExn (FormVar.getEnumErr ["WhileUsed","TimeOut","Size"]) "kind" - handle _ => "Size" - -fun pp_kind kind = - case kind of - "Size" => `WhileUsed of size 10000 and without timeout` - | _ => `^kind. Entries live in the cache in - approximately 20 seconds.

` - -val _ = Page.return ("Caching Demonstration" ^": cache.sml") - (` - Cache entries map email addresses to pairs of user ids and names.

- - Using cache name users and cache kind: ` ^^ (pp_kind kind) ^^ `

- - The cache has ML type: (string,(int,string)) cache

- - - - - - -
Lookup EntryFlushAdd Entry
-
- - Email

- -

- -
- - -
- 		-
- - - - - - - - -
Email
User id
Name
TimeOut
-

- - You can choose among the following cache kinds: - Size, - WhileUsed, - TimeOut

- -

Memoization

- - - Calculate fib of .

- - - -

Using the List type

- - Using cache name userlist and cache kind: ` ^^ (pp_kind kind) ^^ `

- - The cache has ML type: (string,string list) cache

- - - - - - -
Lookup EntryAdd Entry
-
- - Email

- -

-
- - - - - - - -
Email
Firstnames
Lastname
-

- - -

Using the Triple Type Constructor

- - Using cache name triple and cache kind: ` ^^ (pp_kind kind) ^^ `

- - The cache has ML type: (string,string,int) cache

- - - - - - -
Lookup EntryAdd Entry
-
- - Email

- -

-
- - - - - - - - -
Email
Firstnames
Lastname
User id
-

- - - -`) diff --git a/smlserver_demo/www/web/cache_add.sml b/smlserver_demo/www/web/cache_add.sml deleted file mode 100644 index b56e9eadf..000000000 --- a/smlserver_demo/www/web/cache_add.sml +++ /dev/null @@ -1,39 +0,0 @@ -val kind = Option.valOf (Web.Conn.formvar "kind") handle _ => "Size" - -val cache = - let - val (k,name) = - case kind of - "WhileUsed" => (Web.Cache.WhileUsed (SOME(Time.fromSeconds 20),SOME(10000)),"users1") - | "TimeOut" => (Web.Cache.TimeOut (SOME(Time.fromSeconds 20), SOME(10000)),"users2") - | "Size" => (Web.Cache.WhileUsed (NONE, SOME(10000)),"users3") - in - Web.Cache.get (Web.Cache.String, - Web.Cache.Pair Web.Cache.Int Web.Cache.String, - name, k) - end - -val new_p = (* new_p true if new value added *) - case (Web.Conn.formvar "email", Web.Conn.formvar "name", Web.Conn.formvar "uid", - Web.Conn.formvar "timeout") of - (SOME email, SOME name, SOME uid, SOME timeout) => - Web.Cache.insert(cache,email,(Option.getOpt(Int.fromString uid,0) ,name), - Option.map Time.fromSeconds (LargeInt.fromString timeout)) - | _ => false - -val head = if new_p then "New Value added" - else "Key already in Cache" - -val _ = Page.return ("Caching Demonstration" ^ ": cache_add.sml") - (`^head

- -` (*^^ `Pretty printing the cache: - 

-  ^(Web.Cache.pp_cache cache)
-

`*) ^^ ` - - Go back to Cache Demo Home Page.`) - - - - diff --git a/smlserver_demo/www/web/cache_add_list.sml b/smlserver_demo/www/web/cache_add_list.sml deleted file mode 100644 index c696c5df4..000000000 --- a/smlserver_demo/www/web/cache_add_list.sml +++ /dev/null @@ -1,39 +0,0 @@ -val kind = FormVar.wrapExn (FormVar.getEnumErr ["WhileUsed","TimeOut","Size"]) "kind" - handle _ => "Size" - -val cache = - let - val k = - case kind of - "WhileUsed" => Web.Cache.WhileUsed (SOME(Time.fromSeconds 20), SOME(10000)) - | "TimeOut" => Web.Cache.TimeOut (SOME(Time.fromSeconds 20), SOME(10000)) - | "Size" => Web.Cache.WhileUsed (NONE, SOME(10000)) - in - Web.Cache.get (Web.Cache.String, - Web.Cache.List Web.Cache.String, - "userlist", - k) - end - -val new_p = (* new_p true if new value added *) - case (Web.Conn.formvar "email", Web.Conn.formvar "firstnames", Web.Conn.formvar "lastname") of - (SOME email, SOME firstnames, SOME lastname) => - Web.Cache.insert(cache,email,[lastname,firstnames], NONE) - | _ => false - -val head = if new_p then "New Value added" - else "Key already in Cache" - -val _ = Page.return "Caching Demonstration" - (`^head

- -` ^^(* ` Pretty printing the cache: - 

-  ^(Web.Cache.pp_cache cache)
-

` ^^*) ` - - Go back to Cache Demo Home Page.`) - - - - diff --git a/smlserver_demo/www/web/cache_add_triple.sml b/smlserver_demo/www/web/cache_add_triple.sml deleted file mode 100644 index c34e47c56..000000000 --- a/smlserver_demo/www/web/cache_add_triple.sml +++ /dev/null @@ -1,39 +0,0 @@ -val kind = FormVar.wrapExn (FormVar.getEnumErr ["WhileUsed","TimeOut","Size"]) "kind" - handle _ => "Size" - -val cache = - let - val k = - case kind of - "WhileUsed" => Web.Cache.WhileUsed (SOME(Time.fromSeconds 20), SOME(10000)) - | "TimeOut" => Web.Cache.TimeOut (SOME(Time.fromSeconds 20), SOME(10000)) - | "Size" => Web.Cache.WhileUsed (NONE, SOME(10000)) - in - Web.Cache.get (Web.Cache.String, - Web.Cache.Triple Web.Cache.String Web.Cache.String Web.Cache.Int, - "triple", - k) - end - -val new_p = (* new_p true if new value added *) - case (Web.Conn.formvar "email", Web.Conn.formvar "firstnames", Web.Conn.formvar "lastname",Web.Conn.formvar "uid") of - (SOME email, SOME firstnames, SOME lastname,SOME uid) => - Web.Cache.insert(cache,email,(lastname,firstnames,Option.getOpt(Int.fromString uid,0)),NONE) - | _ => false - -val head = if new_p then "New Value added" - else "Key already in Cache" - -val _ = Page.return "Caching Demonstration" - (`^head

- - ` ^^ (*` Pretty printing the cache: - 

-  ^(Web.Cache.pp_cache cache)
-

` ^^*) ` - - Go back to Cache Demo Home Page.`) - - - - diff --git a/smlserver_demo/www/web/cache_fib.sml b/smlserver_demo/www/web/cache_fib.sml deleted file mode 100644 index 1cf8a5fa9..000000000 --- a/smlserver_demo/www/web/cache_fib.sml +++ /dev/null @@ -1,32 +0,0 @@ -val n = FormVar.wrapExn FormVar.getIntErr "n" - handle _ => 10 - -fun fib 0 = 1 - | fib 1 = 1 - | fib n = fib (n-1) + fib(n-2) - -val cache = - Web.Cache.get (Web.Cache.Int, - Web.Cache.Int, - "fib", - Web.Cache.WhileUsed (SOME(Time.fromSeconds 20), SOME(10000))) - -(* Memorisation *) -fun fib_m 0 = 1 - | fib_m 1 = 1 - | fib_m n = fib' (n-1) + fib' (n-2) -and fib' n = (Web.Cache.memoize cache fib_m) n - -val _ = Page.return "Caching Demonstration - Memorisation" (` - - Result of fib ^(Int.toString n) is ^(Int.toString (fib n)).

- - Result of memorized fib ^(Int.toString n) is ^(Int.toString (fib_m n)).

- -` ^^ (*` - Pretty printing the cache: - 

-  ^(Web.Cache.pp_cache cache)
-

` ^^*) ` - - Go back to Cache Demo Home Page.`) diff --git a/smlserver_demo/www/web/cache_flush.sml b/smlserver_demo/www/web/cache_flush.sml deleted file mode 100644 index b8cbdade6..000000000 --- a/smlserver_demo/www/web/cache_flush.sml +++ /dev/null @@ -1,20 +0,0 @@ -val kind = Option.valOf (Web.Conn.formvar "kind") handle _ => "Size" - -val cache = - let - val (k,name) = - case kind of - "WhileUsed" => (Web.Cache.WhileUsed (SOME(Time.fromSeconds 20),SOME(10000)),"users1") - | "TimeOut" => (Web.Cache.TimeOut (SOME(Time.fromSeconds 20), SOME(10000)),"users2") - | "Size" => (Web.Cache.WhileUsed (NONE, SOME(10000)),"users3") - in - Web.Cache.get (Web.Cache.String, - Web.Cache.Pair Web.Cache.Int Web.Cache.String, - name, k) - end -val _ = Web.Cache.flush(cache) - -val _ = Page.return ("Cache Demonstration" ^": cache_flush.sml") - (`The cache has been flushed. - - Go back to Cache Demo Home Page.`) diff --git a/smlserver_demo/www/web/cache_lookup.sml b/smlserver_demo/www/web/cache_lookup.sml deleted file mode 100644 index 5f68b1ac2..000000000 --- a/smlserver_demo/www/web/cache_lookup.sml +++ /dev/null @@ -1,39 +0,0 @@ -val kind = Option.valOf (Web.Conn.formvar "kind") handle _ => "Size" - -val cache = - let - val (k,name) = - case kind of - "WhileUsed" => (Web.Cache.WhileUsed (SOME(Time.fromSeconds 20),SOME(10000)),"users1") - | "TimeOut" => (Web.Cache.TimeOut (SOME(Time.fromSeconds 20), SOME(10000)),"users2") - | "Size" => (Web.Cache.WhileUsed (NONE, SOME(10000)),"users3") - in - Web.Cache.get (Web.Cache.String, - Web.Cache.Pair Web.Cache.Int Web.Cache.String, - name, k) - end - -fun pp_kind kind = - case kind of - "Size" => `^kind of size 10000` - | _ => `^kind. Entries live in the cache in - approximately 20 seconds.

` - -fun returnPage s = Page.return "Caching Demonstration" - (`^s

- - Using cache kind: ` ^^ (pp_kind kind) ^^ `

- - Go back to Cache Demo Home Page.`) - -val _ = (* new_p is true if new value added *) - case Web.Conn.formvar "email" - of NONE => Web.returnRedirect "cache.sml" - | SOME email => - returnPage - (case Web.Cache.lookup cache email - of SOME(uid,name) => "Name and userid for " ^ email ^ " is: (" ^ name ^ "," ^ (Int.toString uid) ^ ")" - | NONE => "No name in cache for " ^ email) - - - diff --git a/smlserver_demo/www/web/cache_lookup_list.sml b/smlserver_demo/www/web/cache_lookup_list.sml deleted file mode 100644 index 7ca18904e..000000000 --- a/smlserver_demo/www/web/cache_lookup_list.sml +++ /dev/null @@ -1,43 +0,0 @@ -val kind = FormVar.wrapExn (FormVar.getEnumErr ["WhileUsed","TimeOut","Size"]) "kind" - handle _ => "Size" - -val cache = - let - val k = - case kind of - "WhileUsed" => Web.Cache.WhileUsed (SOME(Time.fromSeconds 20), SOME(10000)) - | "TimeOut" => Web.Cache.TimeOut (SOME(Time.fromSeconds 20), SOME(10000)) - | "Size" => Web.Cache.WhileUsed (NONE, SOME(10000)) - in - Web.Cache.get (Web.Cache.String, - Web.Cache.List Web.Cache.String, - "userlist", - k) - end - -fun pp_kind kind = - case kind of - "Size" => `^kind of size 10000` - | _ => `^kind. Entries live in the cache in - approximately 20 seconds.

` - -fun returnPage s = Page.return "Caching Demonstration" - (`^s

- - Using cache kind: ` ^^ (pp_kind kind) ^^ `

- - Go back to Cache Demo Home Page.`) - -val _ = (* new_p is true if new value added *) - case Web.Conn.formvar "email" - of NONE => Web.returnRedirect "cache.sml" - | SOME email => - returnPage - (case Web.Cache.lookup cache email - of SOME [lastname,firstnames] => "Name for " ^ email ^ - " is: (" ^ firstnames ^ "," ^ lastname ^ ")" - | SOME _ => "Mega error in the internal cache representation!!!" - | NONE => "No name in cache for " ^ email) - - - diff --git a/smlserver_demo/www/web/cache_lookup_triple.sml b/smlserver_demo/www/web/cache_lookup_triple.sml deleted file mode 100644 index 63ea567bc..000000000 --- a/smlserver_demo/www/web/cache_lookup_triple.sml +++ /dev/null @@ -1,42 +0,0 @@ -val kind = FormVar.wrapExn (FormVar.getEnumErr ["WhileUsed","TimeOut","Size"]) "kind" - handle _ => "Size" - -val cache = - let - val k = - case kind of - "WhileUsed" => Web.Cache.WhileUsed (SOME(Time.fromSeconds 20), SOME(10000)) - | "TimeOut" => Web.Cache.TimeOut (SOME(Time.fromSeconds 20), SOME(10000)) - | "Size" => Web.Cache.WhileUsed (NONE, SOME(10000)) - in - Web.Cache.get (Web.Cache.String, - Web.Cache.Triple Web.Cache.String Web.Cache.String Web.Cache.Int, - "triple", - k) - end - -fun pp_kind kind = - case kind of - "Size" => `^kind of size 10000` - | _ => `^kind. Entries live in the cache in - approximately 20 seconds.

` - -fun returnPage s = Page.return "Caching Demonstration" - (`^s

- - Using cache kind: ` ^^ (pp_kind kind) ^^ `

- - Go back to Cache Demo Home Page.`) - -val _ = (* new_p is true if new value added *) - case Web.Conn.formvar "email" - of NONE => Web.returnRedirect "cache.sml" - | SOME email => - returnPage - (case Web.Cache.lookup cache email - of SOME (lastname,firstnames,uid) => "Name for " ^ email ^ - " is: (" ^ firstnames ^ "," ^ lastname ^ "," ^ (Int.toString uid) ^ ")" - | NONE => "No name in cache for " ^ email) - - - diff --git a/smlserver_demo/www/web/calendar.msp b/smlserver_demo/www/web/calendar.msp deleted file mode 100644 index 6b9e262c0..000000000 --- a/smlserver_demo/www/web/calendar.msp +++ /dev/null @@ -1,101 +0,0 @@ - 0 orelse y mod 400 = 0 - - fun daysinmonth year = - fn Jan => 31 | Feb => if leap year then 29 else 28 - | Mar => 31 | Apr => 30 | May => 31 | Jun => 30 - | Jul => 31 | Aug => 31 | Sep => 30 | Oct => 31 - | Nov => 30 | Dec => 31 - - val tomonthcode = - fn 1 => Jan | 2 => Feb | 3 => Mar | 4 => Apr | 5 => May | 6 => Jun - | 7 => Jul | 8 => Aug | 9 => Sep | 10 => Oct | 11 => Nov | 12 => Dec - | _ => raise Fail "Illegal month number" - - val frommonthcode = - fn Jan => 1 | Feb => 2 | Mar => 3 | Apr => 4 - | May => 5 | Jun => 6 | Jul => 7 | Aug => 8 - | Sep => 9 | Oct => 10 | Nov => 11 | Dec => 12 - - fun toDatedate (year, month, day) = - date { year = year, month = tomonthcode month, day = day, - hour = 12, minute = 0, second = 0, offset = NONE } - - val wdayno = - fn Mon => 1 | Tue => 2 | Wed => 3 | Thu => 4 - | Fri => 5 | Sat => 6 | Sun => 7 - - val dayheader = tr(prmap (th o $) daynames) - - fun mkmonth (year : int) (month : int) wrap = - let val firstwdayno = wdayno (weekDay (toDatedate (year, month, 1))) - val daysinmonth = daysinmonth year (tomonthcode month) - val days = List.tabulate(firstwdayno-1, fn _ => NONE) - @ List.tabulate(daysinmonth, fn d => SOME(d+1)) - fun makeday NONE = Empty - | makeday (SOME day) = - let val daystring = $ (Int.toString day) - in wrap (year, month, day) daystring end - fun weeks [] = [] - | weeks days = - let val thisweek = List.take(days, Int.min(7, length days)) - val nextweek = List.drop(days, Int.min(7, length days)) - val firstrow = prmap (td o makeday) thisweek - in - firstrow :: weeks nextweek - end - val monthheader = - $$[Vector.sub(monthnames, month-1), " ", Int.toString year] - in - tablea "BORDER" (tr(tha "COLSPAN=7" monthheader) - && dayheader && Nl - && prsep Nl (tra "ALIGN=RIGHT") (weeks days)) - end -in - val today = - let val dt = fromTimeLocal(Time.now()) - in (year dt, frommonthcode (month dt), day dt) end - - fun calmonth year month = - let fun wrap date s = if date = today then strong s else s - in mkmonth year month wrap end - - fun calyear year = - let fun prtab(n, f) = List.foldr (op &&) Empty (List.tabulate(n, f)) - fun mkcalrow r = - tra "VALIGN=TOP" (prtab(3, - fn s => td(calmonth year (3*r+s+1)))) - in - tablea "BORDER" (prtab(4, mkcalrow)) - end - - val year = %%#("year", #1 today); -end -?> - -MSP example: calendar for year <?MSP= Int.toString year ?> - -

MSP example: calendar for year

- - -

- -

Your free bonus: a calendar for a random month

- - - - diff --git a/smlserver_demo/www/web/cookie.sml b/smlserver_demo/www/web/cookie.sml deleted file mode 100644 index aff8a7cd4..000000000 --- a/smlserver_demo/www/web/cookie.sml +++ /dev/null @@ -1,53 +0,0 @@ - val cookies = foldl (fn ((n,v),a) => `
  • ^n : ^v ` ^^ a) - `` (Web.Cookie.allCookies()) - - val _ = Page.return "Cookie Example" - (` -
      ` ^^ cookies ^^ `
    - - Cookies may be added to the list above using the ^`^`Set - Cookie'' form. The name and value attributes are - mandatory and are sequences of characters. The character - sequences are automatically URL-encoded, thus it is - legal to include semi-colon, comma, and white space in - both name and value.

    - - A cookie is removed from the browser when the expiration - date is reached. The life time of a cookie with no - expiry attribute is the user's session. Life times are - given in seconds; the program computes an expiration - date based on the current time and the specified life - time. A cookie may be removed by specifying a negative - life time or by using the ^`^`Delete Cookie'' form.

    - - A cookie may be specified to be secure, which means that - the cookie is transmitted on secure channels only (e.g., - HTTPS requests using SSL). A value of "No" means that - the cookie is sent in clear text on insecure channels - (e.g., HTTP requests).

    - -

    - - - -
    NameValueLife TimeSecure  -
    - - - - -
    -
    - -
    - - - - -
    Name 
    - -
    -
    `) diff --git a/smlserver_demo/www/web/cookie_delete.sml b/smlserver_demo/www/web/cookie_delete.sml deleted file mode 100644 index 7075d5dca..000000000 --- a/smlserver_demo/www/web/cookie_delete.sml +++ /dev/null @@ -1,8 +0,0 @@ -val cn = - case FormVar.wrapOpt FormVar.getStringErr "cookie_name" - of NONE => "CookieName" - | SOME cn => cn - -val _ = Web.Cookie.deleteCookie{name=cn,path=SOME "/"} - -val _ = Web.Conn.returnRedirectWithCode(302, "cookie.sml") diff --git a/smlserver_demo/www/web/cookie_set.sml b/smlserver_demo/www/web/cookie_set.sml deleted file mode 100644 index c6f7bb529..000000000 --- a/smlserver_demo/www/web/cookie_set.sml +++ /dev/null @@ -1,27 +0,0 @@ -structure FV = FormVar - -val cv = case FV.wrapOpt FV.getStringErr "cookie_value" - of NONE => "No Cookie Value Specified" - | SOME cv => cv - -val cn = case FV.wrapOpt FV.getStringErr "cookie_name" - of NONE => "CookieName" - | SOME cn => cn - -val clt = case FV.wrapOpt FV.getIntErr "cookie_lt" - of NONE => 60 - | SOME clt => LargeInt.fromInt clt - -val cs = case FV.wrapOpt FV.getStringErr "cookie_secure" - of SOME "Yes" => true - | _ => false - -val expiry = let open Time Date - in fromTimeUniv(now() + fromSeconds clt) - end - -val cookie = Web.Cookie.setCookie - {name=cn, value=cv, expiry=SOME expiry, - domain=NONE, path=SOME "/", secure=cs} - -val _ = Web.Conn.returnRedirectWithCode(302, "cookie.sml") diff --git a/smlserver_demo/www/web/counter.sml b/smlserver_demo/www/web/counter.sml deleted file mode 100644 index 5b84a6021..000000000 --- a/smlserver_demo/www/web/counter.sml +++ /dev/null @@ -1,14 +0,0 @@ - val counter = Int.toString - (case FormVar.wrapOpt FormVar.getIntErr "counter" - of SOME c => (case Web.Conn.formvar "button" - of SOME "Up" => c + 1 - | SOME "Down" => c - 1 - | _ => c) - | NONE => 0) - - val _ = Page.return ("Count: " ^ counter) - `
    - - - -
    ` diff --git a/smlserver_demo/www/web/currency_cache.html b/smlserver_demo/www/web/currency_cache.html deleted file mode 100644 index ad36b6864..000000000 --- a/smlserver_demo/www/web/currency_cache.html +++ /dev/null @@ -1,52 +0,0 @@ - - -Currency Service - - -

    Currency Exchange Service

    - -This service obtains currency rates from Yaahoo Finance. -Currency rates are cached in approximately 5 minutes, -which increases the efficiency of the service and limits -the burden put on the Yaahoo Finance web server.

    - -

    -
    -Exchange - - - -to - - - - -
    -
    - -

    -Another interesting example of obtaining data from foreign sites is -the Bill Gates Personal -Wealth Clock. - -

    -Served by SMLserver - - diff --git a/smlserver_demo/www/web/currency_cache.sml b/smlserver_demo/www/web/currency_cache.sml deleted file mode 100644 index b4fcaf13a..000000000 --- a/smlserver_demo/www/web/currency_cache.sml +++ /dev/null @@ -1,54 +0,0 @@ - structure C = Web.Cache - - val getReal = FormVar.wrapFail FormVar.getRealErr - val getString = FormVar.wrapFail FormVar.getStringErr - - val a = getReal ("a", "amount") - val s = getString ("s", "source currency") - val t = getString ("t", "target currency") - -(* val url = "http://uk.finance.yahoo.com/m5?s=" ^ - Web.encodeUrl s ^ "&t=" ^ Web.encodeUrl t *) - - val url = "http://uk.finance.yahoo.com/q?s=" ^ - Web.encodeUrl s ^ Web.encodeUrl t ^ "=X" - - fun errPage () = - (Page.return "Currency Service Error" - `The service is currently not available, probably - because we have trouble getting information from - the data source: ^url.` - ; Web.exit()) - - fun getdate () = - Date.fmt "%Y-%m-%d" (Date.fromTimeLocal (Time.now())) - - fun round r = Real.fmt (StringCvt.FIX(SOME 2)) r - -(* val pattern = RegExp.fromString - (".+" ^ s ^ t ^ ".+([0-9]+).([0-9]+).+") *) - - val pattern = RegExp.fromString - (".+Last Trade:" ^ ".+([0-9]+)\\.([0-9]+).+Trade Time.+") - - val cache = C.get (C.String,C.Option C.Real,"currency", - C.TimeOut (SOME(Time.fromSeconds(5*60)), SOME(10000))) - - val fetch = C.memoize cache - (fn url => case Web.fetchUrl url - of NONE => NONE - | SOME pg => - (case RegExp.extract pattern pg - of SOME [r1,r2] => Real.fromString (r1 ^ "." ^ r2) - | _ => NONE)) - - val _ = - case fetch url of - NONE => errPage () - | SOME rate => - Page.return - ("Currency Exchange Service, " ^ getdate()) - `^(Real.toString a) ^s gives ^(round (a*rate)) ^t.

    - The exchange rate is obtained by fetching

    - ^url

    - New Calculation` diff --git a/smlserver_demo/www/web/db_test.sml b/smlserver_demo/www/web/db_test.sml deleted file mode 100644 index b6a2676d9..000000000 --- a/smlserver_demo/www/web/db_test.sml +++ /dev/null @@ -1,357 +0,0 @@ -val _ = Web.return -` - Testing WEB_DB -

    Testing the Database Interface (signature WEB_DB)

    - -The script sends a series of SQL statements to the database; -the result is shown below.

    - -Notice: If you are using MySQL, errors in -the sections testing sequences, panicDmlTrans, and -dmlTrans are expected due to the lack of sequences -and transactions in MySQL.

    ` - -infix 1 seq - -local - val errs = ref 0 - fun add_err () = (errs := !errs + 1; "WRONG") - fun add_err' s = (errs := !errs + 1; "WRONG - " ^ s) -in - fun pp_errs() = - if !errs = 0 then - "There were no errors." - else - "There were " ^ (Int.toString (!errs)) ^ " error(s)." - fun e1 seq e2 = e2; - fun tst0 s s' = let val str = s ^ " — " ^ s' - in Web.log(Web.Notice,str); Web.Conn.write(str ^ "
    \n") - end - fun tstOk s f = tst0 s ((f () seq "OK") handle Fail s => add_err' s | _ => add_err()) - fun tstBool s f = tst0 s ((if f () then "OK" else add_err' "false") handle Fail s => add_err' s | _ => add_err()) - fun tstFail s f = tst0 s ((f () seq add_err()) handle Fail s => "OK - " ^ s | _ => add_err()) -end - -fun log x = Web.log(Web.Debug, x) - -val _ = Web.write `

    The function dml

    ` -val dmlTest = - [tstOk "dmlA1" (fn () =>Db.dml `create table db_test ( id int primary key )`), - (* Creating the same table again should fail *) - tstFail "dmlA2" (fn () =>Db.dml `create table db_test ( id int primary key )`), - (* Syntax error *) - tstFail "dmlA3" (fn () => Db.dml `createe table db_test ( id int primary key )`), - (* Inserting Rows *) - tstOk "dmlB1" (fn () => Db.dml `insert into db_test (id) values (1)`), - (* Fail on primary key constraint *) - tstFail "dmlB2" (fn () => Db.dml `insert into db_test (id) values (1)`), - (* Updating Rows *) - tstOk "dmlC1" (fn () => Db.dml `update db_test set id = 42 where id = '1'`), - (* No fail when no rows are updated *) - tstOk "dmlC2" (fn () => Db.dml `update db_test set id = 3 where id = '1'`), - tstOk "dmlE1" (fn () => Db.dml `drop table db_test`), - (* Dropping the same table again should fail *) - tstFail "dmlE2" (fn () => Db.dml `drop table db_test`)] - -val _ = Web.write `

    The function maybeDml

    ` -val maybeDmlTest = - [tstBool "maybeDmlA1" (fn () =>Db.maybeDml `create table db_test ( id int primary key )` = ()), - (* Creating the same table again should fail but () is returned*) - tstBool "maybeDmlA2" (fn () =>Db.maybeDml `create table db_test ( id int primary key )` = ()), - (* Syntax error - error is suppressed *) - tstBool "maybeDmlA3" (fn () => Db.maybeDml `createe table db_test ( id int primary key )` = ()), - (* Inserting Rows *) - tstBool "maybeDmlB1" (fn () => Db.maybeDml `insert into db_test (id) values (1)` = ()), - (* Fail on primary key constraint - error is suppressed *) - tstBool "maybeDmlB2" (fn () => Db.maybeDml `insert into db_test (id) values (1)` = ()), - (* Updating Rows *) - tstBool "maybeDmlC1" (fn () => Db.maybeDml `update db_test set id = 42 where id = '1'` = ()), - (* No rows are updated *) - tstBool "maybeDmlC2" (fn () => Db.maybeDml `update db_test set id = 3 where id = '1'` = ()), - (* Drop the table *) - tstBool "maybeDmlE1" (fn () => Db.maybeDml `drop table db_test` = ()), - (* Dropping the same table again should fail, but error is suppressed *) - tstBool "maybeDmlE2" (fn () => Db.maybeDml `drop table db_test` = ())] - -val _ = Web.write `

    The function panicDml

    ` -local - val f_count = ref 0 - fun f_panic _ = f_count := !f_count + 1 - val panicDml = Db.panicDml f_panic -in - val panicDmlTest = - [tstBool "panicDmlA1" (fn () => panicDml `create table db_test ( id int primary key )` = () andalso !f_count = 0), - (* Creating the same table again should fail but () is returned*) - tstBool "panicDmlA2" (fn () =>panicDml `create table db_test ( id int primary key )` = () andalso !f_count = 1), - (* Syntax error - error is suppressed *) - tstBool "panicDmlA3" (fn () => panicDml `createe table db_test ( id int primary key )` = () andalso !f_count = 2), - (* Inserting Rows *) - tstBool "panicDmlB1" (fn () => panicDml `insert into db_test (id) values (1)` = () andalso !f_count = 2), - (* Fail on primary key constraint - error is suppressed *) - tstBool "panicDmlB2" (fn () => panicDml `insert into db_test (id) values (1)` = () andalso !f_count = 3), - (* Updating Rows *) - tstBool "panicDmlC1" (fn () => panicDml `update db_test set id = 42 where id = '1'` = () andalso !f_count = 3), - (* No rows are updated *) - tstBool "panicDmlC2" (fn () => panicDml `update db_test set id = 3 where id = '1'` = () andalso !f_count = 3), - (* Drop the table *) - tstBool "panicDmlE1" (fn () => panicDml `drop table db_test` = () andalso !f_count = 3), - (* Dropping the same table again should fail, but error is suppressed *) - tstBool "panicDmlE2" (fn () => panicDml `drop table db_test` = () andalso !f_count = 4)] -end - -val _ = Web.write `

    The function dmlTrans

    ` -val dmlTransTest = - let - fun db_testL () = let val a = Db.list (fn g => g "id") `select id from db_test order by id` - in (List.app (fn x => (log x;())) a; a) - end - in - [tstOk "dmlTransA1" (fn () => Db.dml `create table db_test ( id int primary key )`), - (* Unique Constraint Violated on key id *) - tstFail "dmlTransA2" (fn () => Db.Handle.dmlTrans (fn db => - (Db.Handle.dmlDb db `insert into db_test (id) values ('3')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`))), - tstBool "dmlTransA3" (fn () => db_testL() = []), - (* Ok transaction *) - tstOk "dmlTransA4" (fn () => Db.Handle.dmlTrans (fn db => - (Db.Handle.dmlDb db `insert into db_test (id) values ('3')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('5')`))), - tstBool "dmlTransA5" (fn () => db_testL() = ["3","4","5"]), - (* Syntax Error - and the previous content is maintained *) - tstFail "dmlTransA6" (fn () => Db.Handle.dmlTrans (fn db => - (Db.Handle.dmlDb db `delete from db_test`; - Db.Handle.dmlDb db `inserte into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`))), - tstBool "dmlTransA7" (fn () => db_testL() = ["3","4","5"])] - end - -val _ = Web.write `

    The function panicDmlTrans

    ` -val panicDmlTransTest = - let - fun db_testL () = Db.list (fn g => g "id") `select id from db_test order by id` - val f_count = ref 0 - fun f_panic _ = (f_count := !f_count + 1; true) - val panicDml = Db.Handle.panicDmlTrans f_panic - in - [tstOk "panicDmlTransA1" (fn () => Db.dml `delete from db_test`), - (* Unique Constraint Violated on key id *) - tstBool "panicDmlTransA2" (fn () => panicDml (fn db => - (Db.Handle.dmlDb db `insert into db_test (id) values ('3')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - false)) andalso !f_count = 1), - tstBool "panicDmlTransA3" (fn () => db_testL() = []), - (* Ok transaction *) - tstBool "panicDmlTransA4" (fn () => panicDml (fn db => - (Db.Handle.dmlDb db `insert into db_test (id) values ('3')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('5')`; - true)) andalso !f_count = 1), - tstBool "panicDmlTransA5" (fn () => db_testL() = ["3","4","5"]), - (* Syntax Error - and the previous content is maintained *) - tstBool "panicDmlTransA6" (fn () => panicDml (fn db => - (Db.Handle.dmlDb db `delete from db_test`; - Db.Handle.dmlDb db `inserte into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - false)) andalso !f_count = 2), - tstBool "panicDmlTransA7" (fn () => db_testL() = ["3","4","5"])] - end - -val _ = Web.write `

    The function fold

    ` -val foldTest = - [tstOk "delete" (fn () => Db.dml `delete from db_test`), - tstOk "insert" (fn () => Db.dml `insert into db_test values ('3')`), - tstOk "insert" (fn () => Db.dml `insert into db_test values ('4')`), - tstOk "insert" (fn () => Db.dml `insert into db_test values ('5')`), - tstBool "foldA1" (fn () => Quot.==(Db.fold (fn (g,acc) => acc ^^ ` ^(g "id")`) `` `select id from db_test order by id`, - ` 3 4 5`)), - (* Syntax Error *) - tstFail "foldA2" (fn () => Quot.==(Db.fold (fn (g,acc) => acc ^^ ` ^(g "id")`) `` - `selecte id from db_test order by id`, - ` 3 4 5`)), - (* Empty Result *) - tstBool "foldA3" (fn () => Quot.==(Db.fold (fn (g,acc) => acc ^^ ` ^(g "id")`) `` - `select id from db_test where id > 40 order by id`, ``))] - -val _ = Web.write `

    The function list

    ` -val listTest = - [tstBool "listA1" (fn () => Db.list (fn g => g "id") `select id from db_test order by id` = ["3","4","5"]), - (* Syntax Error *) - tstFail "listA2" (fn () => Db.list (fn g => g "id") `selecte id from db_test order by id` = ["3","4","5"]), - (* Empty Result *) - tstBool "listA3" (fn () => Db.list (fn g => g "id") `select id from db_test where id > 40 order by id` = [])] - -val _ = Web.write `

    The function app

    ` -val appTest = -let - val f_count = ref 0 - fun f g = f_count := !f_count + Option.valOf(Int.fromString (g "id")) -in - [tstBool "appA1" (fn () => (Db.app f `select id from db_test order by id`; - !f_count = 12)), - (* Syntax Error *) - tstFail "appA2" (fn () => Db.app f `selecte id from db_test order by id`), - (* Empty Result *) - tstBool "appA3" (fn () => (Db.list f `select id from db_test where id > 40 order by id`; - !f_count = 12))] -end - -val _ = Web.write `

    The function oneField

    ` -val oneFieldTest = - [tstBool "oneFieldA1" (fn () => Db.oneField (`select id from db_test where id = '3'`) = "3"), - (* Fail on zero rows *) - tstFail "oneFieldA2" (fn () => Db.oneField (`select id from db_test where id = '78'`)), - (* Fail on two rows *) - tstFail "oneFieldA3" (fn () => Db.oneField (`select id from db_test where id > '3'`)), - (* Fail on zero fields - syntax error*) - tstFail "oneFieldA4" (fn () => Db.oneField (`select from db_test where id > '3'`)), - (* Fail on more that one field*) - tstFail "oneFieldA5" (fn () => Db.oneField (`select id, id+id as idd from db_test where id > '3'`))] - -val _ = Web.write `

    The function zeroOrOneField

    ` -val zeroOrOneFieldTest = - [(* One row, one field *) - tstBool "zeroOrOneFieldA1" (fn () => Db.zeroOrOneField (`select id from db_test where id = '3'`) = SOME "3"), - (* Zero rows, one field *) - tstBool "zeroOrOneFieldA2" (fn () => Db.zeroOrOneField (`select id from db_test where id > '33'`) = NONE), - (* Zero rows, many fields *) - tstBool "zeroOrOneFieldA3" (fn () => Db.zeroOrOneField (`select id, id+id as idd from db_test where id > '33'`) = NONE), - (* Fail on two rows *) - tstFail "zeroOrOneFieldA4" (fn () => Db.zeroOrOneField (`select id from db_test where id > '3'`)), - (* Fail on zero fields - syntax error *) - tstFail "zeroOrOneFieldA5" (fn () => Db.zeroOrOneField (`select from db_test where id > '3'`)), - (* Fail on one row and more that one field *) - tstFail "zeroOrOneFieldA6" (fn () => Db.zeroOrOneField (`select id, id+id as idd from db_test where id = '3'`))] - -val _ = Web.write `

    The function oneRow

    ` -val oneRowTest = - [(* One row, one field *) - tstBool "oneRowA1" (fn () => Db.oneRow (`select id from db_test where id = '3'`) = ["3"]), - (* Zero rows *) - tstFail "oneRowA2" (fn () => Db.oneRow (`select id from db_test where id > '33'`)), - (* Fail on two rows *) - tstFail "oneRowA3" (fn () => Db.oneRow (`select id from db_test where id > '3'`)), - (* Fail on zero fields - syntax error *) - tstFail "oneRowA4" (fn () => Db.oneRow (`select from db_test where id > '3'`)), - (* One row, two fields *) - tstBool "oneRowA5" (fn () => Db.oneRow (`select id, id+id as idd from db_test where id = '3'`) = ["3","6"])] - -val _ = Web.write `

    The function oneRow'

    ` -val oneRow'Test = - [(* One row, one field *) - tstBool "oneRow'A1" (fn () => Db.oneRow' (fn g => g "id") `select id from db_test where id = '3'` = "3"), - (* Zero rows *) - tstFail "oneRow'A2" (fn () => Db.oneRow' (fn g => g "id") `select id from db_test where id > '33'`), - (* Fail on two rows *) - tstFail "oneRow'A3" (fn () => Db.oneRow' (fn g => g "id") `select id from db_test where id > '3'`), - (* Fail on zero fields - syntax error *) - tstFail "oneRow'A4" (fn () => Db.oneRow' (fn g => g "id") `select from db_test where id > '3'`), - (* One row, two fields *) - tstBool "oneRow'A5" (fn () => Db.oneRow' (fn g => (g "id", g "idd")) - `select id, id+id as idd from db_test where id = '3'` = ("3","6"))] - -val _ = Web.write `

    The function zeroOrOneRow

    ` -val zeroOrOneRowTest = - [(* One row *) - tstBool "zeroOrOneRowA1" (fn () => Db.zeroOrOneRow (`select id from db_test where id = '3'`) = SOME ["3"]), - (* Zero rows *) - tstBool "zeroOrOneRowA2" (fn () => Db.zeroOrOneRow (`select id from db_test where id > '33'`) = NONE), - (* Fail on two rows *) - tstFail "zeroOrOneRowA3" (fn () => Db.zeroOrOneRow (`select id from db_test where id > '3'`)), - (* Fail on zero fields - syntax error *) - tstFail "zeroOrOneRowA4" (fn () => Db.zeroOrOneRow (`select from db_test where id > '3'`)), - (* One row, two fields *) - tstBool "zeroOrOneRowA5" (fn () => Db.zeroOrOneRow (`select id, id+id as idd from db_test where id = '3'`) = SOME ["3","6"])] - -val _ = Web.write `

    The function zeroOrOneRow'

    ` -val zeroOrOneRow'Test = - [(* One row *) - tstBool "zeroOrOneRow'A1" (fn () => Db.zeroOrOneRow' (fn g => g "id") `select id from db_test where id = '3'` = SOME "3"), - (* Zero rows *) - tstBool "zeroOrOneRow'A2" (fn () => Db.zeroOrOneRow' (fn g => g "id") `select id from db_test where id > '33'` = NONE), - (* Fail on two rows *) - tstFail "zeroOrOneRow'A3" (fn () => Db.zeroOrOneRow' (fn g => g "id") `select id from db_test where id > '3'`), - (* Fail on zero fields - syntax error *) - tstFail "zeroOrOneRow'A4" (fn () => Db.zeroOrOneRow' (fn g => g "id") `select from db_test where id > '3'`), - (* One row, two fields *) - tstBool "zeroOrOneRow'A5" (fn () => Db.zeroOrOneRow' (fn g => (g "id",g "idd")) `select id, id+id as idd from db_test where id = '3'` - = SOME ("3","6"))] - -val _ = Web.write `

    The function existsOneRow

    ` -val existsOneRowTest = - [(* Zero rows *) - tstBool "existsOneRowA1" (fn () => Db.existsOneRow `select id from db_test where id > '40'` = false), - (* One row *) - tstBool "existsOneRowA2" (fn () => Db.existsOneRow `select id from db_test where id = '4'` = true), - (* More than one row*) - tstBool "existsOneRowA3" (fn () => Db.existsOneRow `select id from db_test where id > '3'` = true), - (* Fail on zero fields, syntax error *) - tstFail "existsOneRowA4" (fn () => Db.existsOneRow `select from db_test where id > '3'`)] - -val _ = Web.write `

    Sequences

    ` -val seqTest = - let - fun db_testL () = Db.list (fn g => g "id") `select id from db_test order by id` - in - [tstOk "create sequence" (fn () => Db.dml `create sequence t`), - tstOk "drop table" (fn () => Db.dml `drop table db_test`), - tstOk "create table" (fn () =>Db.dml `create table db_test ( id int primary key )`), - tstOk "seqNextvalExp" (fn () => Db.dml `insert into db_test values (^(Db.seqNextvalExp "t"))`), - tstBool "seqNextvalExp" (fn () => db_testL() = ["1"]), - tstFail "seqCurrvalExp" (fn () => Db.dml `insert into db_test values (^(Db.seqCurrvalExp "t"))`), - tstBool "seqCurrvalExp" (fn () => db_testL() = ["1"]), - tstBool "seqNextval" (fn () => Db.seqNextval "t" = 2), - tstBool "seqCurrval" (fn () => Db.seqCurrval "t" = 2), - tstOk "drop sequence" (fn () => Db.dml `drop sequence t`), - tstOk "drop table" (fn () => Db.dml `drop table db_test`)] - end - -val _ = Web.write `

    Various Functions

    ` -val miscTest = - let - val d = Date.fromTimeLocal(Time.now()) - in - [tstOk "create table" (fn () => Db.dml `create table db_test (d ^(Db.timestampType))`), - tstOk "sysdateExp" (fn () => Db.dml `insert into db_test values (^(Db.sysdateExp))`), - tstBool "qq" (fn () => Db.qq "hi" = "hi"), - tstBool "qq" (fn () => Db.qq "'h'i'" = "''h''i''"), - tstBool "qqq" (fn () => Db.qqq "hi" = "'hi'"), - tstBool "qqq" (fn () => Db.qqq "'h'i'" = "'''h''i'''"), - tstOk "fromDate" (fn () => Db.dml `delete from db_test`), - tstOk "fromDate" (fn () => Db.dml `insert into db_test values (^(Db.fromDate d))`), - tstBool "toDate" (fn () => - case Db.toDate(Db.oneField `select ^(Db.toDateExp "d") from db_test`) of - SOME d_db => Date.year d_db = Date.year d andalso - Date.month d_db = Date.month d andalso - Date.day d_db = Date.day d - | NONE => false), - tstBool "toTimestamp" (fn () => - case Db.toTimestamp(Db.oneField `select ^(Db.toTimestampExp "d") from db_test`) of - SOME t_db => Date.compare(t_db,d) = EQUAL - | NONE => false), - tstBool "toDate" (fn () => case Db.toDate "Not a date" of SOME _ => false | NONE => true), - tstOk "drop table" (fn () => Db.dml `drop table db_test`), - tstOk "create table" (fn () => Db.dml `create table db_test (t varchar(100))`), - tstOk "valueList" (fn () => Db.dml `insert into db_test values (^(Db.valueList ["hi"]))`), - tstBool "valueList" (fn () => Db.oneField `select t from db_test` = "hi"), - tstOk "valueList" (fn () => Db.dml `delete from db_test`), - tstOk "valueList" (fn () => Db.dml `insert into db_test values (^(Db.valueList ["'h'i'"]))`), - tstBool "valueList" (fn () => Db.oneField `select t from db_test` = "'h'i'"), - tstOk "setList" (fn () => Db.dml `update db_test set ^(Db.setList [("t","hi")])`), - tstBool "setList" (fn () => Db.oneField `select t from db_test` = "hi"), - tstOk "setList" (fn () => Db.dml `update db_test set ^(Db.setList [("t","'h'i'")])`), - tstBool "setList" (fn () => Db.oneField `select t from db_test` = "'h'i'")] - end - -val _ = Web.write `

    Table Dropping

    ` - -val dmlTransE1 = tstOk "dmlTransE1" (fn () => Db.dml `drop table db_test`) - -val _ = Web.write `

    Summary

    ^(pp_errs())

    ` - -val _ = Web.write -`

    Served by SMLserver, -Back to index page. -` diff --git a/smlserver_demo/www/web/db_testPostgreSQL.sml b/smlserver_demo/www/web/db_testPostgreSQL.sml deleted file mode 100644 index 2e1c71128..000000000 --- a/smlserver_demo/www/web/db_testPostgreSQL.sml +++ /dev/null @@ -1,439 +0,0 @@ -infix 1 seq - -local - val errs = ref 0 - fun add_err () = (errs := !errs + 1; "WRONG") - fun add_err' s = (errs := !errs + 1; "WRONG - " ^ s) -in - fun pp_errs() = - if !errs = 0 then - "There were no errors." - else - "There were " ^ (Int.toString (!errs)) ^ " error(s)." - fun e1 seq e2 = e2; - fun tst0 s s' = - let val s0 = s ^ " \t" ^ s' - val _ = Web.log(Web.Notice, s0) - in s0 ^ "\n" - end - fun tstOk s f = tst0 s ((f () seq "OK") handle Fail s => add_err' s | _ => add_err()) - fun tstBool s f = tst0 s ((if f () then "OK" else add_err' "false") handle Fail s => add_err' s | _ => add_err()) - fun tstFail s f = tst0 s ((f () seq add_err()) handle Fail s => "OK - " ^ s | _ => add_err()) -end - -fun log x = Web.log(Web.Debug, x) - -fun ppTestRes [] = "" - | ppTestRes (x::xs) = x ^ "
    \n" ^ (ppTestRes xs) - -(* -

    Testing the NS_POOL interface

    - -The following pools are available: ^(Db.Handle.Pool.pp()).

    -^(ppTestRes poolTest) - -(*** Testing Pools ***) -local - val pp = Db.Handle.Pool.pp() - val pools = Db.Handle.Pool.toList() -in - val poolTest = - [(* fetch all pools *) - tstBool "poolA1" (fn () => List.map (fn _ => Db.Handle.Pool.getPool ()) pools = pools), - (* there are no more pools *) - tstBool "poolA2" (fn () => Db.Handle.Pool.toList () = []), - (* fail on fetching yet another pool *) - tstFail "poolA3" (fn () => Db.Handle.Pool.getPool()), - (* put pools back into the set of pools *) - tstOk "poolA4" (fn () => List.app Db.Handle.Pool.putPool (List.rev pools)), - (* all pools are available again. *) - tstBool "poolA5" (fn () => Db.Handle.Pool.toList() = pools), - (* pretty print pools *) - tstBool "poolA6" (fn () => Db.Handle.Pool.pp() = pp)] -end -*) - -(*** Testing dml ***) -val dmlTest = - [tstOk "dmlA1" (fn () =>Db.dml `create table db_test ( id int primary key )`), - (* Creating the same table again should fail *) - tstFail "dmlA2" (fn () =>Db.dml `create table db_test ( id int primary key )`), - (* Syntax error *) - tstFail "dmlA3" (fn () => Db.dml `createe table db_test ( id int primary key )`), - (* Inserting Rows *) - tstOk "dmlB1" (fn () => Db.dml `insert into db_test (id) values (1)`), - (* Fail on primary key constraint *) - tstFail "dmlB2" (fn () => Db.dml `insert into db_test (id) values (1)`), - (* Updating Rows *) - tstOk "dmlC1" (fn () => Db.dml `update db_test set id = 42 where id = '1'`), - (* No fail when no rows are updated *) - tstOk "dmlC2" (fn () => Db.dml `update db_test set id = 3 where id = '1'`), - tstOk "dmlE1" (fn () => Db.dml `drop table db_test`), - (* Dropping the same table again should fail *) - tstFail "dmlE2" (fn () => Db.dml `drop table db_test`)] - -(*** Testing maybeDml ***) -val maybeDmlTest = - [tstBool "maybeDmlA1" (fn () =>Db.maybeDml `create table db_test ( id int primary key )` = ()), - (* Creating the same table again should fail but () is returned*) - tstBool "maybeDmlA2" (fn () =>Db.maybeDml `create table db_test ( id int primary key )` = ()), - (* Syntax error - error is suppressed *) - tstBool "maybeDmlA3" (fn () => Db.maybeDml `createe table db_test ( id int primary key )` = ()), - (* Inserting Rows *) - tstBool "maybeDmlB1" (fn () => Db.maybeDml `insert into db_test (id) values (1)` = ()), - (* Fail on primary key constraint - error is suppressed *) - tstBool "maybeDmlB2" (fn () => Db.maybeDml `insert into db_test (id) values (1)` = ()), - (* Updating Rows *) - tstBool "maybeDmlC1" (fn () => Db.maybeDml `update db_test set id = 42 where id = '1'` = ()), - (* No rows are updated *) - tstBool "maybeDmlC2" (fn () => Db.maybeDml `update db_test set id = 3 where id = '1'` = ()), - (* Drop the table *) - tstBool "maybeDmlE1" (fn () => Db.maybeDml `drop table db_test` = ()), - (* Dropping the same table again should fail, but error is suppressed *) - tstBool "maybeDmlE2" (fn () => Db.maybeDml `drop table db_test` = ())] - -(*** Testing panicDml ***) -local - val f_count = ref 0 - fun f_panic _ = f_count := !f_count + 1 - val panicDml = Db.panicDml f_panic -in - val panicDmlTest = - [tstBool "panicDmlA1" (fn () => panicDml `create table db_test ( id int primary key )` = () andalso !f_count = 0), - (* Creating the same table again should fail but () is returned*) - tstBool "panicDmlA2" (fn () =>panicDml `create table db_test ( id int primary key )` = () andalso !f_count = 1), - (* Syntax error - error is suppressed *) - tstBool "panicDmlA3" (fn () => panicDml `createe table db_test ( id int primary key )` = () andalso !f_count = 2), - (* Inserting Rows *) - tstBool "panicDmlB1" (fn () => panicDml `insert into db_test (id) values (1)` = () andalso !f_count = 2), - (* Fail on primary key constraint - error is suppressed *) - tstBool "panicDmlB2" (fn () => panicDml `insert into db_test (id) values (1)` = () andalso !f_count = 3), - (* Updating Rows *) - tstBool "panicDmlC1" (fn () => panicDml `update db_test set id = 42 where id = '1'` = () andalso !f_count = 3), - (* No rows are updated *) - tstBool "panicDmlC2" (fn () => panicDml `update db_test set id = 3 where id = '1'` = () andalso !f_count = 3), - (* Drop the table *) - tstBool "panicDmlE1" (fn () => panicDml `drop table db_test` = () andalso !f_count = 3), - (* Dropping the same table again should fail, but error is suppressed *) - tstBool "panicDmlE2" (fn () => panicDml `drop table db_test` = () andalso !f_count = 4)] -end - -(*** Testing dmlTrans ***) -val dmlTransTest = - let - fun db_testL () = let val a = Db.list (fn g => g "id") `select id from db_test order by id` - in (List.app (fn x => (log x;())) a; a) - end - in - [tstOk "dmlTransA1" (fn () => Db.dml `create table db_test ( id int primary key )`), - (* Unique Constraint Violated on key id *) - tstFail "dmlTransA2" (fn () => Db.Handle.dmlTrans (fn db => - (Db.Handle.dmlDb db `insert into db_test (id) values ('3')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`))), - tstBool "dmlTransA3" (fn () => db_testL() = []), - (* Ok transaction *) - tstOk "dmlTransA4" (fn () => Db.Handle.dmlTrans (fn db => - (Db.Handle.dmlDb db `insert into db_test (id) values ('3')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('5')`))), - tstBool "dmlTransA5" (fn () => db_testL() = ["3","4","5"]), - (* Syntax Error - and the previous content is maintained *) - tstFail "dmlTransA6" (fn () => Db.Handle.dmlTrans (fn db => - (Db.Handle.dmlDb db `delete from db_test`; - Db.Handle.dmlDb db `inserte into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`))), - tstBool "dmlTransA7" (fn () => db_testL() = ["3","4","5"])] - end - -(*** Testing panicDmlTrans ***) -val panicDmlTransTest = - let - fun db_testL () = Db.list (fn g => g "id") `select id from db_test order by id` - val f_count = ref 0 - fun f_panic _ = (f_count := !f_count + 1; true) - val panicDml = Db.Handle.panicDmlTrans f_panic - in - [tstOk "panicDmlTransA1" (fn () => Db.dml `delete from db_test`), - (* Unique Constraint Violated on key id *) - tstBool "panicDmlTransA2" (fn () => panicDml (fn db => - (Db.Handle.dmlDb db `insert into db_test (id) values ('3')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - false)) andalso !f_count = 1), - tstBool "panicDmlTransA3" (fn () => db_testL() = []), - (* Ok transaction *) - tstBool "panicDmlTransA4" (fn () => panicDml (fn db => - (Db.Handle.dmlDb db `insert into db_test (id) values ('3')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('5')`; - true)) andalso !f_count = 1), - tstBool "panicDmlTransA5" (fn () => db_testL() = ["3","4","5"]), - (* Syntax Error - and the previous content is maintained *) - tstBool "panicDmlTransA6" (fn () => panicDml (fn db => - (Db.Handle.dmlDb db `delete from db_test`; - Db.Handle.dmlDb db `inserte into db_test (id) values ('4')`; - Db.Handle.dmlDb db `insert into db_test (id) values ('4')`; - false)) andalso !f_count = 2), - tstBool "panicDmlTransA7" (fn () => db_testL() = ["3","4","5"])] - end - -(*** Testing fold ***) -val foldTest = - [tstOk "delete" (fn () => Db.dml `delete from db_test`), - tstOk "insert" (fn () => Db.dml `insert into db_test values ('3')`), - tstOk "insert" (fn () => Db.dml `insert into db_test values ('4')`), - tstOk "insert" (fn () => Db.dml `insert into db_test values ('5')`), - tstBool "foldA1" (fn () => Quot.==(Db.fold (fn (g,acc) => acc ^^ ` ^(g "id")`) `` `select id from db_test order by id`, - ` 3 4 5`)), - (* Syntax Error *) - tstFail "foldA2" (fn () => Quot.==(Db.fold (fn (g,acc) => acc ^^ ` ^(g "id")`) `` - `selecte id from db_test order by id`, - ` 3 4 5`)), - (* Empty Result *) - tstBool "foldA3" (fn () => Quot.==(Db.fold (fn (g,acc) => acc ^^ ` ^(g "id")`) `` - `select id from db_test where id > 40 order by id`, ``))] - -(*** Testing list ***) -val listTest = - [tstBool "listA1" (fn () => Db.list (fn g => g "id") `select id from db_test order by id` = ["3","4","5"]), - (* Syntax Error *) - tstFail "listA2" (fn () => Db.list (fn g => g "id") `selecte id from db_test order by id` = ["3","4","5"]), - (* Empty Result *) - tstBool "listA3" (fn () => Db.list (fn g => g "id") `select id from db_test where id > 40 order by id` = [])] - -(*** Testing app ***) -val appTest = -let - val f_count = ref 0 - fun f g = f_count := !f_count + Option.valOf(Int.fromString (g "id")) -in - [tstBool "appA1" (fn () => (Db.app f `select id from db_test order by id`; - !f_count = 12)), - (* Syntax Error *) - tstFail "appA2" (fn () => Db.app f `selecte id from db_test order by id`), - (* Empty Result *) - tstBool "appA3" (fn () => (Db.list f `select id from db_test where id > 40 order by id`; - !f_count = 12))] -end - -(*** Testing oneFieldDb ***) -val oneFieldTest = - [tstBool "oneFieldA1" (fn () => Db.oneField (`select id from db_test where id = '3'`) = "3"), - (* Fail on zero rows *) - tstFail "oneFieldA2" (fn () => Db.oneField (`select id from db_test where id = '78'`)), - (* Fail on two rows *) - tstFail "oneFieldA3" (fn () => Db.oneField (`select id from db_test where id > '3'`)), - (* Fail on zero fields - syntax error*) - tstFail "oneFieldA4" (fn () => Db.oneField (`select from db_test where id > '3'`)), - (* Fail on more that one field*) - tstFail "oneFieldA5" (fn () => Db.oneField (`select id, id+id as idd from db_test where id > '3'`))] - -(*** Testing zeroOrOneFieldDb ***) -val zeroOrOneFieldTest = - [(* One row, one field *) - tstBool "zeroOrOneFieldA1" (fn () => Db.zeroOrOneField (`select id from db_test where id = '3'`) = SOME "3"), - (* Zero rows, one field *) - tstBool "zeroOrOneFieldA2" (fn () => Db.zeroOrOneField (`select id from db_test where id > '33'`) = NONE), - (* Zero rows, many fields *) - tstBool "zeroOrOneFieldA3" (fn () => Db.zeroOrOneField (`select id, id+id as idd from db_test where id > '33'`) = NONE), - (* Fail on two rows *) - tstFail "zeroOrOneFieldA4" (fn () => Db.zeroOrOneField (`select id from db_test where id > '3'`)), - (* Fail on zero fields - syntax error *) - tstFail "zeroOrOneFieldA5" (fn () => Db.zeroOrOneField (`select from db_test where id > '3'`)), - (* Fail on one row and more that one field *) - tstFail "zeroOrOneFieldA6" (fn () => Db.zeroOrOneField (`select id, id+id as idd from db_test where id = '3'`))] - -(*** Testing oneRowDb ***) -val oneRowTest = - [(* One row, one field *) - tstBool "oneRowA1" (fn () => Db.oneRow (`select id from db_test where id = '3'`) = ["3"]), - (* Zero rows *) - tstFail "oneRowA2" (fn () => Db.oneRow (`select id from db_test where id > '33'`)), - (* Fail on two rows *) - tstFail "oneRowA3" (fn () => Db.oneRow (`select id from db_test where id > '3'`)), - (* Fail on zero fields - syntax error *) - tstFail "oneRowA4" (fn () => Db.oneRow (`select from db_test where id > '3'`)), - (* One row, two fields *) - tstBool "oneRowA5" (fn () => Db.oneRow (`select id, id+id as idd from db_test where id = '3'`) = ["3","6"])] - -(*** Testing oneRowDb' ***) -val oneRow'Test = - [(* One row, one field *) - tstBool "oneRow'A1" (fn () => Db.oneRow' (fn g => g "id") `select id from db_test where id = '3'` = "3"), - (* Zero rows *) - tstFail "oneRow'A2" (fn () => Db.oneRow' (fn g => g "id") `select id from db_test where id > '33'`), - (* Fail on two rows *) - tstFail "oneRow'A3" (fn () => Db.oneRow' (fn g => g "id") `select id from db_test where id > '3'`), - (* Fail on zero fields - syntax error *) - tstFail "oneRow'A4" (fn () => Db.oneRow' (fn g => g "id") `select from db_test where id > '3'`), - (* One row, two fields *) - tstBool "oneRow'A5" (fn () => Db.oneRow' (fn g => (g "id", g "idd")) - `select id, id+id as idd from db_test where id = '3'` = ("3","6"))] - -(*** Testing zeroOrOneRowDb ***) -val zeroOrOneRowTest = - [(* One row *) - tstBool "zeroOrOneRowA1" (fn () => Db.zeroOrOneRow (`select id from db_test where id = '3'`) = SOME ["3"]), - (* Zero rows *) - tstBool "zeroOrOneRowA2" (fn () => Db.zeroOrOneRow (`select id from db_test where id > '33'`) = NONE), - (* Fail on two rows *) - tstFail "zeroOrOneRowA3" (fn () => Db.zeroOrOneRow (`select id from db_test where id > '3'`)), - (* Fail on zero fields - syntax error *) - tstFail "zeroOrOneRowA4" (fn () => Db.zeroOrOneRow (`select from db_test where id > '3'`)), - (* One row, two fields *) - tstBool "zeroOrOneRowA5" (fn () => Db.zeroOrOneRow (`select id, id+id as idd from db_test where id = '3'`) = SOME ["3","6"])] - -(*** Testing zeroOrOneRowDb' ***) -val zeroOrOneRow'Test = - [(* One row *) - tstBool "zeroOrOneRow'A1" (fn () => Db.zeroOrOneRow' (fn g => g "id") `select id from db_test where id = '3'` = SOME "3"), - (* Zero rows *) - tstBool "zeroOrOneRow'A2" (fn () => Db.zeroOrOneRow' (fn g => g "id") `select id from db_test where id > '33'` = NONE), - (* Fail on two rows *) - tstFail "zeroOrOneRow'A3" (fn () => Db.zeroOrOneRow' (fn g => g "id") `select id from db_test where id > '3'`), - (* Fail on zero fields - syntax error *) - tstFail "zeroOrOneRow'A4" (fn () => Db.zeroOrOneRow' (fn g => g "id") `select from db_test where id > '3'`), - (* One row, two fields *) - tstBool "zeroOrOneRow'A5" (fn () => Db.zeroOrOneRow' (fn g => (g "id",g "idd")) `select id, id+id as idd from db_test where id = '3'` - = SOME ("3","6"))] - -(*** Testing existsOneRowDb ***) -val existsOneRowTest = - [(* Zero rows *) - tstBool "existsOneRowA1" (fn () => Db.existsOneRow `select id from db_test where id > '40'` = false), - (* One row *) - tstBool "existsOneRowA2" (fn () => Db.existsOneRow `select id from db_test where id = '4'` = true), - (* More than one row*) - tstBool "existsOneRowA3" (fn () => Db.existsOneRow `select id from db_test where id > '3'` = true), - (* Fail on zero fields, syntax error *) - tstFail "existsOneRowA4" (fn () => Db.existsOneRow `select from db_test where id > '3'`)] - -(*** Testing sequences ***) -val seqTest = - let - fun db_testL () = Db.list (fn g => g "id") `select id from db_test order by id` - in - Db.Handle.wrapDb - (fn db => - [tstOk "create sequence" (fn () => Db.dml `create sequence t`), - tstOk "drop table" (fn () => Db.dml `drop table db_test`), - tstOk "create table" (fn () =>Db.dml `create table db_test ( id int primary key )`), - tstOk "seqNextvalExp" (fn () => Db.Handle.dmlDb db `insert into db_test values (^(Db.seqNextvalExp "t"))`), - tstBool "seqNextvalExp" (fn () => db_testL () = ["1"]), - tstFail "seqCurrvalExp" (fn () => Db.Handle.dmlDb db `insert into db_test values (^(Db.seqCurrvalExp "t"))`), - tstBool "seqCurrvalExp" (fn () => db_testL () = ["1"]), - tstBool "seqNextval" (fn () => Db.Handle.seqNextvalDb db "t" = 2), - tstBool "seqCurrval" (fn () => Db.Handle.seqCurrvalDb db "t" = 2), - tstOk "drop sequence" (fn () => Db.dml `drop sequence t`), - tstOk "drop table" (fn () => Db.dml `drop table db_test`)]) - end - -(*** Testing Various Functions ***) -val miscTest = - let - val d = Date.fromTimeLocal(Time.now()) - in - [tstOk "create table" (fn () => Db.dml `create table db_test (d ^(Db.timestampType))`), - tstOk "sysdateExp" (fn () => Db.dml `insert into db_test values (^(Db.sysdateExp))`), - tstBool "qq" (fn () => Db.qq "hi" = "hi"), - tstBool "qq" (fn () => Db.qq "'h'i'" = "''h''i''"), - tstBool "qqq" (fn () => Db.qqq "hi" = "'hi'"), - tstBool "qqq" (fn () => Db.qqq "'h'i'" = "'''h''i'''"), - tstOk "fromDate" (fn () => Db.dml `delete from db_test`), - tstOk "fromDate" (fn () => Db.dml `insert into db_test values (^(Db.fromDate d))`), - tstBool "toDate" (fn () => - case Db.toDate(Db.oneField `select ^(Db.toDateExp "d") from db_test`) of - SOME d_db => Date.year d_db = Date.year d andalso - Date.month d_db = Date.month d andalso - Date.day d_db = Date.day d - | NONE => false), - tstBool "toTimestamp" (fn () => - case Db.toTimestamp(Db.oneField `select ^(Db.toTimestampExp "d") from db_test`) of - SOME t_db => Date.compare(t_db,d) = EQUAL - | NONE => false), - tstBool "toDate" (fn () => case Db.toDate "Not a date" of SOME _ => false | NONE => true), - tstOk "drop table" (fn () => Db.dml `drop table db_test`), - tstOk "create table" (fn () => Db.dml `create table db_test (t varchar(100))`), - tstOk "valueList" (fn () => Db.dml `insert into db_test values (^(Db.valueList ["hi"]))`), - tstBool "valueList" (fn () => Db.oneField `select t from db_test` = "hi"), - tstOk "valueList" (fn () => Db.dml `delete from db_test`), - tstOk "valueList" (fn () => Db.dml `insert into db_test values (^(Db.valueList ["'h'i'"]))`), - tstBool "valueList" (fn () => Db.oneField `select t from db_test` = "'h'i'"), - tstOk "setList" (fn () => Db.dml `update db_test set ^(Db.setList [("t","hi")])`), - tstBool "setList" (fn () => Db.oneField `select t from db_test` = "hi"), - tstOk "setList" (fn () => Db.dml `update db_test set ^(Db.setList [("t","'h'i'")])`), - tstBool "setList" (fn () => Db.oneField `select t from db_test` = "'h'i'")] - end - -(*** End of test ***) -val dmlTransE1 = tstOk "dmlTransE1" (fn () => Db.dml `drop table db_test`) - -val _ = Page.return "Testing the Database Interface (signature NS_DB)" ` - -The script sends a series of SQL statements to the database; -the result is shown below.

    - -^(pp_errs())

    - -Notice: If you are using MySQL, errors in -the sections testing sequences, panicDmlTrans, and -dmlTrans are expected due to the lack of sequences -and transactions in MySQL.

    - -

    Testing the NS_DB interface

    - -

    The function dml

    -^(ppTestRes dmlTest) - -

    The function maybeDml

    -^(ppTestRes maybeDmlTest) - -

    The function panicDml

    -^(ppTestRes panicDmlTest) - -

    The function dmlTrans

    -^(ppTestRes dmlTransTest) - -

    The function panicDmlTrans

    -^(ppTestRes panicDmlTransTest) - -

    The function fold

    -^(ppTestRes foldTest) - -

    The function list

    -^(ppTestRes listTest) - -

    The function app

    -^(ppTestRes appTest) - -

    The function oneField

    -^(ppTestRes oneFieldTest) - -

    The function zeroOrOneField

    -^(ppTestRes zeroOrOneFieldTest) - -

    The function oneRow

    -^(ppTestRes oneRowTest) - -

    The function oneRow'

    -^(ppTestRes oneRow'Test) - -

    The function zeroOrOneRow

    -^(ppTestRes zeroOrOneRowTest) - -

    The function zeroOrOneRow'

    -^(ppTestRes zeroOrOneRow'Test) - -

    The function existsOneRow

    -^(ppTestRes existsOneRowTest) - -

    Testing sequences

    -^(ppTestRes seqTest) - -

    Testing Various Functions

    -^(ppTestRes miscTest) - -

    Dropping test table

    -^dmlTransE1
    -` diff --git a/smlserver_demo/www/web/dnsmx.sml b/smlserver_demo/www/web/dnsmx.sml deleted file mode 100644 index 13a7a9722..000000000 --- a/smlserver_demo/www/web/dnsmx.sml +++ /dev/null @@ -1,35 +0,0 @@ -structure FV = FormVar -structure LM = Web.LowMail - -val input = (Web.log(Web.Debug, "just before FV.getStringErr"); -FV.wrapOpt FV.getStringErr "email") - -val data = Quot.fromString ( - case input of NONE => "" - | SOME(indata) => - let val a = String.fields (fn c => c = #"@") indata - val text = if List.length a <> 2 - then String.concat [indata, " Not a valid email address"] - else - let - val b = LM.getFQDN_MX (List.nth (a,1)) - fun bb ((pref,ttl,server),s) = String.concat - ["
    Priority: ", Int.toString pref, ", Time To Live: ", - Int.toString ttl, ", Server: ", - LM.FQDN_MX_toString (server), s] - in indata ^ ( - case List.length b of 0 => " gave no result" - | 1 => " gave this result " ^ foldr bb "" b - | _ => " gave these results " ^ foldr bb "" b ) - end - in text end - ) - -val _ = - Page.return "DNS Mail eXchange record lookup example" (` - Enter an email address: -
    - - -
    ` ^^ data - ) diff --git a/smlserver_demo/www/web/employee/employee.sql b/smlserver_demo/www/web/employee/employee.sql deleted file mode 100644 index 01656598d..000000000 --- a/smlserver_demo/www/web/employee/employee.sql +++ /dev/null @@ -1,15 +0,0 @@ - drop table employee; - - create table employee ( - email varchar(200) primary key not null, - name varchar(200) not null, - passwd varchar(200) not null, - note varchar(2000), - last_modified date - ); - - insert into employee (name, email, passwd) - values ('Martin Elsman', 'mael@it.edu', 'don''t-forget'); - - insert into employee (email, name, passwd, note) - values ('nh@it.edu', 'Niels Hallenberg', 'hi', 'meeting'); diff --git a/smlserver_demo/www/web/employee/index.sml b/smlserver_demo/www/web/employee/index.sml deleted file mode 100644 index 6745b5c0f..000000000 --- a/smlserver_demo/www/web/employee/index.sml +++ /dev/null @@ -1,8 +0,0 @@ -val _ = Page.return "Search the Employee Database" ` -
    -
    - Email: - -
    -
    ` - diff --git a/smlserver_demo/www/web/employee/search.sml b/smlserver_demo/www/web/employee/search.sml deleted file mode 100644 index 8815dc5c1..000000000 --- a/smlserver_demo/www/web/employee/search.sml +++ /dev/null @@ -1,33 +0,0 @@ - val email = FormVar.wrapFail - FormVar.getStringErr ("email","email") - - val sql = `select name, note - from employee - where email = ^(Db.qqq email)` - - val _ = - (case Db.zeroOrOneRow sql of - SOME [name, note] => - Page.return "Employee Search Success" - `
    - - - - - - - - - - -
    Name:^name
    Email:^email
    Note: -
    Password: - -
    -

    - Try a new search?` - | _ => - Page.return "Employee Search Failure" - `Use the back-button in your Web browser - to go back and enter another email address` -) handle Fail m => Page.return "Fail raised" (Quot.fromString m) diff --git a/smlserver_demo/www/web/employee/update.sml b/smlserver_demo/www/web/employee/update.sml deleted file mode 100644 index 102fb7327..000000000 --- a/smlserver_demo/www/web/employee/update.sml +++ /dev/null @@ -1,17 +0,0 @@ - val getString = FormVar.wrapFail FormVar.getStringErr - - val email = getString ("email","email") - val passwd = getString ("passwd","passwd") - val note = getString ("note", "note") - - val update = `update employee - set note = ^(Db.qqq note) - where email = ^(Db.qqq email) - and passwd = ^(Db.qqq passwd)` - - val _ = - (Db.dml update; - Web.returnRedirect ("search.sml?email=" - ^ Web.encodeUrl email)) - handle _ => - Page.return "Employee Database" `Update failed` diff --git a/smlserver_demo/www/web/encode.sml b/smlserver_demo/www/web/encode.sml deleted file mode 100644 index d0b53b72e..000000000 --- a/smlserver_demo/www/web/encode.sml +++ /dev/null @@ -1,25 +0,0 @@ -structure FV = FormVar - -val encdata = FV.wrapOpt FV.getStringErr "encdata" -val decdata = FV.wrapOpt FV.getStringErr "decdata" - - -val se = case encdata of NONE => "foo" - | SOME(a) => a -val te = case encdata of NONE => `` - | SOME d => Quot.fromString (Web.encodeUrl d ) - -(* -val sd = "a" - *) -val sd = case decdata of NONE => "foo" - | SOME(a) => a -val td = case decdata of NONE => `` - | SOME d => Quot.fromString (Web.decodeUrl d ) - -val _ = Page.return "Encode data" ( -`

    - - - -
    ` ^^ te ^^ `
    ` ^^ td) diff --git a/smlserver_demo/www/web/exchange.sml b/smlserver_demo/www/web/exchange.sml deleted file mode 100644 index 72a601424..000000000 --- a/smlserver_demo/www/web/exchange.sml +++ /dev/null @@ -1,38 +0,0 @@ -structure C = Web.Cache - -val form = - `
    - Dollar amount
    - -
    ` - -val cache = C.get (C.String,C.Option C.Real,"currency", - C.TimeOut (SOME(Time.fromSeconds 300), SOME(10000))) - -fun fetchRate url = - case Web.fetchUrl url of - NONE => NONE - | SOME pg => - let val pattern = RegExp.fromString - ".+USDDKK.+([0-9]+).([0-9]+).+" - in case RegExp.extract pattern pg - of SOME [r1,r2] => Real.fromString (r1^"."^r2) - | _ => NONE - end - -val fetch = C.memoize cache fetchRate - -val url = "http://uk.finance.yahoo.com/m5?s=USD&t=DKK" - -val body = - case FormVar.wrapOpt FormVar.getRealErr "a" of - NONE => form - | SOME a => - case fetch url of - NONE => `The service is currently not available` - | SOME rate => - `^(Real.toString a) USD gives - ^(Real.fmt (StringCvt.FIX(SOME 2)) (a*rate)) DKK. -

    ` ^^ form - -val _ = Page.return "Currency Exchange Service" body diff --git a/smlserver_demo/www/web/formvar.sml b/smlserver_demo/www/web/formvar.sml deleted file mode 100644 index 9fdbeafa3..000000000 --- a/smlserver_demo/www/web/formvar.sml +++ /dev/null @@ -1,25 +0,0 @@ -val _ = Page.return "Checking Form Variables" -`This example serves to demonstrate the extensive -support for form-variable checking in -SMLserver. - -

    - -
    Type an integer -
    Type a positive integer -
    Type a real

    -

    Type a string

    -

    Type a positive integer in the range [2,...,10]

    -

    Type an email

    -

    Type a name

    -

    Type a login

    -

    Type a phone number

    -

    Type an URL

    -

    Choose sex -
    - -
    ` diff --git a/smlserver_demo/www/web/formvar_chk.sml b/smlserver_demo/www/web/formvar_chk.sml deleted file mode 100644 index e694988ec..000000000 --- a/smlserver_demo/www/web/formvar_chk.sml +++ /dev/null @@ -1,92 +0,0 @@ -(* Collect All Errors in one final Error Page *) - -structure FV = FormVar - -val (i,errs) = FV.getIntErr("int","integer",FV.emptyErr) -val (n,errs) = FV.getNatErr("nat","positive integer",errs) -val (r,errs) = FV.getRealErr("real","floating point",errs) -val (str,errs) = FV.getStringErr("str","string",errs) -val (range,errs) = FV.getIntRangeErr 2 10 ("range","range",errs) -val (email,errs) = FV.getEmailErr ("email","an email",errs) -val (name,errs) = FV.getNameErr ("name","first name",errs) -val (login,errs) = FV.getLoginErr ("login","personal login",errs) -val (phone,errs) = FV.getPhoneErr ("phone","Work Phone",errs) -val (url,errs) = FV.getUrlErr ("url", "URL of your private homepage",errs) -val (sex,errs) = FV.getEnumErr ["Female","Male","Unknown"] ("sex", "your sex", errs) -val _ = FV.anyErrors errs - - -(* Show only one error at the time *) -(* -val i = (FV.wrapFail FV.getIntErr) ("int","integer") -val n = (FV.wrapFail FV.getNatErr) ("nat","positive integer") -val r = (FV.wrapFail FV.getRealErr) ("real","floating point") -val str = (FV.wrapFail FV.getStringErr) ("str","string") -val range = (FV.wrapFail (FV.getIntRangeErr 2 10)) ("range","range") -val email = (FV.wrapFail FV.getEmailErr) ("email","an email") -val name = (FV.wrapFail FV.getNameErr) ("name","first name") -val login = (FV.wrapFail FV.getLoginErr) ("login","personal login") -val phone = (FV.wrapFail FV.getPhoneErr) ("phone","Work Phone") -val url = (FV.wrapFail FV.getUrlErr) ("url", "URL of your private homepage") -val sex = (FV.wrapFail (FV.getEnumErr ["Female","Male","Unknown"])) ("sex", "your sex") -*) - -(* Raise Exceptions *) -(* -val i = FV.wrapExn FV.getIntErr "int" -val n = FV.wrapExn FV.getNatErr "nat" -val r = FV.wrapExn FV.getRealErr "real" -val str = FV.wrapExn FV.getStringErr "str" -val range = FV.wrapExn (FV.getIntRangeErr 2 10) "range" -val email = FV.wrapExn FV.getEmailErr "email" -val name = FV.wrapExn FV.getNameErr "name" -val login = FV.wrapExn FV.getLoginErr "login" -val phone = FV.wrapExn FV.getPhoneErr "phone" -val url = FV.wrapExn FV.getUrlErr "url" -val sex = FV.wrapExn (FV.getEnumErr ["Female","Male","Unknown"]) "sex" -*) - -(* Return SOME v on success; otherwise NONE *) -(* -val i = Option.valOf(FV.wrapOpt FV.getIntErr "int") -val n = Option.valOf(FV.wrapOpt FV.getNatErr "nat") -val r = Option.valOf(FV.wrapOpt FV.getRealErr "real") -val str = Option.valOf(FV.wrapOpt FV.getStringErr "str") -val range = Option.valOf(FV.wrapOpt (FV.getIntRangeErr 2 10) "range") -val email = Option.valOf(FV.wrapOpt FV.getEmailErr "email") -val name = Option.valOf(FV.wrapOpt FV.getNameErr "name") -val login = Option.valOf(FV.wrapOpt FV.getLoginErr "login") -val phone = Option.valOf(FV.wrapOpt FV.getPhoneErr "phone") -val url = Option.valOf(FV.wrapOpt FV.getUrlErr "url") -val sex = Option.valOf(FV.wrapOpt (FV.getEnumErr ["Female","Male","Unknown"]) "sex") -*) - -(* The Panic wrapper *) -(* -val i = FV.wrapPanic Page.panic FV.getIntErr "int" -val n = FV.wrapPanic Page.panic FV.getNatErr "nat" -val r = FV.wrapPanic Page.panic FV.getRealErr "real" -val str = FV.wrapPanic Page.panic FV.getStringErr "str" -val range = FV.wrapPanic Page.panic (FV.getIntRangeErr 2 10) "range" -val email = FV.wrapPanic Page.panic FV.getEmailErr "email" -val name = FV.wrapPanic Page.panic FV.getNameErr "name" -val login = FV.wrapPanic Page.panic FV.getLoginErr "login" -val phone = FV.wrapPanic Page.panic FV.getPhoneErr "phone" -val url = FV.wrapPanic Page.panic FV.getUrlErr "url" -val sex = FV.wrapPanic Page.panic (FV.getEnumErr ["Female","Male","Unknown"]) "sex" -*) - -val _ = Page.return "Result of Checking Form Variables" ` -You provided the following information:

    - -The integer: ^(Int.toString i)

    -The positive integer: ^(Int.toString n)

    -The real: ^(Real.toString r)

    -The string: ^str

    -The range value: ^(Int.toString range)

    -The email is: ^email

    -The name is: ^name

    -The login is: ^login

    -The phone number is: ^phone

    -The URL is: ^url

    -The Sex is: ^sex

    ` diff --git a/smlserver_demo/www/web/guess.sml b/smlserver_demo/www/web/guess.sml deleted file mode 100644 index 4f453dcb0..000000000 --- a/smlserver_demo/www/web/guess.sml +++ /dev/null @@ -1,44 +0,0 @@ - (* - fun returnPage title pic body = Web.return - ` - ^title -

    -

    ^title

    - ^(Quot.toString body)

    Served by SMLserver -

    - ` -*) - fun returnPage title pic body = - Page.return title `

    ^(Quot.toString body)

    ` - - fun mk_form (n:int) = - `
    - - - -
    ` - - val _ = - case FormVar.wrapOpt FormVar.getNatErr "n" - of NONE => - returnPage "Guess a number between 0 and 100" - "bill_guess.jpg" - (mk_form (Random.range(0,100) (Random.newgen()))) - - | SOME n => - case FormVar.wrapOpt FormVar.getNatErr "guess" - of NONE => - returnPage "You must type a number - try again" - "bill_guess.jpg" (mk_form n) - | SOME g => - if g > n then - returnPage "Your guess is too big - try again" - "bill_large.jpg" (mk_form n) - else if g < n then - returnPage "Your guess is too small - try again" - "bill_small.jpg" (mk_form n) - else - returnPage "Congratulations!" "bill_yes.jpg" - `You guessed the number ^(Int.toString n)

    - Play again?` diff --git a/smlserver_demo/www/web/guest.sml b/smlserver_demo/www/web/guest.sml deleted file mode 100644 index 6683d1386..000000000 --- a/smlserver_demo/www/web/guest.sml +++ /dev/null @@ -1,30 +0,0 @@ - -val form = - `

    - - - -
    New comment
    -
    Name
    -     		Email
    -
    -
    -
    ` - - fun log x = Web.log(Web.Debug, x) - -fun layoutRow (f,acc) = - case (f "comments", f "name", f "email") of (c, n, e) => - (`
  • ^(c) - -- ^(n) -

    ` ^^ acc) - -val rows = Db.fold layoutRow `` - `select email,name,comments - from guest - order by name` - -val _ = Page.return "Guest Book" - (`

      ` ^^ rows ^^ `
    ` ^^ form) - handle Fail m => Page.return "Error on page" (Quot.fromString m) diff --git a/smlserver_demo/www/web/guest_add.sml b/smlserver_demo/www/web/guest_add.sml deleted file mode 100644 index ffa29ba22..000000000 --- a/smlserver_demo/www/web/guest_add.sml +++ /dev/null @@ -1,12 +0,0 @@ -val rs = FormVar.emptyErr -val (n,rs) = FormVar.getStringErr("n", "Name", rs) -val (c,rs) = FormVar.getStringErr("c", "Comment", rs) -val (e,rs) = FormVar.getEmailErr("e", "Email", rs) -val _ = FormVar.anyErrors rs - -val _ = Db.dml - `insert into guest (gid,name,email,comments) - values (^(Db.seqNextvalExp "guest_seq"),^(Db.qqq n),^(Db.qqq e),^(Db.qqq c))` - -val _ = Web.returnRedirect "guest.sml" - diff --git a/smlserver_demo/www/web/hello.msp b/smlserver_demo/www/web/hello.msp deleted file mode 100644 index e8984d502..000000000 --- a/smlserver_demo/www/web/hello.msp +++ /dev/null @@ -1,9 +0,0 @@ - - -

    Hello world!

    - -The current date and time is - - -
    Your friendly ML server page
    - diff --git a/smlserver_demo/www/web/index.sml b/smlserver_demo/www/web/index.sml deleted file mode 100644 index b00358231..000000000 --- a/smlserver_demo/www/web/index.sml +++ /dev/null @@ -1,60 +0,0 @@ -val examples = - [("Time of day", "time_of_day.sml", []), - ("Count up and down", "counter.sml", []), - ("Temperature conversion", "temp.html", ["temp.sml"]), - ("Dynamic recipe", "recipe.html", ["recipe.sml"]), - ("Guess with Bill", "guess.sml", []), - ("Form variables", "formvar.sml", ["formvar_chk.sml"]), - ("Server information", "server.sml", []), - ("Server schedule test", "schedule.sml", []), - ("Currency service", "currency_cache.html", ["currency_cache.sml"]), - ("Regular Expressions", "regexp.sml", []), - ("Dictionary Cache","cache.sml", ["cache_add.sml","cache_lookup.sml","cache_fib.sml"]), - ("Currency exchange", "exchange.sml", []), - ("DNS Mail eXchange lookup", "dnsmx.sml", []), - ("Send an email", "mail_form.sml", ["mail.sml"]), - ("Guest book (DB)", "guest.sml", ["guest_add.sml"]), - ("Employee search (DB)", "employee/index.sml", ["employee/search.sml","employee/update.sml"]), - ("Best Wines (DB)", "rating/index.sml", ["rating/rating.sql", "rating/add0.sml", - "rating/add.sml", "rating/wine.sml"]), - ("Link database (DB)", "link/index.sml", ["link/add_form.sml", "link/add.sml", - "link/delete.sml"]), - ("Cookie example", "cookie.sml", ["cookie_set.sml", "cookie_delete.sml"]), -(* ("Game of life", "life.sml"), *) - ("Hello world (MSP)", "hello.msp.sml", []), - ("Multiplication (MSP)", "mul.msp.sml", []), - ("Calendars (MSP)", "calendar.msp.sml", []), - ("Tables (MSP)", "test.msp.sml", []), - ("Database testing (DB)", "db_test.sml", []), - ("Database testing (DB PostgreSQL)", "db_testPostgreSQL.sml", []), - ("SMLserver images", "../images/index.html", []), - ("Trap","trap.txt", []), - ("Upload", "upload/upload_form.sml",[]), - ("Check a password", "pwcheck.sml",[]), - ("XML-RPC client and server", "xmlrpc_test_client.sml",["xmlrpc_test_server.sml"]), - ("This index page", "index.sml", [])] - -fun src_link n s = `^(Int.toString n)` - -fun sources n nil = `` - | sources n [s] = src_link n s - | sources n (s::ss) = src_link n s ^^ `, ` ^^ sources (n+1) ss - -fun mkrow (desc, src, srcs) = - `^desc - ` - ^^ sources 1 (src::srcs) ^^ `` - -val _ = Page.return "SMLserver Examples" - (`See the SMLserver - Home Page for SMLserver news and updates.

    - - ` - ^^ Quot.concat (List.map mkrow examples) ^^ - `
    Examplesource
    -

    - Some of the *.msp examples are from the ML - Server Pages (MSP) homepage.`) -val _ = Web.log(Web.Notice,"Before exit") -(*val _ = Web.exit() *) diff --git a/smlserver_demo/www/web/link/add.sml b/smlserver_demo/www/web/link/add.sml deleted file mode 100644 index d000db860..000000000 --- a/smlserver_demo/www/web/link/add.sml +++ /dev/null @@ -1,21 +0,0 @@ -structure FV = FormVar - -val person_id = - case Auth.verifyPerson() - of SOME p => p - | NONE => (Web.returnRedirect Auth.loginPage - ; Web.exit()) - -val url = FV.wrapFail FV.getUrlErr ("url", "URL") -val text = FV.wrapFail FV.getStringErr ("text", "Text") - -val insert = - `insert into link (link_id, person_id, url, text) - values (^(Db.seqNextvalExp "link_seq"), - ^(Int.toString person_id), - ^(Db.qqq url), - ^(Db.qqq text))` - -val _ = Db.dml insert - -val _ = Web.returnRedirect "index.sml" diff --git a/smlserver_demo/www/web/link/add_form.sml b/smlserver_demo/www/web/link/add_form.sml deleted file mode 100644 index e5d0eb23a..000000000 --- a/smlserver_demo/www/web/link/add_form.sml +++ /dev/null @@ -1,18 +0,0 @@ - -val _ = - if Auth.isLoggedIn() then () - else - (Web.returnRedirect - "/web/auth_form.sml?target=/web/link/add_form.sml" - ; Web.exit()) - -val _ = Page.return "Submit Web-site that uses SMLserver" - `You may delete your submission later -

    - -
    URL -
    Text -
    - -
    -
    ` diff --git a/smlserver_demo/www/web/link/delete.sml b/smlserver_demo/www/web/link/delete.sml deleted file mode 100644 index 02b2c504f..000000000 --- a/smlserver_demo/www/web/link/delete.sml +++ /dev/null @@ -1,17 +0,0 @@ - val person_id = - case Auth.verifyPerson() - of SOME p => p - | NONE => (Web.returnRedirect Auth.loginPage - ; Web.exit()) - - val link_id = FormVar.wrapFail - FormVar.getNatErr ("link_id", "Link id") - - val delete = - `delete from link - where person_id = ^(Int.toString person_id) - and link_id = ^(Int.toString link_id)` - - val _ = Db.dml delete - - val _ = Web.returnRedirect "index.sml" diff --git a/smlserver_demo/www/web/link/index.sml b/smlserver_demo/www/web/link/index.sml deleted file mode 100644 index 2da2ebff8..000000000 --- a/smlserver_demo/www/web/link/index.sml +++ /dev/null @@ -1,53 +0,0 @@ -fun log x = Web.log(Web.Debug, x) - -val _ = log ("1") - val person = Auth.verifyPerson() -val _ = log ("1") - -val pid = Web.Info.pid() -val _ = log("pid: " ^ (Int.toString pid)) - - val query = - `select person.person_id, person.name, link_id, - person.url as purl, link.url, link.text - from person, link - where person.person_id = link.person_id` - -val _ = log ("1") - fun delete g = - if Int.fromString (g"person_id") = person - then - ` delete` - else `` - -val _ = log ("1") - fun layoutRow (g, acc) = - `
  • -
    ^(g"text") - added by ^(g"name") - ` ^^ delete g ^^ - `
    ` ^^ acc - -val _ = log ("1") - val loginout = - case person - of NONE => - `To manage links that you have entered, please - login.` - | SOME p => - let val name = Db.oneField - `select name from person - where person_id = ^(Int.toString p)` - in `You are logged in as user ^(name) - you may - logout.` - end - -val _ = log ("2") - val list = Db.fold layoutRow `` query -val _ = log ("3") - - val _ = - Page.return "Web sites that use SMLserver" - (loginout ^^ ``) diff --git a/smlserver_demo/www/web/lmail.sml b/smlserver_demo/www/web/lmail.sml deleted file mode 100644 index 0fbf18366..000000000 --- a/smlserver_demo/www/web/lmail.sml +++ /dev/null @@ -1,13 +0,0 @@ -fun unfold NONE = SOME ({to = ["varming@diku.dk","varming@itu.dk"], from = "varming@acm.org", - subject = "Testing mails", cc = [], bcc = [], body = "Hej nu tester vi 5\r\n.ssd" ^ ((String.str o chr) 163), - extra_headers = []}, SOME (), Web.Mail.ISO88591) - | unfold (SOME _) = NONE - -fun fail (_,l,b) = l @ b - -val (_,b) = Web.Mail.mail unfold fail NONE [] - -fun ppfail pf sf (c,d) = pf ^ "Address: " ^ c ^ " failed with message: " ^ d ^ sf - -val _ = Page.return "Results of sending the mail" - (Quot.fromString (String.concat (map (ppfail "
    " "") b))) diff --git a/smlserver_demo/www/web/log_time.sml b/smlserver_demo/www/web/log_time.sml deleted file mode 100644 index cc8373203..000000000 --- a/smlserver_demo/www/web/log_time.sml +++ /dev/null @@ -1,5 +0,0 @@ -val time_of_day = - Date.fmt "%H.%M.%S" (Date.fromTimeLocal(Time.now())) - -val _ = Web.log(Web.Notice, "Script log_time.sml; time of day: " ^time_of_day) - diff --git a/smlserver_demo/www/web/lowmail.sml b/smlserver_demo/www/web/lowmail.sml deleted file mode 100644 index 490114784..000000000 --- a/smlserver_demo/www/web/lowmail.sml +++ /dev/null @@ -1,42 +0,0 @@ - -val (a,b,c) = List.nth (Web.LowMail.getFQDN_MX "varming.gjk.dk", 0) -val _ = Web.log(Web.Debug, "DNS OK") -val conn = fn () => Web.LowMail.initConn c -val _ = Web.log(Web.Debug, "Initconn OK") -fun pp (((id,res),(b,0))) = ("
    This mail was okeyed: " ^ id ^ ", with response: " ^ res ^ b,0) - | pp (((id,res),(b,1))) = ("
    This mail was tempfail: " ^ id ^ ", with response: " ^ res ^ b,1) - | pp (((id,res),(b,_))) = ("
    This mail was permfail: " ^ id ^ ", with response: " ^ res ^ b,2) - -fun ss mail = (let - val _ = Web.log(Web.Debug, "Sendmail") - val (ok, tmp, perm) = - Web.LowMail.sendmail ([("varming@diku.dk"),("varming@itu.dk")], - "varming@gjk.dk", "From: Carsten Varming \r\nTo: CV " ^ - "\r\n.\r\n", mail) - val _ = Web.log(Web.Debug, "Sendmail OK") - val _ = Web.LowMail.closeConn (mail) - val _ = Web.log(Web.Debug, "connClose OK") - val (oktext,_) = foldr pp("",0) ok - val (tmptext,_) = foldr pp ("",1) tmp - val (permtext,_) = foldr pp ("",2) perm - in (oktext ^ tmptext ^ permtext) - end ) - handle Web.LowMail.ConnectionErr (msg, ok, tmp, perm) => - (let - val _ = Web.log(Web.Debug, "handling exception") - val (oktext,_) = foldr pp("",0) ok - val (tmptext,_) = foldr pp ("",1) tmp - val (permtext,_) = foldr pp ("",2) perm - in ("Exception raised: " ^ msg ^ - " " ^ oktext ^ tmptext ^ permtext) - end) - -val _ = Page.return "Results of sending the mail" - (Quot.fromString ( - let val (mail,str) = (SOME(conn()),"") - handle Web.LowMail.ConnectionErr(msg,_,_,_) => (NONE,"No connection: " ^msg) - in case mail of NONE => str - | SOME(mail') => ss mail' - end - handle Web.LowMail.ConnectionErr (s,_,_,_) => "No mail sent:" ^ s)) - diff --git a/smlserver_demo/www/web/mail.sml b/smlserver_demo/www/web/mail.sml deleted file mode 100644 index 37b6dc01e..000000000 --- a/smlserver_demo/www/web/mail.sml +++ /dev/null @@ -1,14 +0,0 @@ - structure FV = FormVar - - val (to,errs) = FV.getEmailErr ("to", "To", FV.emptyErr) - val (from,errs) = FV.getEmailErr ("from", "From", errs) - val (subj,errs) = FV.getStringErr ("subject", "Subject", errs) - val (body,errs) = FV.getStringErr ("body", "Body", errs) - val () = FV.anyErrors errs - - val _ = Web.Mail.send {to=to, from=from, - subject=subj, body=body} - - val _ = Page.return "Email has been sent" - `Email with subject "^subj" has been sent to ^to.

    - Send another?` diff --git a/smlserver_demo/www/web/mail_form.sml b/smlserver_demo/www/web/mail_form.sml deleted file mode 100644 index 43998e205..000000000 --- a/smlserver_demo/www/web/mail_form.sml +++ /dev/null @@ -1,15 +0,0 @@ - Page.return "Send an email" - `

    - - - - - - -
    To: -
    From: -
    Subject: -
    -
    -
    ` diff --git a/smlserver_demo/www/web/mul.msp b/smlserver_demo/www/web/mul.msp deleted file mode 100644 index 7bdfec14d..000000000 --- a/smlserver_demo/www/web/mul.msp +++ /dev/null @@ -1,23 +0,0 @@ - " - && $(Int.toString (r * c)) - && $"" - fun row sz r = $"" && iter (col r) sz && $"" - in - fun tab sz = iter (row sz) sz - end - ?> - - - -

    Multiplication Table

    -
    -
    Served by SMLserver - - diff --git a/smlserver_demo/www/web/pwcheck.sml b/smlserver_demo/www/web/pwcheck.sml deleted file mode 100644 index 6d762c7df..000000000 --- a/smlserver_demo/www/web/pwcheck.sml +++ /dev/null @@ -1,36 +0,0 @@ -(* uses cracklib2 deb package *) - -fun isNullFP (x : foreignptr) = prim("__is_null",x) : bool - -fun mylog (Fail x) = (Web.log(Web.Notice, x) ; raise Fail x) - | mylog e = raise e - -val b = Web.WebDynlib.dlopen (SOME "libcrack.so", Web.WebDynlib.NOW, false) - handle Fail x => mylog (Fail x) -val a = Web.WebDynlib.dlsym ("testdyn1", "FascistCheck", b) - handle Fail x => mylog (Fail x) - -fun fascistCheck a : string option = - let val b : foreignptr = prim("@:", ("testdyn1", a : string, "/usr/lib/cracklib_dict")) - in if isNullFP b then NONE else SOME(prim ("fromCtoMLstring", b)) - end -structure FV = FormVar -val input = FV.wrapOpt FV.getStringErr "password" - -val data = Quot.fromString ( - case input of NONE => "" - | SOME pw => let val r = fascistCheck pw - in - case r of NONE => "PassWord OK" - | SOME m => "Bad PassWord: " ^ m - end) - -val _ = - Page.return "Password checking" ( - ` - Enter a password: -
    - - -
    ` ^^ data) - diff --git a/smlserver_demo/www/web/rating/add.sml b/smlserver_demo/www/web/rating/add.sml deleted file mode 100644 index d372837e9..000000000 --- a/smlserver_demo/www/web/rating/add.sml +++ /dev/null @@ -1,57 +0,0 @@ - (* Assume either (1) form variable wid is present - * or (2) form variables name and year are present *) - - structure FV = FormVar - - val (wid, name, year) = - case FV.wrapOpt FV.getNatErr "wid" of - SOME wid => (* get name and year *) - let val wid = Int.toString wid - val query = - `select name, year from wine - where wid = ^wid` - in case Db.oneRow query of - [name,year] => (wid, name, year) - | _ => raise Fail "add.sml" - end - | NONE => - let val name = FV.wrapFail - FV.getStringErr ("name","name of wine") - val year = FV.wrapFail - (FV.getIntRangeErr 1 3000) - ("year", "year of wine") - val year = Int.toString year - val query = `select wid from wine - where name = ^(Db.qqq name) - and year = ^(Db.qqq year)` - in - case Db.zeroOrOneRow query of - SOME [wid] => (wid, name, year) - | _ => (* get fresh wid from RDBMS *) - let val wid = Int.toString - (Db.seqNextval "wid_sequence") - val _ = Db.dml - `insert into wine (wid, name, year) - values (^wid, - ^(Db.qqq name), - ^(Db.qqq year))` - in (wid, name, year) - end - end - - (* return forms to the user... *) - val _ = - RatingUtil.returnPageWithTitle - ("Your comments to ``" ^ name ^ " - year " ^ year ^ "''") - `
    - -
    - Email:  -
    - Name:  -
    - Rate (between 0 and 6):  -   - -

    Back to Best Wines -

    ` diff --git a/smlserver_demo/www/web/rating/add0.sml b/smlserver_demo/www/web/rating/add0.sml deleted file mode 100644 index 4abb29394..000000000 --- a/smlserver_demo/www/web/rating/add0.sml +++ /dev/null @@ -1,20 +0,0 @@ - structure FV = FormVar - val comment = FV.wrapFail FV.getStringErr - ("comment", "comment") - val fullname = FV.wrapFail FV.getStringErr - ("fullname", "fullname") - val email = FV.wrapFail FV.getStringErr - ("email", "email") - val wid = Int.toString(FV.wrapFail FV.getNatErr - ("wid","internal number")) - val rating = - Int.toString(FV.wrapFail (FV.getIntRangeErr 0 6) - ("rating","rating")) - - val _ = Db.dml - `insert into rating (wid, comments, fullname, - email, rating) - values (^wid, ^(Db.qqq comment), ^(Db.qqq fullname), - ^(Db.qqq email), ^rating)` - - val _ = Web.returnRedirect "index.sml" diff --git a/smlserver_demo/www/web/rating/index.sml b/smlserver_demo/www/web/rating/index.sml deleted file mode 100644 index 1e3ed9a4e..000000000 --- a/smlserver_demo/www/web/rating/index.sml +++ /dev/null @@ -1,39 +0,0 @@ - (* the complex query that calculates the scores *) - val query = - `select wine.wid, name, year, - avg(rating) as average, - count(*) as ratings - from wine, rating - where wine.wid = rating.wid - group by wine.wid, name, year - order by average desc, name, year` - - fun formatRow (g, acc) = - let val avg = g "average" - val avgInt = - case Int.fromString avg of - SOME i => i - | NONE => case Real.fromString avg of - SOME r => floor r - | NONE => raise Fail "Error in formatRow" - val wid = g "wid" - in acc ^^ - `^(g "name") - (year ^(g "year")) - ^(RatingUtil.bottleImgs avgInt) - ^(g "ratings") - rate it` - end - - val _ = RatingUtil.returnPageWithTitle "Best Wines" - (` -
    WineAverage Score (out of 6) - Ratings ` ^^ - (Db.fold formatRow `` query) ^^ - `
    -
    -

    Rate new wine - type its name and year

    - Name:  - Year:  - -
    `) diff --git a/smlserver_demo/www/web/rating/rating.sql b/smlserver_demo/www/web/rating/rating.sql deleted file mode 100644 index a733820fc..000000000 --- a/smlserver_demo/www/web/rating/rating.sql +++ /dev/null @@ -1,24 +0,0 @@ -drop table rating; -drop table wine; -drop sequence wid_sequence; - -create sequence wid_sequence; - -create table wine ( - wid integer primary key, - name varchar(100) not null, - year integer, - check ( 0 <= year and year <= 3000 ), - unique ( name, year ) -); - -create table rating ( - wid integer references wine, - comment varchar(1000), - fullname varchar(100), - email varchar(100), - rating integer, - check ( 0 <= rating and rating <= 6 ) -); - - diff --git a/smlserver_demo/www/web/rating/wine.jpg b/smlserver_demo/www/web/rating/wine.jpg deleted file mode 100644 index ba2797240..000000000 Binary files a/smlserver_demo/www/web/rating/wine.jpg and /dev/null differ diff --git a/smlserver_demo/www/web/rating/wine.sml b/smlserver_demo/www/web/rating/wine.sml deleted file mode 100644 index 5ce59ab46..000000000 --- a/smlserver_demo/www/web/rating/wine.sml +++ /dev/null @@ -1,33 +0,0 @@ - (* Present comments and ratings for a specific wine *) - val wid = FormVar.wrapFail FormVar.getNatErr - ("wid","internal number") - - val query = - `select comments, fullname, email, rating - from rating - where wid = ^(Int.toString wid)` - - val lines = Db.fold - (fn (g,r) => - let val rating = - case Int.fromString (g "rating") of - SOME i => i - | NONE => raise Fail "Rating not integer" - in - ` ^(RatingUtil.bottleImgs rating) - ^(g "comments") - ^(RatingUtil.mailto (g "email") (g "fullname"))` - end ^^ r) `` query - - val body = - ` -
    RatingCommentRater` ^^ lines ^^ - `
    -

    Back to Best Wines` - - val name = Db.oneField - `select name from wine - where wid = ^(Int.toString wid)` - - val _ = RatingUtil.returnPageWithTitle - ("Ratings - " ^ name) body \ No newline at end of file diff --git a/smlserver_demo/www/web/recipe.html b/smlserver_demo/www/web/recipe.html deleted file mode 100644 index 4477770a0..000000000 --- a/smlserver_demo/www/web/recipe.html +++ /dev/null @@ -1,11 +0,0 @@ - - -

    Dynamic Recipe: Apple Pie

    - Enter the number of people you're inviting for apple pie: -
    - - -
    Served by - SMLserver - - diff --git a/smlserver_demo/www/web/recipe.sml b/smlserver_demo/www/web/recipe.sml deleted file mode 100644 index f0cef5e8f..000000000 --- a/smlserver_demo/www/web/recipe.sml +++ /dev/null @@ -1,41 +0,0 @@ - fun error s = - (Page.return ("Error: " ^ s) - `An error occurred while generating a recipe for - you; use your browser's back-button to backup - and enter a number in the form.` - ; Web.exit()) - - val persons = - case FormVar.wrapOpt FormVar.getNatErr "persons" - of SOME n => real n - | NONE => error "You must type a number" - - fun pr_num s r = - if Real.== (r,1.0) then "one " ^ s - else - if Real.==(real(round r),r) then - Int.toString (round r) ^ " " ^ s ^ "s" - else Real.toString r ^ " " ^ s ^ "s" - - val _ = Page.return "Apple Pie Recipe" - `To make an Apple pie for ^(pr_num "person" persons), you - need the following ingredients: -
      - -
    • ^(pr_num "cup" (persons / 16.0)) butter -
    • ^(pr_num "cup" (persons / 4.0)) sugar -
    • ^(pr_num "egg" (persons / 4.0)) -
    • ^(pr_num "teaspoon" (persons / 16.0)) salt -
    • ^(pr_num "teaspoon" (persons / 4.0)) cinnamon -
    • ^(pr_num "teaspoon" (persons / 4.0)) baking soda -
    • ^(pr_num "cup" (persons / 4.0)) flour -
    • ^(pr_num "cup" (2.5 * persons / 4.0)) diced apples -
    • ^(pr_num "teaspoon" (persons / 4.0)) vanilla -
    • ^(pr_num "tablespoon" (persons / 2.0)) hot water -
    - - Combine ingredients in order given. Bake in greased 9-inch - pie pans for 45 minutes at 350F. Serve warm with whipped - cream or ice cream.

    - - Make another recipe.` diff --git a/smlserver_demo/www/web/regexp.sml b/smlserver_demo/www/web/regexp.sml deleted file mode 100644 index 6ce4c09ef..000000000 --- a/smlserver_demo/www/web/regexp.sml +++ /dev/null @@ -1,41 +0,0 @@ -fun do_regExpBool p s = - "RegExp.match \"" ^ p ^ "\" \"" ^ s ^ "\" gives " ^ - (Bool.toString (RegExp.match (RegExp.fromString p) s)) ^ "
    \n" - -fun do_regExp p s = - let - fun pl' [] = "" - | pl' [x] = "\"" ^ x ^ "\"" - | pl' (x::xs) = "\"" ^ x ^ "\", " ^ (pl' xs) - fun pl NONE = "No Result" - | pl (SOME l) = pl' l - in - "RegExp.extract \"" ^ p ^ "\" \"" ^ s ^ "\" gives [" ^ - (pl (RegExp.extract (RegExp.fromString p) s)) ^ "]
    \n" - end - -val emailp = "([a-zA-Z][0-9a-zA-Z._]*)@([0-9a-zA-Z._]+)" -val _ = - Page.return "RegExp examples" - `

    Function RegExp.match

    - ^(do_regExpBool "[0-9]+" "99") - ^(do_regExpBool "[0-9]+" "aa99AA") - ^(do_regExpBool "[0-9]+.*" "99AA") - ^(do_regExpBool "[0-9]+" "99AA") - ^(do_regExpBool "[0-9]+" "aa99") - -

    Function RegExp.extract

    - ^(do_regExp "Name: ([a-zA-Z ]+);Tlf: ([0-9 ]+)" "Name: Hans Hansen;Tlf: 66 66 66 66") - ^(do_regExp emailp "name@company.com") - ^(do_regExp emailp "name@company@com") - -

    A group that takes part in a match repeatedly

    - ^(do_regExpBool "(a(b+))+" "abbabbb") - ^(do_regExp "(a(b+))+" "abbabbb") - - ^(do_regExpBool "(([a-zA-Z][0-9a-zA-Z._]*)@[0-9a-zA-Z._]+,?)*" "joe@it.edu,sue@id.edu,pat@it.edu") - ^(do_regExp "(([a-zA-Z][0-9a-zA-Z._]*)@[0-9a-zA-Z._]+,?)*" "joe@it.edu,sue@id.edu,pat@it.edu") - -

    A group that does not take part in a match

    - ^(do_regExp "(ab)|(cd)" "cd") - ^(do_regExp "(ab)|(cd)" "ab")` diff --git a/smlserver_demo/www/web/return_file.sml b/smlserver_demo/www/web/return_file.sml deleted file mode 100644 index 0cace39d5..000000000 --- a/smlserver_demo/www/web/return_file.sml +++ /dev/null @@ -1,12 +0,0 @@ -val (path,errs) = FormVar.getStringErr("path","path",FormVar.emptyErr) -val _ = FormVar.anyErrors errs - -val {isAbs,vol,arcs} = Path.fromString path - -val _ = - if Path.isAbsolute path orelse List.exists (fn arc => arc = Path.parentArc) arcs then - Page.return "Return File" `The path ^path may not be absolute and - may not contain parent arcs (..)

    - You must specify a path relative to the server pageroot.` - else - Web.Conn.returnFile(200,"text/plain",Path.concat (Web.Info.pageRoot(),path)) diff --git a/smlserver_demo/www/web/schedule.sml b/smlserver_demo/www/web/schedule.sml deleted file mode 100644 index 48f0603fe..000000000 --- a/smlserver_demo/www/web/schedule.sml +++ /dev/null @@ -1,39 +0,0 @@ -structure FV = FormVar - -fun toint x = Option.getOpt (Option.map Int.fromString x, NONE) - -fun optionapp f NONE = () - | optionapp f (SOME a) = f a - -val first = toint (FV.wrapOpt FV.getStringErr "first") -val interval = toint (FV.wrapOpt FV.getStringErr "interval") -val script = FV.wrapOpt FV.getStringErr "script" -val kind = FV.wrapOpt FV.getStringErr "kind" - -val _ = case kind of NONE => () - | SOME("reg") => ( - case (first,interval,script) of - (SOME(f), SOME(i), SOME(s)) => - Web.schedule s NONE - (Date.fromTimeUniv(Time.+(Time.now(), Time.fromSeconds (LargeInt.fromInt f)))) - (Time.fromSeconds (LargeInt.fromInt i)) - | _ => ()) - | SOME ("cancel") => optionapp Web.deSchedule script - | SOME _ => () - -val _ = Page.return "Schedule frontend" -` -

    - - -
    FirstIntervalScriptAction -
    - - - -
    -
    -` - diff --git a/smlserver_demo/www/web/secret/pub.sml b/smlserver_demo/www/web/secret/pub.sml deleted file mode 100644 index 7bd6525ae..000000000 --- a/smlserver_demo/www/web/secret/pub.sml +++ /dev/null @@ -1,7 +0,0 @@ -fun url (x : string ,y) = y ^^ `Url ^(x) ` - -val _ = Page.return "Information" (` - ` -^^ (foldl url `` (Web.Conn.url())) ^^ -`
    `) - diff --git a/smlserver_demo/www/web/server.sml b/smlserver_demo/www/web/server.sml deleted file mode 100644 index 406a4c315..000000000 --- a/smlserver_demo/www/web/server.sml +++ /dev/null @@ -1,61 +0,0 @@ -fun url (x : string ,y) = y ^^ `Url ^(x) ` - -val _ = Page.return "Server Information" (` - - - - - - - -
    Hostname ^(Web.Info.hostname())
    Pid ^(Int.toString (Web.Info.pid()))
    Uptime (seconds) ^(Int.toString (Web.Info.uptime()))
    Pageroot ^(Web.Info.pageRoot())
    User ^(Option.getOpt(Web.Info.getUser(),""))
    AuthType ^(Option.getOpt(Web.Info.getAuthType(),""))
    - -

    Connection Information

    - - - -` -^^ (foldl url `` (Web.Conn.url())) ^^ -` - - - - -
    Scheme ^(Web.Conn.scheme())
    Host ^(Web.Conn.host())
    Location ^(Web.Conn.location())
    Peer ^(Web.Conn.peer())
    Server Port ^(Int.toString (Web.Conn.port()))
    Server Name ^(Web.Conn.server())
    Method ^(Web.Conn.method())
    Content Length ^(Int.toString(Web.Conn.contentLength()))
    - -

    Headers Information

    - - -^(concat(Web.Set.foldr(fn ((k,v),acc) => - "" :: acc) - nil (Web.Conn.headers()))) -
    KeyValue
    " :: k :: "" :: v :: "
    - -

    Form Data

    - - -^(case Web.Conn.getQuery() - of SOME s => - concat(Web.Set.foldr(fn ((k,v),acc) => - "" :: acc) - nil s) - | NONE => "") -
    KeyValue
    " :: k :: "" :: v :: "
    No form data
    - -

    Some Configuration Information

    - - - -
    MailRelay ^(case Web.Info.configGetValue(Web.Info.Type.String, "MailRelay") - of NONE => " " - | SOME(s) => s)
    Number of heap caches ^(Int.toString (Option.valOf - (Web.Info.configGetValue - (Web.Info.Type.Int,"MaxHeapPoolSz"))))
    - -

    Request Data

    - - -
    ^(Web.Conn.getRequestData()) -
    -` -) diff --git a/smlserver_demo/www/web/temp.html b/smlserver_demo/www/web/temp.html deleted file mode 100644 index 61b7df5a0..000000000 --- a/smlserver_demo/www/web/temp.html +++ /dev/null @@ -1,11 +0,0 @@ - - -

    Temperature Conversion

    - Enter a temperature in degrees Celcius: -
    - - -
    Served by SMLserver - - diff --git a/smlserver_demo/www/web/temp.sml b/smlserver_demo/www/web/temp.sml deleted file mode 100644 index 25b685ed7..000000000 --- a/smlserver_demo/www/web/temp.sml +++ /dev/null @@ -1,14 +0,0 @@ - fun calculate c = concat - [" ", - "

    Temperature Conversion

    ", - Int.toString c, " degrees Celcius equals ", - Int.toString (9 * c div 5 + 32), - " degrees Fahrenheit.

    Go ", - "calculate a new temperature.", - "

    Served by ", - "SMLserver "] - - val _ = Web.Conn.return - (case FormVar.wrapOpt FormVar.getIntErr "temp_c" - of NONE => "Go back and enter an integer!" - | SOME i => calculate i) diff --git a/smlserver_demo/www/web/test.html b/smlserver_demo/www/web/test.html deleted file mode 100644 index 87ca7e79d..000000000 --- a/smlserver_demo/www/web/test.html +++ /dev/null @@ -1,52 +0,0 @@ - - -Currency Service - - -

    Currency Exchange Service

    - -This service obtains currency rates from Yaahoo Finance. -Currency rates are cached in approximately 5 minutes, -which increases the efficiency of the service and limits -the burden put on the Yaahoo Finance web server.

    - -

    -
    -Exchange - - - -to - - - - -
    -
    - -

    -Another interesting example of obtaining data from foreign sites is -the Bill Gates Personal -Wealth Clock. - -

    -Served by SMLserver - - diff --git a/smlserver_demo/www/web/test.msp b/smlserver_demo/www/web/test.msp deleted file mode 100644 index 5e4db6c3f..000000000 --- a/smlserver_demo/www/web/test.msp +++ /dev/null @@ -1,101 +0,0 @@ - -MSP examples: generating tables in various styles - - -

    MSP examples: generating tables in various styles

    - -This page was generated to illustrate ML Server Pages. - -"; print (Int.toString (opr(r,s)))) - fun mkhead i = (print ""; print (Int.toString i)) - fun mkrow m r = (print ""; mkhead r; - List.tabulate(m, mkcell r); print "\n") - in - print "
    "; print oprname; - List.tabulate(m, mkhead); print "\n"; - List.tabulate(n, mkrow m); - print "
    " - end -?> - -" && $ (Int.toString (opr(r,s))) - fun mkhead i = $ "" && $ (Int.toString i) - fun tabulate(n, f) = List.foldr (op&&) Empty (List.tabulate(n, f)) - fun mkrow m r = $ "" && mkhead r && tabulate(m, mkcell r) && Nl - in - $ "
    " && $ oprname && tabulate(m, mkhead) && Nl - && tabulate(n, mkrow m) - && $"
    " - end -?> - - - - - -

    A multiplication table (generated by imperative code)

    - - - -

    A multiplication table (generated by functional code)

    - - - -

    An addition table (generated by functional code)

    - - - -

    A subtraction table (generated by functional code using Msp HTML functions)

    - - - -

    - - c = #"0") (full s)) -in - val shortmon = drop0 (Date.fmt "%m" now) - val shortday = drop0 (Date.fmt "%d" now) -end -?> - - -
    Year -
    Month -
    Danish date format -
    US date format -
    ISO date format -
    The time now is -
    - - diff --git a/smlserver_demo/www/web/test.sml b/smlserver_demo/www/web/test.sml deleted file mode 100644 index a54138d96..000000000 --- a/smlserver_demo/www/web/test.sml +++ /dev/null @@ -1,3 +0,0 @@ - -val _ = Web.Conn.write ("hello world" ^ " !! ") - diff --git a/smlserver_demo/www/web/testRedirect.sml b/smlserver_demo/www/web/testRedirect.sml deleted file mode 100644 index 3a36c6ea5..000000000 --- a/smlserver_demo/www/web/testRedirect.sml +++ /dev/null @@ -1,4 +0,0 @@ - -val _ = Web.returnRedirect ("test.sml") - - diff --git a/smlserver_demo/www/web/testinternalredirect.sml b/smlserver_demo/www/web/testinternalredirect.sml deleted file mode 100644 index e4d70e060..000000000 --- a/smlserver_demo/www/web/testinternalredirect.sml +++ /dev/null @@ -1,2 +0,0 @@ - -val _ = Web.Conn.redirect ("http://localhost:8080/apache/test.sml") diff --git a/smlserver_demo/www/web/testsendfile.sml b/smlserver_demo/www/web/testsendfile.sml deleted file mode 100644 index d812c87d2..000000000 --- a/smlserver_demo/www/web/testsendfile.sml +++ /dev/null @@ -1 +0,0 @@ -val _ = Web.Conn.returnFile(~1, "image/gif", "/home/varming/apache2/htdocs/web/www/apache/phd0410s.gif"); diff --git a/smlserver_demo/www/web/time_of_day.sml b/smlserver_demo/www/web/time_of_day.sml deleted file mode 100644 index 088850ae1..000000000 --- a/smlserver_demo/www/web/time_of_day.sml +++ /dev/null @@ -1,8 +0,0 @@ - val time_of_day = - Date.fmt "%H.%M.%S" (Date.fromTimeLocal(Time.now())) - - val _ = Web.log(Web.Debug, "time of day: " ^ time_of_day) - val _ = Page.return "Time of day" (` - - The time of day is ` ^^ Quot.fromString time_of_day ^^ `.` - ) diff --git a/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo1.png b/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo1.png deleted file mode 100644 index ed489b7b6..000000000 Binary files a/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo1.png and /dev/null differ diff --git a/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo2.png b/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo2.png deleted file mode 100644 index 026ca9d9a..000000000 Binary files a/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo2.png and /dev/null differ diff --git a/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo3.png b/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo3.png deleted file mode 100644 index 28571f20d..000000000 Binary files a/smlserver_demo/www/web/upload/files/poweredby_smlserver_logo3.png and /dev/null differ diff --git a/smlserver_demo/www/web/upload/return_file.sml b/smlserver_demo/www/web/upload/return_file.sml deleted file mode 100644 index 572df01d9..000000000 --- a/smlserver_demo/www/web/upload/return_file.sml +++ /dev/null @@ -1,6 +0,0 @@ -structure FV = FormVar - -val (filename,errs) = FV.getStringErr("clientfile","Filename",FV.emptyErr) -val _ = FV.anyErrors errs - -val _ = Web.returnFile (Web.Info.pageRoot() ^ "/web/upload/files/" ^ filename) diff --git a/smlserver_demo/www/web/upload/upload.sml b/smlserver_demo/www/web/upload/upload.sml deleted file mode 100644 index d8fb0838d..000000000 --- a/smlserver_demo/www/web/upload/upload.sml +++ /dev/null @@ -1,32 +0,0 @@ -structure FV = FormVar - -val (filename,errs) = FV.getStringErr("clientfile","Filename",FV.emptyErr) -val (filesize,errs) = FV.getIntErr("clientfile.filesize","Filesize",errs) -val filename_contenttype = FV.wrapOpt FV.getStringErr "clientfile.content-type" -val _ = FV.anyErrors errs - -val _ = - if filesize > 1024*10 then - (Page.return "Uploading files in SMLserver" - (`The file ^filename of size ^(Int.toString (Int.div (filesize,1024))) Kb - is too large. The maximum size is 10Kb.`); - Web.exit()) - else - Web.Conn.storeMultiformData("clientfile",Web.Info.pageRoot() ^ "/apache/upload/files/" ^ filename) - -val _ = Page.return "Uploading files in SMLserver" - `Received the following form variables: - - - - - - ^(case filename_contenttype of - SOME c => Quot.toString `` - | _ => "") -
    Form variableValue
    clientfile^filename
    filesize^(Int.toString filesize) bytes
    clientfile.contenttype^c

    - -The file ^filename has now been upload.

    - -Back to the index page.` - diff --git a/smlserver_demo/www/web/upload/upload_form.sml b/smlserver_demo/www/web/upload/upload_form.sml deleted file mode 100644 index e4cf5ff70..000000000 --- a/smlserver_demo/www/web/upload/upload_form.sml +++ /dev/null @@ -1,31 +0,0 @@ -val os_dir = FileSys.openDir (Web.Info.pageRoot() ^ "/web/upload/files/") -fun load_files acc = - let - val filename = FileSys.readDir os_dir - in - case filename of SOME filename => load_files(filename::acc) - | NONE => acc - end - -val uploaded_files = - List.foldl (fn (filename,acc) => - `

  • ^filename ` ^^ - acc) `` (load_files []) -val _ = FileSys.closeDir os_dir - -val _ = Page.return "Uploading files in SMLserver" - (` -
    - - - -
    -

    - -The following files has been uploaded:

    - -

      -` ^^ uploaded_files ^^ ` -
    -`) - diff --git a/smlserver_demo/www/web/xmlrpc_test_client.sml b/smlserver_demo/www/web/xmlrpc_test_client.sml deleted file mode 100644 index 34934d9e8..000000000 --- a/smlserver_demo/www/web/xmlrpc_test_client.sml +++ /dev/null @@ -1,39 +0,0 @@ -local - open Web.XMLrpc - fun call name t1 t2 a = - rpc t1 t2 {url="http://localhost/web/xmlrpc_test_server.sml", - method=name} a -in - val add = call "add" (pair(int,int)) int - val neg = call "neg" int int -end - -val res1 = Int.toString (neg(add(11,neg 5))) - handle Web.XMLrpc.TypeConversion => "TypeConversion Error" - -val res2 = Int.toString (add(12,200)) - handle Web.XMLrpc.TypeConversion => "TypeConversion Error" - -val res3 = Int.toString (neg 12) - handle Web.XMLrpc.TypeConversion => "TypeConversion Error" - -val () = Web.return ` - -

    XML-RPC Example

    - -

    -Each of the calculations below are made using XML-RPC client calls to an XML-RPC -server, which implements the neg and add11 operations. To see how easy -it is to make your ML functions available as XML-RPC methods, see the -source code for the server and the client available from the index page. -

    - - - - - - -
    ExpressionResult
    neg(add(11,neg 5))^res1
    add(12,200)^res2
    neg 12^res3
    -` diff --git a/smlserver_demo/www/web/xmlrpc_test_server.sml b/smlserver_demo/www/web/xmlrpc_test_server.sml deleted file mode 100644 index 8ec4e8809..000000000 --- a/smlserver_demo/www/web/xmlrpc_test_server.sml +++ /dev/null @@ -1,27 +0,0 @@ -fun add (a:int,b:int) : int = a + b - -fun neg (a:int) : int = ~a - -fun toInt s = case Int.fromString s of SOME i => i - | NONE => raise Fail "parseInt" - -fun guests (n) : ((int * string) * (string*string)) list = - Db.fold (fn (f,a) => ((toInt(f "gid"),f "name"), (f "email", f "comments"))::a) nil - `select gid,email,name,comments - from guest - order by name` - -fun guest_del(gid:int) : bool = - let val () = Db.dml `delete from guest where gid = ^(Int.toString gid)` - in true - end handle _ => false - -local open Web.XMLrpc -in (* val _ = Web.log(Web.Notice, "in xmlrpc_test_server.sml") *) - val _ = - dispatch [method "add" (pair(int,int)) int add, - method "neg" int int neg, - method "guests" int (list(pair(pair(int,string),pair(string,string)))) guests, - method "guest_del" int bool guest_del] -end - diff --git a/src/.cvsignore b/src/.cvsignore deleted file mode 100644 index 7d36cd113..000000000 --- a/src/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -.config PM run MLB a.out Version.sml CM -config.h Makefile mlkit.img diff --git a/src/CUtils/.cvsignore b/src/CUtils/.cvsignore deleted file mode 100644 index f8305e747..000000000 --- a/src/CUtils/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -a.out \ No newline at end of file diff --git a/src/Common/.cvsignore b/src/Common/.cvsignore deleted file mode 100644 index 31cd8ec31..000000000 --- a/src/Common/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB a.out \ No newline at end of file diff --git a/src/Common/EfficientElab/.cvsignore b/src/Common/EfficientElab/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Common/EfficientElab/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Common/FLAGS.sig b/src/Common/FLAGS.sig index 7c61abdea..39fdcd274 100644 --- a/src/Common/FLAGS.sig +++ b/src/Common/FLAGS.sig @@ -3,13 +3,13 @@ signature FLAGS = sig - (* + (* * MLKit warnings: collected during compilation and printed all at once at * the end of the compilation of a program. The printing is done in - * Manager which also resets the warnings. + * Manager which also resets the warnings. *) - type Report + type Report val warn : Report -> unit val warn_string : string -> unit val report_warnings : unit -> unit @@ -19,7 +19,7 @@ signature FLAGS = * Testing and toggling of flags. *) - val is_on : string -> bool + val is_on : string -> bool val is_on0 : string -> unit -> bool (* to avoid lookup *) val turn_on : string -> unit val turn_off : string -> unit @@ -53,49 +53,46 @@ signature FLAGS = information *) - val chat: bool ref (* true if a message is to be printed - for each phase of compilation + val chat: bool ref (* true if a message is to be printed + for each phase of compilation *) val DEBUG_COMPILER: bool ref val print_types : bool ref - val SMLserver : bool ref (* true when SMLserver for KAM backend - is enabled. - *) val log : TextIO.outstream ref val colwidth : int ref - val timings_stream : TextIO.outstream option ref (* optional stream for exporting - timings (`KITtimings') + val timings_stream : TextIO.outstream option ref (* optional stream for exporting + timings (`KITtimings') *) (* Program Points. *) val print_all_program_points : bool ref (* if true then print all program points, - otherwise print program_points in the - list below. + otherwise print program_points in the + list below. *) - val program_points: int list ref (* contains the program points that - should be included in program listing + val program_points: int list ref (* contains the program points that + should be included in program listing *) - val region_paths : (int*int) list ref + val region_paths : (int*int) list ref - (* Generic system to document options and let them appear on command + (* Generic system to document options and let them appear on command * lines. *) - type bentry = {long: string, (* long option for use with mlkit command + type bentry = {long: string, (* long option for use with mlkit command * using `--', script files, and internally - * in the mlkit to lookup the current setting + * in the mlkit to lookup the current setting * during execution. *) short: string option, (* short option used in commands with - *) menu: string list, (* menu path; nil means no-show *) item: bool ref, (* the actual flag *) neg: bool, (* should negated flag be introduced? * -no_opt, --no_optimiser *) - desc: string} (* description string; format manually + desc: string} (* description string; format manually * with new-lines *) - + type 'a entry = {long: string, short: string option, menu: string list, @@ -104,7 +101,7 @@ signature FLAGS = (* Functions to add entries dynamically; remember to add a description * telling what the flag is used for. If a nil-menu is given, the - * entry is not shown in help and the option cannot be given at the + * entry is not shown in help and the option cannot be given at the * command line. *) val add_bool_entry : bentry -> (unit -> bool) @@ -126,7 +123,7 @@ signature FLAGS = val help_all : unit -> string type options = {desc : string, long : string list, short : string list, - kind : string option, default : string option} + kind : string option, default : string option} val getOptions : unit -> options list diff --git a/src/Common/Flags.sml b/src/Common/Flags.sml index 22b6a1033..2a7d79d52 100644 --- a/src/Common/Flags.sml +++ b/src/Common/Flags.sml @@ -897,8 +897,6 @@ type options = {desc : string, long : string list, short : string list, kind : string option, default : string option} val getOptions = Directory.getOptions : unit -> options list -val SMLserver = ref false - datatype compiler_mode = LINK_MODE of string list (* lnk-files *) | LOAD_BASES of string list (* eb-files to be loaded; nil if normal *) diff --git a/src/Common/KitCompiler.sml b/src/Common/KitCompiler.sml index 5644660b9..43de2e615 100644 --- a/src/Common/KitCompiler.sml +++ b/src/Common/KitCompiler.sml @@ -56,8 +56,7 @@ functor KitCompiler(Execution : EXECUTION) : KIT_COMPILER = fun print_greetings () = let val version = Version.version ^ " (" ^ Version.gitversion ^ " - " ^ date ^ ")" val msg = - if !Flags.SMLserver then "SMLserver Compiler " ^ version ^ "\n" - else if backend_name = "SmlToJs" then "SmlToJs " ^ version ^ "\n" + if backend_name = "SmlToJs" then "SmlToJs " ^ version ^ "\n" else ("MLKit " ^ version ^ " [" ^ backend_name ^ " Backend]\n") in print msg diff --git a/src/Common/Man.sml b/src/Common/Man.sml index b66f4d9e8..cfead7216 100644 --- a/src/Common/Man.sml +++ b/src/Common/Man.sml @@ -4,25 +4,21 @@ structure Man : val gen : {cmd:unit->string, date:string, extraOptions: (string * string list * string list)list, - version:string} + version:string} -> string - end = + end = struct - fun isSMLserver exe : bool = - String.isSubstring "smlserverc" exe - fun isSMLtoJs exe : bool = String.isSubstring "smltojs" exe - + val homepage = "http://melsman.github.io/mlkit" - val homepage_smlserver = "http://www.smlserver.org" val homepage_smltojs = "http://www.smlserver.org/smltojs" fun concatWith2 (s1,s2) nil = "" | concatWith2 (s1,s2) [x] = x | concatWith2 (s1,s2) [x1,x2] = x1 ^ s2 ^ x2 - | concatWith2 (s1,s2) l = + | concatWith2 (s1,s2) l = let fun loop [x,y] = x ^ s1 ^ s2 ^ y (* ", " ^ " and " *) | loop (x::xs) = x ^ s1 ^ loop xs | loop _ = raise Fail "concatWith2.impossible" @@ -33,12 +29,12 @@ struct | addBetween _ (x::[]) = [x] | addBetween s (x::y::zz) = x:: s :: (addBetween s (y :: zz)) - fun printDefs () = + fun printDefs () = let - val formatDefaults = + val formatDefaults = List.mapPartial (fn ({default,long,short,...} : Flags.options) => Option.map (fn d => case List.getItem short - of NONE => + of NONE => Option.valOf(Option.map (fn (l,_) => {name = "--" ^ l, value = d}) (List.getItem long)) | SOME (s,_) => {name = "-" ^ s, value = d} ) default) @@ -50,21 +46,21 @@ struct fun printOpts extra = let - fun pLong (l,short,kind) = let + fun pLong (l,short,kind) = let val kk = case kind of NONE => "" | SOME a => " " ^ a - in + in String.concat (addBetween ", " ((List.map (fn x => "--" ^ x ^ kk) l) @ (List.map (fn x => "-" ^ x ^ kk) short))) end fun printOps ({long,short,desc,kind,...} : Flags.options) = String.concat [".IP \"\\fB", pLong (long,short,kind), "\\fR\" 4\n",".IX Item \"", pLong (long,short,kind), "\"\n", - desc,"\n"] + desc,"\n"] fun genExtra (l,s,d) = {long = [l], short = s, desc = String.concat d, kind = NONE, default = NONE} val extra' = List.map genExtra extra fun cmp c ([],[]) = EQUAL | cmp c ([],_) = LESS | cmp c (_,[]) = GREATER - | cmp c (x::xs,y::ys) = case c (x,y) + | cmp c (x::xs,y::ys) = case c (x,y) of EQUAL => cmp c (xs,ys) | GREATER => GREATER | LESS => LESS @@ -73,7 +69,7 @@ struct String.concat (List.map printOps (sort (Flags.getOptions () @ extra'))) end - structure Devel = + structure Devel = struct val developers = ["Lars Birkedal", "Martin Elsman", @@ -82,68 +78,58 @@ struct val contributers = ["Peter Bertelsen", "Vesa Karvonen", - "Ken Friis Larsen", + "Ken Friis Larsen", "Henning Niss", "Peter Sestoft"] - val smlserver_developers = ["Martin Elsman", - "Niels Hallenberg", - "Carsten Varming"] - val smltojs_developers = ["Martin Elsman"] end fun mkStr s = "\"" ^ s ^ "\"" - - fun files exe = + + fun files exe = [("/etc/" ^ exe ^ "/mlb-path-map", "System-wide configuration of library and runtime system locations"), ("~/." ^ exe ^ "/mlb-path-map", "User specific configuration of library and runtime system locations")] - fun header exe date version = - let val title = - if isSMLserver exe then - mkStr "Standard ML compiler for SMLserver" - else if isSMLtoJs exe then + fun header exe date version = + let val title = + if isSMLtoJs exe then mkStr "SMLtoJs - a Standard ML to JavaScript compiler" else mkStr "MLKit - a compiler for Standard ML" in - String.concat [".TH ", exe, " 1 \"", date, "\" \"version ", + String.concat [".TH ", exe, " 1 \"", date, "\" \"version ", version, "\" ",title,"\n"] end - - fun name exe = - let val text = - if isSMLserver exe then - "Standard ML compiler for SMLserver" - else if isSMLtoJs exe then + + fun name exe = + let val text = + if isSMLtoJs exe then "Standard ML to JavaScript compiler" else "A fullblown Standard ML compiler" - in + in ".SH NAME\n" ^ exe ^ " \\- " ^ text ^ " \n" end - fun defaults() = - String.concat [".SH DEFAULTS\n", + fun defaults () = + String.concat [".SH DEFAULTS\n", printDefs(), ".\n"] - fun synopsis exe = + fun synopsis exe = String.concat [".SH SYNOPSIS\n", exe, " [OPTION]... [file.sml | file.sig | file.mlb]\n\n", "All possible options are listed below.\n"] - fun description exe = - let val (name, result, homepage) = - if isSMLserver exe then - ("SMLserver", "loadable bytecode files ", homepage_smlserver) - else if isSMLtoJs exe then - ("SMLtoJs", "an HTML-file, containing references to generated JavaScript files, ", homepage_smltojs) + fun description exe = + let val (name, result, homepage) = + if isSMLtoJs exe then + ("SMLtoJs", "an HTML-file, containing references to generated JavaScript files, ", homepage_smltojs) else ("MLKit", "an executable file\n.B run\n", homepage) in String.concat[".SH DESCRIPTION\n", - "When invoked, \n.B ", exe, "\nwill compile the specified sources into ", result, + "When invoked, \n.B ", exe, "\nwill compile the specified sources into ", result, "through a series of translation phases. Various options (see below) can be used to control the ", "printing of intermediate forms and to control to which degree various optimizations are performed. If source files ", "are organised in ML Basis Files (files with extension .mlb), the compiler will memoize symbol table ", @@ -153,47 +139,43 @@ struct ".B ", homepage, "\n"] end - fun options extraOptions = + fun options extraOptions = String.concat [".SH OPTIONS\n", printOpts extraOptions] - - val exit = + + val exit = String.concat [".SH EXIT STATUS\nExits with status 0 on success and -1 on failure.\n"] - fun environment exe = + fun environment exe = String.concat [".SH ENVIRONMENT\n", "A library install directory must be provided ", "in an environment variable SML_LIB or as a path-definition ", "in either the system wide path-map /etc/" ^ exe ^ "/mlb-path-map ", "or in the user's personal path-map ~/." ^ exe ^ "/mlb-path-map.\n"] - val files = fn exe => + val files = fn exe => String.concat [".SH FILES\n", String.concat (List.map (fn (f,e) => ".IP " ^ f ^ "\n" ^ e ^ "\n" ) (files exe))] (* val diag = String.concat [".SH DIAGNOSTICS\n", "The following diagnostics may be issued on stderr:\n"] *) - fun examples exe = + fun examples exe = if isSMLtoJs exe then String.concat [".SH EXAMPLES\n", "For examples, consult the SMLtoJs home page.\n"] else let val (name, title) = - if isSMLserver exe then - ("SMLserver", "book \"SMLserver, A Functional Approach to Web Publishing\"") - else ("MLKit", "MLKit manual \"Programming with Regions in the MLKit\"") + ("MLKit", "MLKit manual \"Programming with Regions in the MLKit\"") in String.concat [".SH EXAMPLES\n", "For examples, consult the ", title, ", which is available from the ", name, " home page.\n"] end - - fun standard exe = - let + fun standard exe = + let val based_on_mlkit_maybe = - if isSMLserver exe then "SMLserver is based on the MLKit. " - else if isSMLtoJs exe then + if isSMLtoJs exe then "SMLtoJs is based on the MLKit. " else "" val maybe_all_basis = @@ -208,40 +190,27 @@ struct end fun credits exe = - let val smlserver_maybe = - if isSMLserver exe then - ("SMLserver was developed by " ^ concatWith2 (", ", " and ") Devel.smlserver_developers ^ ". ") - else "" - val c = + let val c = if isSMLtoJs exe then ["SMLtoJs was developed by " ^ concatWith2 (", ", " and ") Devel.smltojs_developers ^ ". ", "Many people have helped developing the MLKit on which SMLtoJs is built; see the MLKit home page for details."] else - [smlserver_maybe, - "The MLKit (version 2 and beyond) was developed by ", + ["The MLKit (version 2 and beyond) was developed by ", concatWith2 (", "," and ") Devel.developers, ". People who have contributed with bug-fixes and improvements include ", concatWith2 (", ", " and ") Devel.contributers, ". Nick Rothwell and David N. Turner took part in the development of the MLKit version 1.\n"] - in + in String.concat ([".SH CREDITS\n"] @ c) end - fun seealso exe = - let val smlserver_maybe = - if isSMLserver exe orelse isSMLtoJs exe then - ("See the book \"SMLserver, A Functional Approach to Web Publishing\", available from the " ^ - "SMLserver home page, for an introduction to programming efficient Web applications with SMLserver. " ^ - "For installation instructions, see the file README_SMLSERVER in the distribution. ") - else "" - in - String.concat [".SH SEE ALSO\n", smlserver_maybe, + fun seealso exe = + String.concat [".SH SEE ALSO\n", "See the MLKit manual \"Programming with Regions in the MLKit\", available from the ", "MLKit home page\n\n", ".B ", homepage, "\n\nfor an in-depth introduction to programming with regions in the MLKit.\n\n", "The home page also provides an overview of which parts of ", "the Standard ML Basis Library the MLKit implements, along with download and installation instructions."] - end fun gen {cmd:unit->string,date:string, extraOptions : (string * string list * string list) list, diff --git a/src/Compiler/.cvsignore b/src/Compiler/.cvsignore deleted file mode 100644 index 31cd8ec31..000000000 --- a/src/Compiler/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB a.out \ No newline at end of file diff --git a/src/Compiler/Backend/.cvsignore b/src/Compiler/Backend/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Compiler/Backend/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Compiler/Backend/Barry/.cvsignore b/src/Compiler/Backend/Barry/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Compiler/Backend/Barry/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Compiler/Backend/CLOS_EXP.sml b/src/Compiler/Backend/CLOS_EXP.sml index d3f581b4d..913f1e810 100644 --- a/src/Compiler/Backend/CLOS_EXP.sml +++ b/src/Compiler/Backend/CLOS_EXP.sml @@ -149,12 +149,6 @@ signature CLOS_EXP = imports:label list * label list, exports:label list * label list} - (* For bytecode ME 2000-10-04 *) - val lift : env * ((place*pp) at, place*phsize, unit)LambdaPgm -> {main_lab:label, - code:ClosPrg, - env:env, - imports:label list * label list, - exports:label list * label list} type StringTree val layout_clos_exp : ClosExp -> StringTree val layout_top_decl : TopDecl -> StringTree diff --git a/src/Compiler/Backend/ClosExp.sml b/src/Compiler/Backend/ClosExp.sml index fddf1e66b..5a2befe56 100644 --- a/src/Compiler/Backend/ClosExp.sml +++ b/src/Compiler/Backend/ClosExp.sml @@ -40,13 +40,6 @@ struct item=ref false, neg=false, desc= "Print Region Expression after closure conversion."} - val print_lift_conv_program_p = Flags.add_bool_entry - {long="print_lift_conv_program", short=SOME "Plcp", - menu=["Printing of intermediate forms","print lifted expression for the KAM"], - item=ref false, neg=false, desc= - "Print Region Expression after lifting. Used for the\n\ - \compilation into byte code (KAM)."} - fun pp_lvars s lvs = let fun loop nil = () | loop (lv::lvs) = (print (Lvars.pr_lvar lv); print ","; loop lvs) @@ -1548,12 +1541,6 @@ struct | gen_fresh_res_lvars(RegionExp.RaisedExnBind) = [] (* Convert ~n to -n *) -(* - fun int32_to_string i = if Int32.>=(i,0) then Int32.toString i - else "-" ^ Int32.toString (Int32.~ i) - - fun int_to_string i = if i >= 0 then Int.toString i else "-" ^ Int.toString (~i) -*) fun convert_real r = (* Translate a real constant into C notation: *) let fun conv #"~" = #"-" | conv #"E" = #"e" @@ -2277,8 +2264,8 @@ struct | maybe_insert_smas(fresh_lvs,smas,ce) = LET{pat=fresh_lvs,bind=UB_RECORD smas,scope=ce} in - (case explode name - of #"@" :: rest => (* AUTO CONVERSION *) + (case explode name of + #"@" :: rest => (* AUTO CONVERSION *) let val name = implode rest fun ty_trs tr = case tr @@ -2299,13 +2286,56 @@ struct ses), NONE_SE) end - | _ => - let val (name, args) = add_pp_for_profiling(rhos_for_result',ces) + | _ => + + (* for overloaded primitives that may raise exceptions (e.g., div and mod), + * we add the evaluation context as the first parameter to the function; we + * do this here, instead of in the frontend, to avoid that other backends + * (e.g., the Javascript backend) are affected by the fact that the native + * backend requires that a context is made accessible during evaluation. + *) + + let fun cons_ctx ces = + let val lv_ctx = fresh_lvar "ctx" + in ( fn e => LET{pat=[lv_ctx],bind=CCALL{name="__get_ctx",args=[],rhos_for_result=[]}, + scope=e} + , VAR lv_ctx :: ces + ) + end + val (maybe_add_context, ces) = + case name of + "__div_word31" => cons_ctx ces + | "__div_word32ub" => cons_ctx ces + | "__div_word32b" => cons_ctx ces + | "__div_word63" => cons_ctx ces + | "__div_word64ub" => cons_ctx ces + | "__div_word64b" => cons_ctx ces + | "__mod_word31" => cons_ctx ces + | "__mod_word32ub" => cons_ctx ces + | "__mod_word32b" => cons_ctx ces + | "__mod_word63" => cons_ctx ces + | "__mod_word64ub" => cons_ctx ces + | "__mod_word64b" => cons_ctx ces + | "__div_int31" => cons_ctx ces + | "__div_int32ub" => cons_ctx ces + | "__div_int32b" => cons_ctx ces + | "__div_int63" => cons_ctx ces + | "__div_int64ub" => cons_ctx ces + | "__div_int64b" => cons_ctx ces + | "__mod_int31" => cons_ctx ces + | "__mod_int32ub" => cons_ctx ces + | "__mod_int32b" => cons_ctx ces + | "__mod_int63" => cons_ctx ces + | "__mod_int64ub" => cons_ctx ces + | "__mod_int64b" => cons_ctx ces + | _ => (fn x => x, ces) + val (name, args) = add_pp_for_profiling(rhos_for_result',ces) in (maybe_return_unit (insert_ses(maybe_insert_smas(fresh_lvs,smas, - CCALL{name=name, - args=args, - rhos_for_result=map VAR fresh_lvs}), + maybe_add_context + (CCALL{name=name, + args=args, + rhos_for_result=map VAR fresh_lvs})), ses)), NONE_SE) end) @@ -2396,714 +2426,6 @@ struct in ccExp e end (* End ccTrip *) - - (* ------------------------ *) - (* Lift, for the KAM *) - (* ------------------------ *) - fun liftTrip (MulExp.TR(e,metaType,ateffects,mulef)) env lab = - let - fun gen_pseudo_res_lvars(RegionExp.Mus type_and_places) = - (case type_and_places of - [(ty,_)] => - (case RType.unFUN ty of - SOME(mus1,arroweffect,mus2) => List.map (fn _ => Lvars.notused_lvar) mus2 - | NONE => die "gen_fresh_res: not a function type.") - | _ => die "gen_fresh_res: not a function type.") - | gen_pseudo_res_lvars(RegionExp.Frame _) = [] - | gen_pseudo_res_lvars(RegionExp.RaisedExnBind) = [] - - fun lookup_ve env lv = - case CE.lookupVarOpt env lv of - SOME(CE.LVAR lv') => VAR lv' - | SOME(CE.RVAR rho) => die ("lookup_ve: rho=" ^ (pr_rhos [rho]) ^ ".") - | SOME(CE.DROPPED_RVAR rho) => die ("lookup_ve: dropped rho=" ^ (pr_rhos [rho]) ^ ".") - | SOME(CE.SELECT(lv',i)) => SELECT(i,VAR lv') - | SOME(CE.LABEL lab) => FETCH(lab) - | SOME(CE.FIX(_,SOME (CE.SELECT(lv',i)),_,_)) => SELECT(i,VAR lv') - | SOME(CE.FIX(_,SOME (CE.LVAR lv'),_,_)) => VAR lv' - | SOME(CE.FIX(_,SOME (CE.LABEL lab),_,_)) => FETCH(lab) - | SOME(CE.FIX(_,SOME a,_,_)) => die ("lookup_ve on FIX(SOME " ^ (CE.pr_access_type a) ^ ") -- not implemented") - | SOME(CE.FIX(_,NONE,_,_)) => die "lookup_ve: this case should be caught in APP." - | NONE => die ("lookup_ve: lvar(" ^ (Lvars.pr_lvar lv) ^ ") not bound in env.") - - fun lookup_rho env place = - case CE.lookupRhoOpt env place of - SOME(CE.LVAR lv') => VAR lv' - | SOME(CE.RVAR place) => RVAR place - | SOME(CE.DROPPED_RVAR place) => DROPPED_RVAR place - | SOME(CE.SELECT(lv',i)) => SELECT(i,VAR lv') - | SOME(CE.LABEL lab) => FETCH(lab) - | SOME _ => die "lookup_rho: rho bound to FIX" - | NONE => die ("lookup_rho: rho(" ^ PP.flatten1(Effect.layout_effect place) ^ ") not bound...") - - fun lookup_excon env excon = - case CE.lookupExconOpt env excon of - SOME(CE.LVAR lv') => VAR lv' - | SOME(CE.SELECT(lv',i)) => SELECT(i,VAR lv') - | SOME(CE.LABEL lab) => FETCH(lab) - | SOME _ => die "lookup_excon: excon bound to FIX or RVAR" - | NONE => die ("lookup_excon: excon(" ^ (Excon.pr_excon excon) ^ ") not bound") - - fun convert_alloc (alloc,env) = - case alloc of - AtInf.ATBOT(rho,pp) => convert_sma(AtInf.ATBOT(rho,pp),CE.lookupRhoKind env rho,lookup_rho env rho) - | AtInf.SAT(rho,pp) => convert_sma(AtInf.SAT(rho,pp),CE.lookupRhoKind env rho,lookup_rho env rho) - | AtInf.ATTOP(rho,pp) =>convert_sma(AtInf.ATTOP(rho,pp),CE.lookupRhoKind env rho,lookup_rho env rho) - | AtInf.IGNORE => IGNORE - - fun compile_letrec_app env lvar = - let - val (lab_f,size_clos) = lookup_fun env lvar - in - if size_clos = 0 then - (NONE,lab_f) - else - (SOME (lookup_ve env lvar),lab_f) - end - - fun compile_sels_and_default sels default f_match ccTrip = - let - val sels' = - List.foldr (fn ((m,tr),sels_acc) => - (f_match m, (ccTrip tr))::sels_acc) [] sels - in - case default of - SOME tr => (sels', ccTrip tr) - | NONE => - (case rev sels' of - ((_,ce)::rev_sels') => (rev rev_sels',ce) - | _ => die "compile_sels_and_default: no selections.") - end - - fun liftExp e = - (case e of - MulExp.VAR{lvar,...} => lookup_ve env lvar - | MulExp.INTEGER(i,t,alloc) => INTEGER{value=i, precision=precisionNumType t} - | MulExp.WORD(w,t,alloc) => WORD{value=w, precision=precisionNumType t} - | MulExp.STRING(s,alloc) => STRING s - | MulExp.REAL(r,alloc) => REAL (convert_real r) - | MulExp.F64(r,alloc) => F64 (convert_real r) - | MulExp.UB_RECORD trs => UB_RECORD (List.map (fn tr => liftTrip tr env lab) trs) - | MulExp.FN{pat,body,free=ref (SOME free_vars_all),alloc} => - (* For now, the function is closure implemented. *) - (* Free variables must go into the closure. All free variables *) - (* (free_vars_all) must be bound in the closure environment, *) - (* while we do not store region closures with no free variables *) - (* in the actual closure. *) - let - val free_vars = remove_zero_sized_region_closure_lvars env free_vars_all - - val new_lab = fresh_lab (Labels.pr_label lab ^ ".anon") - val args = List.map #1 pat - val lv_clos = Lvars.env_lvar - val pseudo_res_lvars = gen_pseudo_res_lvars metaType (* Only used to remember the number of return values in cc *) - val cc = CallConv.mk_cc_fn(args,SOME lv_clos,pseudo_res_lvars) - - val env_body = build_clos_env env (get_global_env()) lv_clos BI.init_clos_offset free_vars_all - val env_with_args = (env_body plus_decl_with CE.declareLvar) (map (fn lv => (lv, CE.LVAR lv)) args) - - val (free_lvs,free_excons,free_rhos) = free_vars - val ces = (List.map (fn lv => lookup_ve env lv) free_lvs, - List.map (fn excon => lookup_excon env excon) free_excons, - List.map (fn place => lookup_rho env place) free_rhos) - - val _ = add_new_fn(new_lab, cc, liftTrip body env_with_args new_lab) - val sma = convert_alloc(alloc,env) - in - CLOS_RECORD{label=new_lab, elems=ces, alloc=sma} - end - | MulExp.FN _ => die "liftExp: FN with no free vars info" - | MulExp.FIX{free=ref (SOME free_vars_all),shared_clos=alloc,functions,scope} => - (* For now, the functions are closure implemented *) - (* Note, that we may pass a shared closure to a function even though it isn't used by the function. *) - (* It is not necessary to pass a shared closure to a FIX bound function f iff: *) - (* 1- f has no free variables except FIX bound functions. *) - (* 2- f does not call another FIX bound function g using the shared closure. *) - let - val free_vars_in_shared_clos = remove_zero_sized_region_closure_lvars env free_vars_all - val shared_clos_size = size3 free_vars_in_shared_clos - - val lv_sclos = fresh_lvar("sclos") - val (free_lvs, free_excons, free_rhos) = free_vars_in_shared_clos - val ces = (List.map (fn lv => lookup_ve env lv) free_lvs, - List.map (fn excon => lookup_excon env excon) free_excons, - List.map (fn place => lookup_rho env place) free_rhos) - - val lvars_labels_formals = map (fn {lvar, rhos_formals=ref formals, ...} => - (lvar, fresh_lab(Lvars.pr_lvar lvar), formals)) functions - - val lvars = map #lvar functions - val binds = map #bind functions - val formalss = map (! o #rhos_formals) functions (* place*phsize *) - val dropss = map (valOf o #bound_but_never_written_into) functions - handle Option => die "FIX.dropps: bound but never written was None" - - val labels = map #2 lvars_labels_formals - - val env_scope = - if shared_clos_size = 0 then - (env plus_decl_with CE.declareLvar) - (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,NONE,0,formals))) lvars_labels_formals) - else - (env plus_decl_with CE.declareLvar) - (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,SOME(CE.LVAR lv_sclos),shared_clos_size,formals))) lvars_labels_formals) - - fun compile_fn (lvar,bind,formals,drops,lab) = - let - val (args,body,metaType) = case bind of - MulExp.TR(MulExp.FN{pat,body,...},metaType,_,_) => (List.map #1 pat, body, metaType) - | _ => die "compile_fn: bind is not a FN" - val pseudo_res_lvars = gen_pseudo_res_lvars metaType (* Only used to remember the number of return values in cc *) - - val lv_sclos_fn = Lvars.env_lvar - val env_bodies = build_clos_env env (get_global_env()) lv_sclos_fn BI.init_sclos_offset free_vars_all - - val env_with_funs = - if shared_clos_size = 0 then - (env_bodies plus_decl_with CE.declareLvar) - (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,NONE,0,formals))) lvars_labels_formals) - else - (env_bodies plus_decl_with CE.declareLvar) - (map (fn (lv,lab,formals) => (lv,CE.FIX(lab,SOME(CE.LVAR lv_sclos_fn),shared_clos_size,formals))) lvars_labels_formals) - - val rho_lvs = List.map (fn _ => fresh_lvar("rho")) formals (* fresh lvs for region parameters 12/09-2000, Niels *) - val env_with_rho_lvs = - List.foldl (fn ((rho_lv,(place,_)),env) => - (CE.declareRho(place,CE.LVAR rho_lv,env))) env_with_funs (zip(rho_lvs,formals)) - - val env_with_rho_kind = - (env_with_rho_lvs plus_decl_with CE.declareRhoKind) - (map (fn (place,phsize) => (place,mult("f",phsize))) formals) - - val env_with_rho_drop = - (env_with_rho_kind plus_decl_with CE.declareRho) - (map (fn (place,_) => (place,CE.DROPPED_RVAR(drop_rho place))) drops) - val env_with_rho_drop_kind = - (env_with_rho_drop plus_decl_with CE.declareRhoKind) - (map (fn(place,phsize) => (place,mult("f",phsize))) drops) - - val env_with_args = - (env_with_rho_drop_kind plus_decl_with CE.declareLvar) - (map (fn lv => (lv, CE.LVAR lv)) args) - -(* val _ = print ("Closure size, " ^ (Lvars.pr_lvar lv_sclos_fn) ^ ": " ^ (Int.toString shared_clos_size) ^ - " " ^ (pr_free free_vars_in_shared_clos) ^ "\n") *) - val sclos = if shared_clos_size = 0 then NONE else SOME lv_sclos_fn (* 14/06-2000, Niels *) - val cc = CallConv.mk_cc_fun(args,sclos,NONE,rho_lvs,pseudo_res_lvars) - in - add_new_fun(lab,cc,liftTrip body env_with_args lab) - end - val _ = List.app compile_fn (zip5 (lvars,binds,formalss,dropss,labels)) - in - if shared_clos_size = 0 then - liftTrip scope env_scope lab - else - let - val sma = convert_alloc(alloc,env) - in - LET{pat=[lv_sclos], - bind= SCLOS_RECORD{elems=ces,alloc=sma}, - scope= liftTrip scope env_scope lab} - end - end - | MulExp.FIX{free=_,shared_clos,functions,scope} => die "liftExp: No free variables in FIX" - - | MulExp.APP(SOME MulExp.JMP, _, tr1 as MulExp.TR(MulExp.VAR{lvar,fix_bound,rhos_actuals = ref rhos_actuals,...}, _, _, _), tr2) => - let - val ces_arg = (* We remove the unboxed record. *) - case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => liftTrip tr env lab) trs - | _ => [liftTrip tr2 env lab] - - val (ce_clos,lab_f) = compile_letrec_app env lvar - val smas = List.map (fn alloc => PASS_PTR_TO_RHO(convert_alloc(alloc,env))) rhos_actuals - in - JMP{opr=lab_f,args=ces_arg,reg_vec=NONE,reg_args=smas,clos=ce_clos} - end - | MulExp.APP(SOME MulExp.JMP, _, tr1, tr2) => die "JMP to other than lvar" - | MulExp.APP(SOME MulExp.FUNCALL, _, tr1 as MulExp.TR(MulExp.VAR{lvar,fix_bound=true, rhos_actuals=ref rhos_actuals,...},_,_,_), tr2) => - let - val ces_arg = (* We remove the unboxed record. *) - case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => liftTrip tr env lab) trs - | _ => [liftTrip tr2 env lab] - - val (ce_clos,lab_f) = compile_letrec_app env lvar - val smas = List.map (fn alloc => PASS_PTR_TO_RHO(convert_alloc(alloc,env))) rhos_actuals - in - FUNCALL{opr=lab_f,args=ces_arg,reg_vec=NONE,reg_args=smas,clos=ce_clos} - end - | MulExp.APP(SOME MulExp.FNJMP,_, tr1,tr2) => - let - val ces = - case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => liftTrip tr env lab) trs - | _ => [liftTrip tr2 env lab] - val ce_opr = liftTrip tr1 env lab - in - FNJMP{opr=ce_opr,args=ces,clos=NONE (*SOME ce_opr*)} (* opr and clos is similar, we only want to the opr expression once! I therefore set clos equal to NONE17/09-2000, Niels *) - end -(* - | MulExp.APP(NONE,_, (* primitive *) - tr1 as MulExp.TR(MulExp.VAR{lvar,fix_bound=false, rhos_actuals=ref rhos_actuals,...},_,_,_), - tr2) => - let - val ces = - (case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => - List.map (fn tr => liftTrip tr env lab) trs (* all primitives have *) - | _ => die "APP.lvar.prim.args not UB_RECORD") (* unboxed arguments. *) - - val prim_name = - (case (Lvars.primitive lvar, rhos_actuals) of - (NONE, []) => die ("APP.expected primitive: " ^ Lvars.pr_lvar lvar) - | (NONE, _) => die ("APP.non-primitive with unboxed region parameters: lvar = " ^ Lvars.pr_lvar lvar) - | (SOME prim, _) => - (case prim of - Lvars.PLUS_INT => BI.PLUS_INT - | Lvars.MINUS_INT => BI.MINUS_INT - | Lvars.MUL_INT => BI.MUL_INT - | Lvars.NEG_INT => BI.NEG_INT - | Lvars.ABS_INT => BI.ABS_INT - | Lvars.LESS_INT => BI.LESS_INT - | Lvars.LESSEQ_INT => BI.LESSEQ_INT - | Lvars.GREATER_INT => BI.GREATER_INT - | Lvars.GREATEREQ_INT => BI.GREATEREQ_INT - | Lvars.PLUS_FLOAT => BI.PLUS_FLOAT - | Lvars.MINUS_FLOAT => BI.MINUS_FLOAT - | Lvars.MUL_FLOAT => BI.MUL_FLOAT - | Lvars.DIV_FLOAT => BI.DIV_FLOAT - | Lvars.NEG_FLOAT => BI.NEG_FLOAT - | Lvars.ABS_FLOAT => BI.ABS_FLOAT - | Lvars.LESS_FLOAT => BI.LESS_FLOAT - | Lvars.LESSEQ_FLOAT => BI.LESSEQ_FLOAT - | Lvars.GREATER_FLOAT => BI.GREATER_FLOAT - | Lvars.GREATEREQ_FLOAT => BI.GREATEREQ_FLOAT)) - - val smas = List.map (fn alloc => convert_alloc(alloc,env)) rhos_actuals - - (* Only real primitives allocate and only one time. *) - val smas_ccall = map (fn sma => PASS_PTR_TO_MEM(sma,BI.size_of_real())) smas - in - CCALL{name=prim_name,args=ces,rhos_for_result=smas_ccall} - end - | MulExp.APP(NONE,_, (* primitive *) - tr1, (* not lvar: error *) - tr2) => die "expected primitive operation" -*) - | MulExp.APP(SOME MulExp.FNCALL,_, tr1, tr2) => - let - val ces = - case tr2 of - MulExp.TR(MulExp.UB_RECORD trs,_,_,_) => List.map (fn tr => liftTrip tr env lab) trs - | _ => [liftTrip tr2 env lab] - val ce_opr = liftTrip tr1 env lab - in - FNCALL{opr=ce_opr,args=ces,clos=NONE (*SOME ce_opr*)} (* opr and clos is similar, we only want to the opr expression once! I therefore set clos equal to NONE17/09-2000, Niels *) - end - | MulExp.APP _ => die "application form not recognised" - - | MulExp.LETREGION{B,rhos=ref bound_regvars,body} => - let - val env_with_kind = - (env plus_decl_with CE.declareRhoKind) - (map (fn (place,phsize) => (place,mult("l",phsize))) bound_regvars) - val env_body = - (env_with_kind plus_decl_with CE.declareRho) - (map (fn (place,_) => (place,CE.RVAR place)) bound_regvars) - in - LETREGION{rhos=bound_regvars, - body= liftTrip body env_body lab} - end - | MulExp.LET{k_let,pat,bind,scope} => - let - val lvars = List.map #1 pat - val env_with_lvar = - (env plus_decl_with CE.declareLvar) - (map (fn lv => (lv,CE.LVAR lv)) lvars) - in - LET{pat=lvars, - bind= liftTrip bind env lab, - scope= liftTrip scope env_with_lvar lab} - end - | MulExp.EXCEPTION(excon,true,typePlace,alloc,scope) => (* Nullary exception constructor *) - let - val lv_exn = fresh_lvar "exn" - val env' = CE.declareExcon(excon,(CE.LVAR lv_exn,CE.NULLARY_EXCON),env) - val sma = convert_alloc(alloc,env) - in - LET{pat=[lv_exn], - bind=RECORD{elems=[RECORD{elems=[CCALL{name="__fresh_exname", - args=[],rhos_for_result=[]}, - STRING (Excon.pr_excon excon)], - alloc=sma, - tag=BI.tag_exname false, - maybeuntag=false}], - alloc=sma, - tag=BI.tag_excon0 false, - maybeuntag=false}, - scope= liftTrip scope env' lab} - end - | MulExp.EXCEPTION(excon,false,typePlace,alloc,scope) => (* Unary exception constructor *) - let - val lv_exn = fresh_lvar "exn" - val env' = CE.declareExcon(excon,(CE.LVAR lv_exn,CE.UNARY_EXCON),env) - val sma = convert_alloc(alloc,env) - in - LET{pat=[lv_exn], - bind=RECORD{elems=[CCALL{name="__fresh_exname", - args=[], - rhos_for_result=[]}, - STRING (Excon.pr_excon excon)], - alloc=sma, - tag=BI.tag_exname false, - maybeuntag=false}, - scope= liftTrip scope env' lab} - end - | MulExp.RAISE tr => RAISE(liftTrip tr env lab) - | MulExp.HANDLE(tr1,tr2) => HANDLE(liftTrip tr1 env lab, - liftTrip tr2 env lab) - | MulExp.SWITCH_I {switch=MulExp.SWITCH(tr,selections,opt), precision} => - let val (selections,opt) = (compile_sels_and_default selections - opt (fn i => i) (fn tr => liftTrip tr env lab)) - val ce = liftTrip tr env lab - in SWITCH_I{switch=SWITCH(ce,selections,opt), precision=precision} - end - | MulExp.SWITCH_W {switch=MulExp.SWITCH(tr,selections,opt), precision} => - let val (selections,opt) = (compile_sels_and_default selections - opt (fn i => i) (fn tr => liftTrip tr env lab)) - val ce = liftTrip tr env lab - in SWITCH_W{switch=SWITCH(ce,selections,opt), precision=precision} - end - | MulExp.SWITCH_S(MulExp.SWITCH(tr,selections,opt)) => - (* We bind tr (i.e., ce) to an lvar so that tr is only evaluated once. *) - let - val (selections,opt) = - compile_sels_and_default selections opt (fn m=>m) (fn tr => liftTrip tr env lab) - val ce = liftTrip tr env lab - - (* When tagging is enabled, integers in SWITCH_I are converted in - * CodeGenX86.sml - so in that case we must use an untagged representation - * of true, which is 1 (given that BI.ml_true is 3). *) - val True = IntInf.fromInt (if BI.ml_true = 3 then - if BI.tag_values() then 1 - else BI.ml_true - else die "True") - fun compile_seq_switch(ce,[],default) = default - | compile_seq_switch(ce,(s,ce')::rest,default) = - SWITCH_I {switch=SWITCH(CCALL{name="equalStringML",args=[ce,STRING s],rhos_for_result=[]}, - [(True,ce')], - compile_seq_switch(ce,rest,default)), - precision=BI.defaultIntPrecision()} - val lv_str = fresh_lvar("sw_str") - in - LET{pat=[lv_str], - bind=ce, - scope=compile_seq_switch(VAR lv_str,selections,opt)} - end - | MulExp.SWITCH_C(MulExp.SWITCH(tr,selections,opt)) => - let - fun tag con = - (case CE.lookupCon env con of - CE.ENUM i => - if BI.tag_values() orelse (* hack to treat booleans tagged *) - Con.eq(con,Con.con_TRUE) orelse Con.eq(con,Con.con_FALSE) then - (con,ENUM(2*i+1)) - else - (con,ENUM i) - | CE.UB_NULLARY i => (con,UNBOXED(4*i+3)) - | CE.UB_UNARY i => (con,UNBOXED i) - | CE.B_NULLARY i => (con,BOXED(Word32.toInt (BI.tag_con0(false,i)))) - | CE.B_UNARY i => (con,BOXED(Word32.toInt (BI.tag_con1(false,i))))) - - val (selections,opt) = - compile_sels_and_default selections opt tag (fn tr => liftTrip tr env lab) - val ce = liftTrip tr env lab - in - SWITCH_C(SWITCH(ce,selections,opt)) - end - | MulExp.SWITCH_E(MulExp.SWITCH(tr,selections,opt)) => - (* We bind tr (i.e., ce) to an lvar so that tr is only evaluated once. *) - let - val (selections,opt) = - compile_sels_and_default selections opt - (fn m=>(lookup_excon env m,CE.lookupExconArity env m)) - (fn tr => liftTrip tr env lab) - val ce = liftTrip tr env lab - fun compile_seq_switch(ce,[],default) = default - | compile_seq_switch(ce,((ce_e,arity),ce')::rest,default) = - (case arity of - CE.NULLARY_EXCON => - SWITCH_I{switch=SWITCH(CCALL{name="__equal_int32ub", - args=[ce,SELECT(0,SELECT(0,ce_e))], - rhos_for_result=[]}, - [(IntInf.fromInt BI.ml_true,ce')], - compile_seq_switch(ce,rest,default)), - precision=BI.defaultIntPrecision()} - | UNARY_EXCON => - SWITCH_I{switch=SWITCH(CCALL{name="__equal_int32ub", - args=[ce,SELECT(0,ce_e)],rhos_for_result=[]}, - [(IntInf.fromInt BI.ml_true,ce')], - compile_seq_switch(ce,rest,default)), - precision=BI.defaultIntPrecision()}) - val lv_exn_arg = fresh_lvar("exn_arg") - in - LET{pat=[lv_exn_arg], - bind=SELECT(0,SELECT(0,ce)), - scope=compile_seq_switch(VAR lv_exn_arg,selections,opt)} - end - | MulExp.CON0{con,il,aux_regions,alloc} => - let - val sma = convert_alloc(alloc,env) - val smas = List.map (fn alloc => convert_alloc(alloc,env)) aux_regions - in - CON0{con=con, - con_kind=lookup_con env con, - aux_regions=smas, - alloc=sma} - end - | MulExp.CON1({con,il,alloc},tr) => - let - val sma = convert_alloc(alloc,env) - val ce_arg = liftTrip tr env lab - in - CON1{con=con, - con_kind=lookup_con env con, - alloc=sma, - arg=ce_arg} - end - | MulExp.DECON({con,il},tr) => - DECON{con=con, - con_kind=lookup_con env con, - con_exp = liftTrip tr env lab} - | MulExp.EXCON(excon,NONE) => lookup_excon env excon - | MulExp.EXCON(excon,SOME(alloc,tr)) => - RECORD{elems=[lookup_excon env excon,liftTrip tr env lab], - alloc=convert_alloc(alloc,env), - tag=BI.tag_excon1 false, - maybeuntag=false} - | MulExp.DEEXCON(excon,tr) => SELECT(1,liftTrip tr env lab) - | MulExp.RECORD(alloc, trs) => - RECORD{elems=List.map (fn tr => liftTrip tr env lab) trs, - alloc=convert_alloc(alloc,env), - tag=BI.tag_record(false,length trs), - maybeuntag=length trs = 2} (* memo: what if length trs = 3 ? *) - | MulExp.BLOCKF64(alloc, trs) => - BLOCKF64{elems=List.map (fn tr => liftTrip tr env lab) trs, - alloc=convert_alloc(alloc,env), - tag=BI.tag_blockf64(false,length trs)} - | MulExp.SCRATCHMEM(n,alloc) => SCRATCHMEM {bytes=n, - alloc=convert_alloc(alloc,env), - tag=BI.tag_blockf64(false,(8+n-1) div 8)} - | MulExp.SELECT(i,tr) => SELECT(i,liftTrip tr env lab) - | MulExp.REF(a,tr) => REF(convert_alloc(a,env),liftTrip tr env lab) - | MulExp.DEREF tr => DEREF(liftTrip tr env lab) - | MulExp.ASSIGN(alloc,tr1,tr2) => - ASSIGN(convert_alloc(alloc,env), - liftTrip tr1 env lab, - liftTrip tr2 env lab) - | MulExp.DROP(tr) => DROP(liftTrip tr env lab) - | MulExp.EQUAL({mu_of_arg1,mu_of_arg2,alloc},tr1,tr2) => - let - val tau = - (case tr1 of - MulExp.TR(_,RegionExp.Mus[(tau,_)],_,_) => tau - | _ => die "EQUAL.metaType not Mus.") - val ce1 = liftTrip tr1 env lab - val ce2 = liftTrip tr2 env lab - fun eq_prim n = CCALL{name=n,args=[ce1,ce2],rhos_for_result=[]} - in - (case RType.unCONSTYPE tau of - SOME(tn,_,_,_) => - if (TyName.eq(tn,TyName.tyName_BOOL) - orelse TyName.eq(tn,TyName.tyName_REF) - orelse TyName.eq(tn,TyName.tyName_CHARARRAY) - orelse TyName.eq(tn,TyName.tyName_ARRAY)) - then - eq_prim "__equal_int32ub" - else if TyName.eq(tn,TyName.tyName_INT31) then - eq_prim "__equal_int31" - else if TyName.eq(tn,TyName.tyName_INT32) then - (if BI.tag_values() then eq_prim "__equal_int32b" - else eq_prim "__equal_int32ub") - else if TyName.eq(tn,TyName.tyName_WORD31) then - eq_prim "__equal_word31" - else if TyName.eq(tn,TyName.tyName_WORD32) then - (if BI.tag_values() then eq_prim "__equal_word32b" - else eq_prim "__equal_word32ub") - else if TyName.eq(tn,TyName.tyName_INT63) then - eq_prim "__equal_int63" - else if TyName.eq(tn,TyName.tyName_INT64) then - (if BI.tag_values() then eq_prim "__equal_int64b" - else eq_prim "__equal_int64ub") - else if TyName.eq(tn,TyName.tyName_WORD63) then - eq_prim "__equal_word63" - else if TyName.eq(tn,TyName.tyName_WORD64) then - (if BI.tag_values() then eq_prim "__equal_word64b" - else eq_prim "__equal_word64ub") - else if TyName.eq(tn,TyName.tyName_STRING) then - eq_prim "equalStringML" - else if TyName.eq(tn,TyName.tyName_VECTOR) then - die "`=' on vectors! EliminateEq should have dealt with this" - else eq_prim "equalPolyML" - | NONE => case RType.unRECORD tau of - SOME [] => eq_prim "__equal_int32ub" - | _ => eq_prim "equalPolyML") - end - | MulExp.CCALL({name = "id", mu_result, rhos_for_result}, trs) => - (case trs of - [tr] => liftTrip tr env lab - | _ => die "CCALL: ``id'' with more than one tr") - | MulExp.CCALL({name = "pointer", mu_result, rhos_for_result}, trs) => - (case trs of - [tr] => liftTrip tr env lab - | _ => die "CCALL: ``pointer'' with more than one tr") - | MulExp.CCALL({name = "ord", mu_result, rhos_for_result}, trs) => - (case trs of - [tr] => liftTrip tr env lab - | _ => die "CCALL: ``ord'' with more than one tr") - | MulExp.CCALL({name, mu_result, rhos_for_result}, trs) => - (* Regions in mu_result must be passed to the C-function for storing *) - (* the result of the call. Regions are passed in two ways, dependent *) - (* on whether the size of the allocation in the region can be *) - (* determined statically. Either, (1) a pointer to the region is *) - (* passed, or (2) a pointer to already allocated space is passed. *) - (* Regions occurring in mu_result paired with a string type or occur *) - (* in a type (tau list,rho) in mu_result, are passed by passing a *) - (* pointer to the region. For other regions we allocate space *) - (* statically and pass a pointer to the allocated space. Regions *) - (* passed as infinite also have to get the storage mode set for the *) - (* case that the C function calls resetRegion. See also the chapter *) - (* `Calling C Functions' in the documentation. *) - let - fun comp_region_args_sma [] = [] - | comp_region_args_sma ((sma, i_opt)::rest) = - (case i_opt of - SOME 0 => die "liftExp (CCALL ...): argument region with size 0" - | SOME i => PASS_PTR_TO_MEM(sma,i) :: (comp_region_args_sma rest) - | NONE => PASS_PTR_TO_RHO(sma) :: (comp_region_args_sma rest)) - val smas = List.map (fn (alloc,_) => convert_alloc(alloc,env)) rhos_for_result - val i_opts = List.map #2 rhos_for_result - - val ces = List.map (fn tr => liftTrip tr env lab) trs - val smas = comp_region_args_sma (zip(smas,i_opts)) -(* - val maybe_return_unit = - (case mu_result of (* is it actually necessary to return an unit? 13/09-2000, Niels *) - (RType.RECORD [], _) => (fn ce => LET{pat=[fresh_lvar("ccall")],bind=ce, - scope=RECORD{elems=[], - alloc=IGNORE, - tag=BI.tag_ignore}}) - | _ => (fn ce => ce)) -*) - in - (case explode name - of #"@" :: rest => (* AUTO CONVERSION *) - let val name = implode rest - fun ty_trs tr = - case tr - of MulExp.TR(_,RegionExp.Mus[(ty,_)],_,_) => ty - | _ => die "CCALL_AUTO.ty" - fun fty ty : foreign_type = - case RType.unCONSTYPE ty of - SOME(tn,_,_,_) => tn_to_foreign_type tn - | NONE => case RType.unRECORD ty of - SOME [] => Unit - | _ => die "CCALL_AUTO.fty" - val args = ListPair.zip(ces,map (fty o ty_trs) trs) - handle _ => die "CCALL_AUTO.zip" - val res = case fty (#1 mu_result) - of CharArray => die "CCALL_AUTO.CharArray not supported in result" - | t => t - in - (*maybe_return_unit*) - (CCALL_AUTO{name=name,args=args,res=res}) - end - | _ => - (*maybe_return_unit*) - (CCALL{name=name,args=ces,rhos_for_result=smas})) - end - | MulExp.EXPORT({name,mu_arg,mu_res},tr) => - let val ce = liftTrip tr env lab - fun toForeignType (ty,_) : foreign_type = - case RType.unCONSTYPE ty of - SOME(tn,_,_,_) => tn_to_foreign_type tn - | NONE => case RType.unRECORD ty of - SOME [] => Unit - | _ => die "EXPORT.toForeignType" - in - EXPORT{name=name, - clos_lab=Labels.new_named ("ExportClosLab_" ^ name), - arg=(ce,toForeignType mu_arg,toForeignType mu_res)} - end - | MulExp.RESET_REGIONS({force,alloc,regions_for_resetting},tr) => - let - val regions_for_resetting = List.filter (fn alloc => - case alloc of - AtInf.IGNORE => false | _ => true) regions_for_resetting - val smas = List.map (fn alloc => convert_alloc(alloc,env)) regions_for_resetting - in - RESET_REGIONS{force=force, - regions_for_resetting=smas} - end - | MulExp.FRAME{declared_lvars, declared_excons} => - let - val lvars = List.map #lvar declared_lvars - val lvars_and_labels' = - List.map (fn lvar => - (case CE.lookupVar env lvar of - CE.FIX(lab,SOME(CE.LVAR lv_clos),i,formals) => - let - val lab_sclos = fresh_lab(Lvars.pr_lvar lv_clos ^ "_lab") - in - (SOME{lvar=lv_clos,label=lab_sclos},{lvar=lvar,acc_type=CE.FIX(lab,SOME(CE.LABEL lab_sclos),i,formals)}) - end - | CE.FIX(lab,NONE,i,formals) => (NONE,{lvar=lvar,acc_type=CE.FIX(lab,NONE,i,formals)}) - | CE.LVAR lv => - let - val lab = fresh_lab(Lvars.pr_lvar lvar ^ "_lab") - in - (SOME{lvar=lvar,label=lab},{lvar=lvar,acc_type=CE.LABEL lab}) - end - | _ => die "FRAME: lvar not bound to either LVAR or FIX.")) lvars - val (lv_and_lab,frame_env_lv) = ListPair.unzip lvars_and_labels' - val lvars_and_labels = List.foldr (fn (lv_lab,acc) => - case lv_lab of - NONE => acc | SOME lv_lab => lv_lab::acc) [] lv_and_lab - val frame_env_lv = - (ClosConvEnv.empty plus_decl_with CE.declareLvar) - (map (fn {lvar,acc_type} => (lvar,acc_type)) frame_env_lv) - val excons = List.map #1 declared_excons - val excons_and_labels = List.map (fn excon => {excon=excon,label=fresh_lab(Excon.pr_excon excon ^ "_lab")}) excons - val frame_env = - (frame_env_lv plus_decl_with CE.declareExcon) - (map (fn {excon,label} => (excon,(CE.LABEL label, - CE.lookupExconArity env excon))) excons_and_labels) - val _ = set_frame_env frame_env - in - List.foldr (fn ({excon,label},acc) => - let - val ce = lookup_excon env excon -(*mael val _ = print ("Label for excon(" ^ Excon.pr_excon excon ^ ") = " ^ - Labels.pr_label label ^ "\n") -*) - in - LET{pat=[(*fresh_lvar("not_used") *)],bind=STORE(ce,label),scope=acc} - end) - (List.foldr (fn ({lvar,label},acc) => - let -(*mael val _ = print ("Label for lvar(" ^ Lvars.pr_lvar lvar ^ ") = " ^ - Labels.pr_label label ^ "\n") -*) - in - LET{pat=[(* fresh_lvar("not_used") *)],bind=STORE(VAR lvar,label),scope=acc} - end) - (FRAME{declared_lvars=lvars_and_labels,declared_excons=excons_and_labels}) lvars_and_labels) - excons_and_labels - end) - in - liftExp e - end (* End liftTrip *) in fun clos_conv(l2clos_exp_env, Fenv, prog as MulExp.PGM{expression = tr, @@ -3138,71 +2460,6 @@ struct exports=export_labs} end (* End clos_conv *) - (* For bytecode *) - fun lift(clos_env, prog) = - let - val _ = chat "[Lifting for bytecode generation...]" - (* val n_prog = N prog 04/10-2000, Niels *) - val n_prog = prog - - val _ = - if print_normalized_program_p() then - display("\nReport: AFTER NORMALIZATION:", PhysSizeInf.layout_pgm n_prog) - else () - - val Fenv = F n_prog - val prog as MulExp.PGM{expression = tr, - export_datbinds, - import_vars, - export_vars, - export_basis, - export_Psi} = MulExp.k_evalPgm n_prog - - val _ = reset_lvars() - val _ = reset_labs() - val _ = reset_top_decls() - - (* Filter out global exception constructors *) - val import_vars = - let fun member e nil = false - | member e (x::xs) = Excon.eq(e,x) orelse member e xs - fun filter (e, acc) = - if member e [Excon.ex_DIV,Excon.ex_MATCH,Excon.ex_BIND, - Excon.ex_OVERFLOW,Excon.ex_INTERRUPT] then acc - else e::acc - val (lvars,excons,rhos) = - valOf(!import_vars) - handle _ => die "clos_conv: import_vars not specified." - in (lvars, foldl filter nil excons, rhos) - end - - val import_labs = find_globals_in_env import_vars clos_env - - val env_datbind = add_datbinds_to_env export_datbinds CE.empty - val global_env = CE.plus (clos_env, env_datbind) - val _ = set_global_env global_env - val main_lab = fresh_lab "main" - val lift_exp = liftTrip tr global_env main_lab - val _ = add_new_fn(main_lab,CallConv.mk_cc_fn([],NONE,[]),lift_exp) - val export_env = CE.plus (env_datbind, (get_frame_env())) - val export_labs = find_globals_in_env_all (get_frame_env()) - val code = get_top_decls() - val all = - {main_lab=main_lab, - code=code, - env=export_env, - imports=import_labs, - exports=export_labs} - val _ = - if print_lift_conv_program_p() then - (display("\nReport: export_env:", CE.layoutEnv export_env); - display("\nReport: AFTER LIFT: ", layout_clos_prg(#code(all)))) - else - () -(* val _ = print "\nReturning from display.." *) - in - all - end (* End lift *) end val empty = ClosConvEnv.empty diff --git a/src/Compiler/Backend/Dummy/.cvsignore b/src/Compiler/Backend/Dummy/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Compiler/Backend/Dummy/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Compiler/Backend/HpPaRisc/.cvsignore b/src/Compiler/Backend/HpPaRisc/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Compiler/Backend/HpPaRisc/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Compiler/Backend/HpPaRisc/BackendInfo.sml b/src/Compiler/Backend/HpPaRisc/BackendInfo.sml deleted file mode 100644 index 324a7bd2e..000000000 --- a/src/Compiler/Backend/HpPaRisc/BackendInfo.sml +++ /dev/null @@ -1,206 +0,0 @@ -functor BackendInfo(structure Labels : ADDRESS_LABELS - structure Lvars : LVARS - structure Lvarset: LVARSET - sharing type Lvarset.lvar = Lvars.lvar - structure HpPaRisc : HP_PA_RISC - sharing type HpPaRisc.lvar = Lvars.lvar - structure PP : PRETTYPRINT - structure Flags : FLAGS - structure Report : REPORT - sharing type Report.Report = Flags.Report - structure Crash : CRASH) : BACKEND_INFO = - struct - - (***********) - (* 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 ("BackendInfo." ^ s) - - type label = Labels.label - type lvar = Lvars.lvar - type reg = HpPaRisc.reg - type lvarset = Lvarset.lvarset - type offset = int - - val init_clos_offset = 1 (* First offset in FN closure is 1 and code pointer is at offset 0 *) - val init_sclos_offset = 0 (* First offset in shared closure is 0 *) - val init_regvec_offset = 0 (* First offset in region vector is 0 *) - - (******************************) - (* Runtime System Information *) - (******************************) - val pOff = 0 (* Offset for previous region pointer (p) in a region descriptor. *) - val aOff = 1 (* Offset for allocation pointer (a) in a region descriptor. *) - val bOff = 2 (* Offset for border pointer (b) in a region descriptor. *) - val fpOff = 3 (* Offset for first region page pointer (fp) in a region descriptor. *) - - val regionPageTotalSize = 254 (*ALLOCATABLE_WORDS_IN_REGION_PAGE*) + 2 (*HEADER_WORDS_IN_REGION_PAGE*) - val regionPageHeaderSize = 2 (*HEADER_WORDS_IN_REGION_PAGE*) - - (***********) - (* Tagging *) - (***********) - - fun pr_tag_w tag = "0X" ^ (Word32.fmt StringCvt.HEX tag) - (* For now, some tags are in integers but it should be eliminated; max size is then 2047 only 09/01/1999, Niels *) - fun pr_tag_i tag = "0X" ^ (Int.fmt StringCvt.HEX tag) - - fun gen_record_tag(s:int,off:int,i:bool,t:int) = - let - fun pw(s,w) = print (s ^ " is " ^ (Word32.fmt StringCvt.BIN w) ^ "\n") - val w0 = Word32.fromInt 0 - val size = Word32.fromInt s - val offset = Word32.fromInt off - val immovable = if i = true then Word32.fromInt 1 else Word32.fromInt 0 - val tag = Word32.fromInt t - fun or_bits(w1,w2) = Word32.orb(w1,w2) - fun shift_left(num_bits,w) = Word32.<<(w,Word.fromInt num_bits) - val w_size = shift_left(19,size) - val w_offset = or_bits(w_size,shift_left(6,offset)) - val w_immovable = or_bits(w_offset,shift_left(5,immovable)) - val w_tag = or_bits(w_immovable,tag) - in - w_tag - end - - fun gen_string_tag(s:int,i:bool,t:int) = - let - fun pw(s,w) = print (s ^ " is " ^ (Word32.fmt StringCvt.BIN w) ^ "\n") - val w0 = Word32.fromInt 0 - val size = Word32.fromInt s - val immovable = if i = true then Word32.fromInt 1 else Word32.fromInt 0 - val tag = Word32.fromInt t - fun or_bits(w1,w2) = Word32.orb(w1,w2) - fun shift_left(num_bits,w) = Word32.<<(w,Word.fromInt num_bits) - val w_size = shift_left(6,size) - val w_immovable = or_bits(w_size,shift_left(5,immovable)) - val w_tag = or_bits(w_immovable,tag) - in - w_tag - end - - val ml_true = 3 (* The representation of true *) - val ml_false = 1 (* The representation of false *) - val ml_unit = 1 (* The representation of unit *) - - fun tag_real(i:bool) = gen_record_tag(3,3,i,6) - fun tag_string(i:bool,size) = gen_string_tag(size,i,1) - fun tag_record(i:bool,size) = gen_record_tag(size,0,i,6) - fun tag_con0(i:bool,c_tag) = gen_string_tag(c_tag,i,2) - fun tag_con1(i:bool,c_tag) = gen_string_tag(c_tag,i,3) - fun tag_ref(i:bool) = gen_string_tag(0,i,5) - fun tag_clos(i:bool,size,n_skip) = gen_record_tag(size,n_skip,i,6) - fun tag_sclos(i:bool,size,n_skip) = gen_record_tag(size,n_skip,i,6) - fun tag_regvec(i:bool,size) = gen_record_tag(size,size,i,6) - fun tag_table(i:bool,size) = gen_string_tag(size,i,7) - fun tag_exname(i:bool) = gen_record_tag(2,2,i,6) - fun tag_excon0(i:bool) = gen_record_tag(1,0,i,6) - fun tag_excon1(i:bool) = gen_record_tag(2,0,i,6) - val tag_ignore = Word32.fromInt 0 - - val inf_bit = 1 (* We add 1 to an address to set the infinite bit. *) - val atbot_bit = 2 (* We add 2 to an address to set the atbot bit. *) - - val tag_values = Flags.lookup_flag_entry "tag_values" - val tag_integers = Flags.lookup_flag_entry "tag_integers" - - fun size_of_real () = if !tag_values then 4 else 2 - fun size_of_ref () = if !tag_values then 2 else 1 - fun size_of_record l = if !tag_values then List.length l + 1 else List.length l - fun size_of_reg_desc() = 4 - fun size_of_handle() = 4 - - val exn_DIV_lab = Labels.new_named("exnDIV_lab") (* Global exceptions are globally allocated. *) - val exn_MATCH_lab = Labels.new_named("exnMATCH_lab") - val exn_BIND_lab = Labels.new_named("exnBIND_lab") - val exn_OVERFLOW_lab = Labels.new_named("exn_OVERFLOW_lab") - val exn_INTERRUPT_lab = Labels.new_named("exn_INTERRUPT_lab") - - val toplevel_region_withtype_top_lab = Labels.new_named("reg_top") - val toplevel_region_withtype_bot_lab = Labels.new_named("reg_bot") - val toplevel_region_withtype_string_lab = Labels.new_named("reg_string") - val toplevel_region_withtype_real_lab = Labels.new_named("reg_real") - - (* Physical Registers *) - fun is_reg lv = HpPaRisc.is_reg lv - fun lv_to_reg lv = HpPaRisc.lv_to_reg lv - val args_phreg = HpPaRisc.reg_args_as_lvs - val res_phreg = HpPaRisc.reg_res_as_lvs - val args_phreg_ccall = HpPaRisc.reg_args_ccall_as_lvs - val res_phreg_ccall = HpPaRisc.reg_res_ccall_as_lvs - - val all_regs = HpPaRisc.all_regs_as_lvs - - val callee_save_ccall_phregs = HpPaRisc.callee_save_regs_ccall_as_lvs - val callee_save_ccall_phregset = Lvarset.lvarsetof callee_save_ccall_phregs - fun is_callee_save_ccall phreg = Lvarset.member(phreg,callee_save_ccall_phregset) - - val caller_save_ccall_phregs = HpPaRisc.caller_save_regs_ccall_as_lvs - val caller_save_ccall_phregset = Lvarset.lvarsetof caller_save_ccall_phregs - fun is_caller_save_ccall phreg = Lvarset.member(phreg,caller_save_ccall_phregset) - - val callee_save_phregs = HpPaRisc.callee_save_regs_mlkit_as_lvs - val callee_save_phregset = Lvarset.lvarsetof callee_save_phregs - fun is_callee_save phreg = Lvarset.member(phreg,callee_save_phregset) - val caller_save_phregs = HpPaRisc.caller_save_regs_mlkit_as_lvs - val caller_save_phregset = Lvarset.lvarsetof caller_save_phregs - fun is_caller_save phreg = Lvarset.member(phreg,caller_save_phregset) - fun pr_reg phreg = HpPaRisc.pr_reg phreg - fun reg_eq(reg1,reg2) = HpPaRisc.reg_eq(reg1,reg2) - - val init_frame_offset = 0 - - (* Jump Tables *) - val minCodeInBinSearch = 5 - val maxDiff = 10 - val minJumpTabSize = 5 - - (* Names For Primitive Functions *) - val EQUAL_INT = "__equal_int" - val MINUS_INT = "__minus_int" - val PLUS_INT = "__plus_int" - val MUL_INT = "__mul_int" - val NEG_INT = "__neg_int" - val ABS_INT = "__abs_int" - val LESS_INT = "__less_int" - val LESSEQ_INT = "__lesseq_int" - val GREATER_INT = "__greater_int" - val GREATEREQ_INT = "__greatereq_int" - val FRESH_EXN_NAME = "__fresh_exname" - val PLUS_FLOAT = "__plus_float" - val MINUS_FLOAT = "__minus_float" - val MUL_FLOAT = "__mul_float" - val DIV_FLOAT = "__div_float" - val NEG_FLOAT = "__neg_float" - val ABS_FLOAT = "__abs_float" - val LESS_FLOAT = "__less_float" - val LESSEQ_FLOAT = "__lesseq_float" - val GREATER_FLOAT = "__greater_float" - val GREATEREQ_FLOAT = "__greatereq_float" - - val prims = ["__equal_int", "__minus_int", "__plus_int", (* "__mul_int", *) (* treat millicode calls as C calls (e.g., mul) *) - "__neg_int", "__abs_int", "__less_int", "__lesseq_int", (* ; for def-use.. *) - "__greater_int", "__greatereq_int", "__fresh_exname", - "__plus_float", "__minus_float", "__mul_float", (*"__div_float",*) (* calls a C function *) - "__neg_float", "__abs_float", "__less_float", "__lesseq_float", - "__greater_float", "__greatereq_float", "less_word__", "greater_word__", - "lesseq_word__", "greatereq_word__", "plus_word8__", "minus_word8__", - (*"mul_word8__",*) "and__", "or__", "xor__", "shift_left__", "shift_right_signed__", - "shift_right_unsigned__", "plus_word__", "minus_word__" (*, "mul_word__"*)] - - fun member n [] = false - | member n (n'::ns) = n=n' orelse member n ns - - fun is_prim name = member name prims - - val down_growing_stack : bool = false (* true for x86 code generation *) - val double_alignment_required : bool = true (* false for x86 code generation *) - - (* For the KAM machine *) - val env_lvar = Lvars.new_named_lvar("env") - val notused_lvar = Lvars.new_named_lvar("notused") - end - diff --git a/src/Compiler/Backend/HpPaRisc/CodeGen.sml b/src/Compiler/Backend/HpPaRisc/CodeGen.sml deleted file mode 100644 index 908889354..000000000 --- a/src/Compiler/Backend/HpPaRisc/CodeGen.sml +++ /dev/null @@ -1,2242 +0,0 @@ -functor CodeGen(structure Con : CON - structure Excon : EXCON - structure Lvars : LVARS - structure Labels : ADDRESS_LABELS - structure CallConv: CALL_CONV - sharing type CallConv.lvar = Lvars.lvar - structure LineStmt: LINE_STMT - sharing type Con.con = LineStmt.con - sharing type Excon.excon = LineStmt.excon - sharing type Lvars.lvar = LineStmt.lvar = CallConv.lvar - sharing type Labels.label = LineStmt.label - sharing type CallConv.cc = LineStmt.cc - structure SubstAndSimplify: SUBST_AND_SIMPLIFY - sharing type SubstAndSimplify.lvar = LineStmt.lvar - sharing type SubstAndSimplify.place = LineStmt.place -(* sharing type SubstAndSimplify.LinePrg = LineStmt.LinePrg *) - sharing type SubstAndSimplify.label = LineStmt.label - structure HpPaRisc : HP_PA_RISC - sharing type HpPaRisc.label = Labels.label - sharing type HpPaRisc.RI.lvar = Lvars.lvar - sharing type HpPaRisc.RI.reg = SubstAndSimplify.reg - structure BI : BACKEND_INFO - sharing type BI.label = Labels.label - structure JumpTables : JUMP_TABLES - structure HppaResolveJumps : HPPA_RESOLVE_JUMPS - where type AsmPrg = HpPaRisc.AsmPrg - structure PP : PRETTYPRINT - sharing type PP.StringTree = - LineStmt.StringTree = - HpPaRisc.StringTree - structure Flags : FLAGS - structure Report : REPORT - sharing type Report.Report = Flags.Report - structure Crash : CRASH) : CODE_GEN = -struct - - structure RI = HpPaRisc.RI - - val lv_to_reg = RI.lv_to_reg - - type excon = Excon.excon - type con = Con.con - type lvar = Lvars.lvar - type phsize = LineStmt.phsize - type pp = LineStmt.pp - type cc = CallConv.cc - type label = Labels.label - type ('sty,'offset,'aty) LinePrg = ('sty,'offset,'aty) LineStmt.LinePrg - type StoreTypeCO = SubstAndSimplify.StoreTypeCO - type AtySS = SubstAndSimplify.Aty - type reg = HpPaRisc.reg - type offset = int - type AsmPrg = HpPaRisc.AsmPrg - - (***********) - (* 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 ("CodeGen(HP-PARISC)." ^ s) - 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 _ = List.app (fn (k,s,r) => Flags.add_bool_entry - {long=k,short=NONE,item=r,menu=["Printing of intermediate forms",s],neg=false,desc=""}) - [("print_HP-PARISC_program_meta", "print HP-PARISC program (with META instructions)", ref false), - ("print_HP-PARISC_program", "print HP-PARISC program", ref false)] - - val _ = Flags.add_bool_entry - {long="inline_alloc_HP-PARISC", short=NONE, item=ref true, neg=false, - menu=["Control","Lambda Backend", "inline alloc HP-PARISC"], - desc=""} - - - val gc_p = Flags.is_on0 "garbage_collection" - val inline_alloc = Flags.lookup_flag_entry "inline_alloc_HP-PARISC" - val jump_tables = true - - (********************************) - (* CG on Top Level Declarations *) - (********************************) - local - open HpPaRisc - structure SS = SubstAndSimplify - structure LS = LineStmt - - (* 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 stack_bot_gc_lab = NameLab "stack_bot_gc" (* Declared in GC.c *) - val gc_stub_lab = NameLab "__gc_stub" - val global_region_labs = [BI.toplevel_region_withtype_top_lab, - BI.toplevel_region_withtype_string_lab, - BI.toplevel_region_withtype_real_lab] - - (* Eliminate trivial moves, i.e., reg_i = reg_i *) - fun copy(s,t,C) = if s = t then C else COPY{r=s,t=t}::C - - (* Environment holding functions called from this compilation unit. *) - local - structure LibFunSet = - OrderSet(structure Order = - struct - type T = string - fun lt(l1: T) l2 = l1 < l2 - end - structure PP =PP - structure Report = Report) - val lib_functions = ref LibFunSet.empty - in - fun add_lib_function str = lib_functions := LibFunSet.insert str (!lib_functions) - fun reset_lib_functions () = lib_functions := LibFunSet.empty - fun get_lib_functions C = - List.foldr (fn (str,C) => DOT_IMPORT(NameLab str, "CODE") :: C) C (LibFunSet.list (!lib_functions)) - end - - (* 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_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 reset_label_counter() = counter := 0 - end - - (* Static Data inserted at end of this compilation unit. *) - local - val static_data : RiscInst 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 - - (* Convert ~n to -n *) - fun int_to_string 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 - | IMMED of int - - (* Can be used to load from the stack or from a record *) - (* dst = base[x] *) - (* Kills Gen 1 *) - fun load_indexed_kill_gen1(dst_reg:reg,base_reg:reg,offset:Offset,C) = - let - val x = - case offset of - BYTES x => x - | WORDS x => x*4 - | _ => die "load_indexed_kill_gen1: offset not in BYTES or WORDS" - in - if is_im14 x then - LDW{d=int_to_string x,s=Space 0,b=base_reg,t=dst_reg} :: C - else - ADDIL{i="L'" ^ int_to_string x,r=base_reg} :: - LDW{d="R'" ^ int_to_string x,s=Space 0,b=Gen 1,t=dst_reg} :: C - end - - (* Can be used to update the stack or store in a record *) - (* base[x] = src *) - (* Kills Gen 1 *) - fun store_indexed_kill_gen1(base_reg:reg,offset:Offset,src_reg:reg,C) = - let - val x = - case offset of - BYTES x => x - | WORDS x => x*4 - | _ => die "store_indexed_kill_gen1: offset not in BYTES or WORDS" - in - if is_im14 x then - STW {r=src_reg,d=int_to_string x,s=Space 0,b=base_reg} :: C - else - ADDIL {i="L'" ^ int_to_string x,r=base_reg} :: - STW {r=src_reg,d="R'" ^ int_to_string x,s=Space 0,b=Gen 1} :: C - end - - (* Calculate an addres given a base and an offset *) - (* dst = base + x *) - (* Kills Gen 1 *) - fun base_plus_offset_kill_gen1(base_reg:reg,offset:Offset,dst_reg:reg,C) = - let - val x = - case offset of - BYTES x => x - | WORDS x => x*4 - | _ => die "base_plus_offset_kill_gen1: offset not in BYTES or WORDS" - in - if is_im14 x then - LDO {d=int_to_string x,b=base_reg,t=dst_reg} :: C - else - ADDIL {i="L'" ^ int_to_string x,r=base_reg} :: - LDO {d="R'" ^ int_to_string x,b=Gen 1,t=dst_reg} :: C - end - - (* Load a constant *) - (* dst = x *) - (* Kills no regs. *) - fun load_immed(IMMED x,dst_reg:reg,C) = - if is_im14 x then - LDI {i=int_to_string x, t=dst_reg} :: C - else - LDIL {i="L'" ^ int_to_string x, t=dst_reg} :: - LDO {d="R'" ^ int_to_string x,b=dst_reg,t=dst_reg} :: C - | load_immed _ = die "load_immed: immed not in IMMED" - - fun load_immed'(x,dst_reg:reg,C) = - let - val x_i = (Option.valOf(Int32.fromString x)) - in - if x_i < 8192 andalso x_i >= ~8192 then (*is_im14 *) - LDI {i= x, t=dst_reg} :: C - else - LDIL {i="L'" ^ x, t=dst_reg} :: - LDO {d="R'" ^ x,b=dst_reg,t=dst_reg} :: C - end - - (* Find a register for aty and generate code to store into the aty *) - fun resolve_aty_def_kill_gen1(SS.STACK_ATY offset,t:reg,size_ff,C) = (t,store_indexed_kill_gen1(sp,WORDS(~size_ff+offset),t,C)) - | resolve_aty_def_kill_gen1(SS.PHREG_ATY phreg,t:reg,size_ff,C) = (phreg,C) - | resolve_aty_def_kill_gen1(SS.UNIT_ATY,t:reg,size_ff,C) = (t,C) - | resolve_aty_def_kill_gen1 _ = die "resolve_aty_def_kill_gen1: ATY cannot be defined" - - (* Make sure that the aty ends up in register dst_reg *) - fun move_aty_into_reg_kill_gen1(SS.REG_I_ATY offset,dst_reg,size_ff,C) = base_plus_offset_kill_gen1(sp,BYTES(~size_ff*4+offset*4+BI.inf_bit),dst_reg,C) - | move_aty_into_reg_kill_gen1(SS.REG_F_ATY offset,dst_reg,size_ff,C) = base_plus_offset_kill_gen1(sp,WORDS(~size_ff+offset),dst_reg,C) - | move_aty_into_reg_kill_gen1(SS.STACK_ATY offset,dst_reg,size_ff,C) = load_indexed_kill_gen1(dst_reg,sp,WORDS(~size_ff+offset),C) - | move_aty_into_reg_kill_gen1(SS.DROPPED_RVAR_ATY,dst_reg,size_ff,C) = C - | move_aty_into_reg_kill_gen1(SS.PHREG_ATY phreg,dst_reg,size_ff,C) = copy(phreg,dst_reg,C) - | move_aty_into_reg_kill_gen1(SS.INTEGER_ATY i,dst_reg,size_ff,C) = load_immed'(i,dst_reg,C) (* Integers are tagged in ClosExp *) - | move_aty_into_reg_kill_gen1(SS.UNIT_ATY,dst_reg,size_ff,C) = load_immed(IMMED BI.ml_unit,dst_reg,C) - | move_aty_into_reg_kill_gen1 _ = die "move_aty_into_reg_kill_gen1: ATY cannot be moved" - - fun resolve_arg_kill_gen1(arg: SS.Aty, tmp:reg, size_ff:int) : reg * (RiscInst list -> RiscInst list) = - case arg - of SS.PHREG_ATY r => (r, fn C => C) - | _ => (tmp, fn C => move_aty_into_reg_kill_gen1(arg, tmp, size_ff, C)) - - (* dst_aty = src_reg *) - fun move_reg_into_aty_kill_gen1(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_kill_gen1(sp,WORDS(~size_ff+offset),src_reg,C) - | _ => die "move_reg_into_aty_kill_gen1: ATY not recognized" - - (* dst_aty = src_aty *) - fun move_aty_to_aty_kill_gen1(SS.PHREG_ATY src_reg,dst_aty,size_ff,C) = move_reg_into_aty_kill_gen1(src_reg,dst_aty,size_ff,C) - | move_aty_to_aty_kill_gen1(src_aty,SS.PHREG_ATY dst_reg,size_ff,C) = move_aty_into_reg_kill_gen1(src_aty,dst_reg,size_ff,C) - | move_aty_to_aty_kill_gen1(src_aty,dst_aty,size_ff,C) = - let - val (reg_for_result,C') = resolve_aty_def_kill_gen1(dst_aty,tmp_reg1,size_ff,C) - in - move_aty_into_reg_kill_gen1(src_aty,reg_for_result,size_ff,C') - end - - (* dst_aty = src_aty[offset] *) - fun move_index_aty_to_aty_kill_gen1(SS.PHREG_ATY src_reg,SS.PHREG_ATY dst_reg,offset:Offset,t:reg,size_ff,C) = - load_indexed_kill_gen1(dst_reg,src_reg,offset,C) - | move_index_aty_to_aty_kill_gen1(SS.PHREG_ATY src_reg,dst_aty,offset:Offset,t:reg,size_ff,C) = - load_indexed_kill_gen1(t,src_reg,offset, - move_reg_into_aty_kill_gen1(t,dst_aty,size_ff,C)) - | move_index_aty_to_aty_kill_gen1(src_aty,dst_aty,offset,t:reg,size_ff,C) = - move_aty_into_reg_kill_gen1(src_aty,t,size_ff, - load_indexed_kill_gen1(t,t,offset, - move_reg_into_aty_kill_gen1(t,dst_aty,size_ff,C))) - - (* dst_aty = &lab *) - (* Kills Gen 1 *) - fun load_label_addr_kill_gen1(lab,dst_aty,t:reg,size_ff,C) = - let - val (reg_for_result,C') = resolve_aty_def_kill_gen1(dst_aty,t,size_ff,C) - in - ADDIL'{pr_i=fn () => "L'" ^ pp_lab lab ^ "-$global$",r=dp} :: - LDO'{pr_d=fn () => "R'" ^ pp_lab lab ^ "-$global$",b=Gen 1,t=reg_for_result} :: C' - end - - (* dst_aty = lab[0] *) - (* Kills Gen 1 *) - fun load_from_label_kill_gen1(lab,dst_aty,t:reg,size_ff,C) = - let - val (reg_for_result,C') = resolve_aty_def_kill_gen1(dst_aty,t,size_ff,C) - in - ADDIL'{pr_i=fn () => "L'" ^ pp_lab lab ^ "-$global$",r=dp} :: - LDW'{pr_d=fn () => "R'" ^ pp_lab lab ^ "-$global$",b=Gen 1,t=reg_for_result,s=Space 0} :: C' - end - - (* lab[0] = src_aty *) - (* Kills Gen 1 *) - fun store_in_label_kill_gen1(SS.PHREG_ATY src_reg,label,tmp1:reg,size_ff,C) = - ADDIL'{pr_i=fn () => "L'" ^ pp_lab label ^ "-$global$",r=dp} :: - STW'{r=src_reg,pr_d=fn () => "R'" ^ pp_lab label ^ "-$global$",b=Gen 1,s=Space 0} :: C - | store_in_label_kill_gen1(src_aty,label,tmp1:reg,size_ff,C) = - move_aty_into_reg_kill_gen1(src_aty,tmp1,size_ff, - ADDIL'{pr_i=fn () => "L'" ^ pp_lab label ^ "-$global$",r=dp} :: - STW'{r=tmp1,pr_d=fn () => "R'" ^ pp_lab label ^ "-$global$",s=Space 0,b=Gen 1} :: C) - - (* Generate a string label *) - fun gen_string_lab str = - let - val string_lab = new_string_lab() - val _ = add_static_data [DOT_DATA, - DOT_ALIGN 4, - LABEL string_lab, - DOT_WORD(BI.pr_tag_w(BI.tag_string(true,size(str)))), - DOT_WORD (Int.toString(size(str))), - DOT_WORD "0", (* NULL pointer to next fragment. *) - DOT_STRINGZ str] - in - string_lab - end - - (* Generate a Data label *) - fun gen_data_lab lab = - add_static_data [DOT_DATA, - DOT_ALIGN 4, - LABEL(DatLab lab), - DOT_WORD (int_to_string BI.ml_unit)] (* was "0", but use ML-unit for GC 2001-01-09, Niels *) - - (* 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_kill_gen1(SS.PHREG_ATY src_reg,t:reg,base_reg,offset:Offset,size_ff,C) = - store_indexed_kill_gen1(base_reg,offset,src_reg,C) - | store_aty_in_reg_record_kill_gen1(src_aty,t:reg,base_reg,offset:Offset,size_ff,C) = - move_aty_into_reg_kill_gen1(src_aty,t,size_ff, - store_indexed_kill_gen1(base_reg,offset,t,C)) - - (* Can be used to load form the stack or a record when destination is an ATY *) - (* dst_aty = base_reg[offset] *) - fun load_aty_from_reg_record_kill_gen1(SS.PHREG_ATY dst_reg,t:reg,base_reg,offset:Offset,size_ff,C) = - load_indexed_kill_gen1(dst_reg,base_reg,offset,C) - | load_aty_from_reg_record_kill_gen1(dst_aty,t:reg,base_reg,offset:Offset,size_ff,C) = - load_indexed_kill_gen1(t,base_reg,offset, - move_reg_into_aty_kill_gen1(t,dst_aty,size_ff,C)) - - (* base_aty[offset] = src_aty *) - fun store_aty_in_aty_record_kill_reg1(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_kill_gen1(base_reg,offset,src_reg,C) - | (SS.PHREG_ATY src_reg,base_aty) => - move_aty_into_reg_kill_gen1(base_aty,t2,size_ff, - store_indexed_kill_gen1(t2,offset,src_reg,C)) - | (src_aty,SS.PHREG_ATY base_reg) => - move_aty_into_reg_kill_gen1(src_aty,t1,size_ff, - store_indexed_kill_gen1(base_reg,offset,t1,C)) - | (src_aty,base_aty) => - move_aty_into_reg_kill_gen1(src_aty,t1,size_ff, - move_aty_into_reg_kill_gen1(base_aty,t2,size_ff, - store_indexed_kill_gen1(t2,offset,t1,C)))) - - (* push(aty), i.e., sp[0] = aty ; sp+=4 *) - (* size_ff is for sp before sp is moved. *) - fun push_aty_kill_gen1(SS.PHREG_ATY aty_reg,t:reg,size_ff,C) = STWM{r=aty_reg,d="4",s=Space 0,b=sp} :: C - | push_aty_kill_gen1(aty,t:reg,size_ff,C) = move_aty_into_reg_kill_gen1(aty,t,size_ff, - STWM{r=t,d="4",s=Space 0,b=sp} :: C) - - (* pop(aty), i.e., sp-=4; aty=sp[0] *) - (* size_ff is for sp after pop *) - fun pop_aty_kill_gen1(SS.PHREG_ATY aty_reg,t:reg,size_ff,C) = LDWM{d="-4",s=Space 0,b=sp,t=aty_reg} :: C - | pop_aty_kill_gen1(aty,t:reg,size_ff,C) = - LDWM{d="-4",s=Space 0,b=sp,t=t} :: - move_reg_into_aty_kill_gen1(t,aty,size_ff,C) - - (* Returns a register with arg and a continuation function. *) - fun resolve_arg_aty_kill_gen1(arg:SS.Aty,t:reg,size_ff:int) : reg * (RiscInst list -> RiscInst list) = - case arg - of SS.PHREG_ATY r => (r, fn C => C) - | _ => (t, fn C => move_aty_into_reg_kill_gen1(arg,t,size_ff,C)) - - (* Returns a floating point register and a continuation function. *) - fun resolve_float_aty_arg_kill_gen1(float_aty,t,tmp_float,size_ff) = - let - val disp = - if BI.tag_values() then - "8" - else - "0" - in - case float_aty of - SS.PHREG_ATY x => (tmp_float,fn C => FLDDS{complt=EMPTY,d=disp,s=Space 0,b=x,t=tmp_float} :: C) - | _ => (tmp_float,fn C => move_aty_into_reg_kill_gen1(float_aty,t,size_ff, - FLDDS{complt=EMPTY,d=disp,s=Space 0,b=t,t=tmp_float} :: C)) - end - - fun box_float_reg(base_reg,float_reg,t:reg,C) = - if BI.tag_values() then - load_immed(IMMED (Word32.toInt(BI.tag_real(false))),t, - STW{r=t,d="0",s=Space 0,b=base_reg} :: - FSTDS{complt=EMPTY,r=float_reg,d="8",s=Space 0,b=base_reg} :: C) - else - FSTDS {complt=EMPTY,r=float_reg,d="0",s=Space 0,b=base_reg} :: C - - (***********************) - (* Calling C Functions *) - (***********************) - fun align_stack_kill_gen1(t:reg,C) = (* MEGA HACK *) - copy(sp, t, - load_immed(IMMED 60,Gen 1, - ANDCM{cond=NEVER,r1=Gen 1,r2=sp,t=Gen 1} :: - ADD{cond=NEVER,r1=Gen 1,r2=sp,t=sp} :: - STWM {r=t,d="1028",s=Space 0,b=sp} :: C)) - - (* Kills no registers. *) - fun restore_stack C = LDW {d="-1028",s=Space 0,b=sp,t=sp} :: C - - fun compile_c_call_prim(name: string,args: SS.Aty list,opt_ret: SS.Aty option,size_ff:int,tmp:reg,C) = - let - val _ = add_lib_function name - val (convert: bool,name: string) = - (case explode name of - #"@" :: rest => (BI.tag_integers(), implode rest) - | _ => (false, name)) - - fun convert_int_to_c(reg,C) = - if convert then - SHD {cond=NEVER, r1=Gen 0, r2=reg, p="1" , t=reg} :: C - else - C - - fun convert_int_to_ml(reg,C) = - if convert then - SH1ADD {cond=NEVER, r1=reg, r2=Gen 0, t=reg} :: - LDO {d="1", b=reg, t=reg} :: C - else - C - - fun arg_str(n,[]) = "" - | arg_str(n,[a]) = "ARGW" ^ Int.toString n ^ "=GR" - | arg_str(n,a::rest) = - if n<3 then - arg_str(n,[a]) ^ ", " ^ arg_str(n+1,rest) - else - arg_str(n,[a]) - - val call_str = arg_str(0,args) ^ - (case opt_ret - of SOME _ => (if length args > 0 then ", " else "") ^ "RTNVAL=GR" - | NONE => "") - - fun fetch_args_ext([],_,C) = C - | fetch_args_ext(r::rs,offset,C) = - move_aty_into_reg_kill_gen1(r,tmp,size_ff, - convert_int_to_c(tmp, - STW{r=tmp,d="-" ^ Int.toString offset,s=Space 0,b=sp} :: - fetch_args_ext(rs,offset+4,C))) - - (* The stack is aligned before arguments are flushed on the stack. *) - fun fetch_args([],_,C) = align_stack_kill_gen1(tmp,C) - | fetch_args(r::rs,ar::ars,C) = - move_aty_into_reg_kill_gen1(r,ar,size_ff, - convert_int_to_c(ar,fetch_args(rs,ars,C))) - | fetch_args(rs,[],C) = align_stack_kill_gen1(tmp,fetch_args_ext(rs,52,C)) (* arg4 is at offset sp-52 *) - - fun store_ret(SOME d,C) = - convert_int_to_ml(ret0, - move_reg_into_aty_kill_gen1(ret0,d,size_ff,C)) - | store_ret(NONE,C) = C - in - fetch_args(args,[arg0, arg1, arg2, arg3], - META_BL{n=false,target=NameLab name,rpLink=rp,callStr=call_str} :: - restore_stack(store_ret(opt_ret,C))) - 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,DOT_WORD("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 mrp *) - fun do_gc(reg_map: Word32.word,C) = - if gc_p() then - let - val _ = add_lib_function (pp_lab gc_stub_lab) - 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_kill_gen1(time_to_gc_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, (* tmp_reg1 = &gc_flag *) - LDW{d="0",s=Space 0,b=tmp_reg1,t=tmp_reg1} :: (* tmp_reg1 = gc_flag *) - META_IF{cond=NOTEQUAL,r1=Gen 0,r2=tmp_reg1,target=l} :: (* destroys tmp_reg0 *) - LDIL{i="L'" ^ reg_map_immed,t=tmp_reg1} :: (* tmp_reg1 = reg_map *) - LDO{d="R'" ^ reg_map_immed,b=tmp_reg1,t=tmp_reg1} :: - load_label_addr_kill_gen1(l,SS.PHREG_ATY mrp,mrp,size_ff, (* mrp = return address *) - META_B{n=false,target=gc_stub_lab} :: (* META_B destroys tmp_reg0 *) - LABEL 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) = -(* compile_c_call_prim("resetRegion",[SS.PHREG_ATY t],SOME(SS.PHREG_ATY t),size_ff,tmp,C)*) - let - val _ = add_lib_function "__reset_region" - val l = new_local_lab "return_from_alloc" - in - copy(t,tmp_reg1, - load_label_addr_kill_gen1(l,SS.PHREG_ATY mrp,mrp,size_ff, - STWM {r=mrp, d="4", s=Space 0, b=sp} :: - META_B{n=false,target=NameLab "__reset_region"} :: (* META_B destroys tmp_reg0 *) - LABEL l :: - copy(tmp_reg1,t,C))) - end - - fun alloc_kill_gen1_tmp0_1(t:reg,n:int,size_ff,C) = - if !inline_alloc then - if gc_p() then - let - val _ = add_lib_function "__inline_allocate_gc" - val l = new_local_lab "return_from_alloc" - in - copy(t,tmp_reg1, - load_label_addr_kill_gen1(l,SS.PHREG_ATY mrp,mrp,size_ff, - STWM {r=mrp, d="4", s=Space 0, b=sp} :: - load_immed(IMMED(n*4), mrp, - META_B{n=false,target=NameLab "__inline_allocate_gc"} :: (* META_B destroys tmp_reg0 *) - LABEL l :: - copy(tmp_reg1,t,C)))) - end - else - let - val _ = add_lib_function "__inline_allocate" - val l = new_local_lab "return_from_alloc" - in - copy(t,tmp_reg1, - load_label_addr_kill_gen1(l,SS.PHREG_ATY mrp,mrp,size_ff, - STWM {r=mrp, d="4", s=Space 0, b=sp} :: - load_immed(IMMED(n*4), mrp, - META_B{n=false,target=NameLab "__inline_allocate"} :: (* META_B destroys tmp_reg0 *) - LABEL l :: - copy(tmp_reg1,t,C)))) - end - else - let - val _ = add_lib_function "__allocate" - val l = new_local_lab "return_from_alloc" - in - copy(t,tmp_reg1, - load_label_addr_kill_gen1(l,SS.PHREG_ATY mrp,mrp,size_ff, - STWM {r=mrp, d="4", s=Space 0, b=sp} :: - load_immed(IMMED n, mrp, - META_B{n=false,target=NameLab "__allocate"} :: (* META_B destroys tmp_reg0 *) - LABEL l :: - copy(tmp_reg1,t,C)))) - end - - fun clear_status_bits(t,C) = DEPI{cond=NEVER,i="0",p="31",len="2",t=t}::C - fun set_atbot_bit(dst_reg:reg,C) = DEPI{cond=NEVER,i="1",p="30",len="1",t=dst_reg} :: C - fun clear_atbot_bit(dst_reg:reg,C) = DEPI{cond=NEVER,i="0",p="30",len="1",t=dst_reg} :: C - fun set_inf_bit(dst_reg:reg,C) = DEPI{cond=NEVER,i="1",p="31",len="1",t=dst_reg} :: C - - (* move_aty_into_reg_kill_gen1_ap differs from move_aty_into_reg_kill_gen1 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_kill_gen1_ap(aty,dst_reg,size_ff,C) = - (case aty of - SS.REG_I_ATY offset => base_plus_offset_kill_gen1(sp,BYTES(~size_ff*4+offset*4(*+BI.inf_bit*)),dst_reg, - set_inf_bit(dst_reg,C)) - | SS.REG_F_ATY offset => base_plus_offset_kill_gen1(sp,WORDS(~size_ff+offset),dst_reg,C) - | SS.STACK_ATY offset => load_indexed_kill_gen1(dst_reg,sp,WORDS(~size_ff+offset),C) - | SS.PHREG_ATY phreg => copy(phreg,dst_reg, C) - | _ => die "move_aty_into_reg_kill_gen1_ap: ATY cannot be used to allocate memory") - - fun alloc_ap_kill_gen1_tmp0_1_2(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_kill_gen1_ap(aty,dst_reg,size_ff,alloc_kill_gen1_tmp0_1(dst_reg,n,size_ff,C)) - | LS.ATTOP_LF(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,C) - | LS.ATTOP_FI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,alloc_kill_gen1_tmp0_1(dst_reg,n,size_ff,C)) - | LS.ATTOP_FF(aty,pp) => - let - val default_lab = new_local_lab "no_alloc" - in - move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff, - META_IF_BIT{r=dst_reg,bitNo=31,target=default_lab} :: (* inf bit set? *) - alloc_kill_gen1_tmp0_1(dst_reg,n,size_ff,LABEL default_lab :: C)) - end - | LS.ATBOT_LI(aty,pp) => - move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff, - reset_region(dst_reg,tmp_reg0,size_ff, (* dst_reg is preserved for alloc *) - alloc_kill_gen1_tmp0_1(dst_reg,n,size_ff,C))) - | LS.ATBOT_LF(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,C) (* atbot bit not set; its a finite region *) - | LS.SAT_FI(aty,pp) => - let - val default_lab = new_local_lab "no_reset" - in - move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff, - META_IF_BIT{r=dst_reg,bitNo=30,target=default_lab} :: (* atbot bit set? *) - reset_region(dst_reg,tmp_reg0,size_ff,LABEL default_lab :: (* dst_reg is preverved over the call *) - alloc_kill_gen1_tmp0_1(dst_reg,n,size_ff,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_kill_gen1_ap(aty,dst_reg,size_ff, - META_IF_BIT{r=dst_reg,bitNo=31,target=finite_lab} :: (* inf bit set? *) - META_IF_BIT{r=dst_reg,bitNo=30,target=attop_lab} :: (* atbot bit set? *) - reset_region(dst_reg,tmp_reg0,size_ff,LABEL attop_lab :: (* dst_reg is preserved over the call *) - alloc_kill_gen1_tmp0_1(dst_reg,n,size_ff,LABEL finite_lab :: C))) - end) - - (* Set Atbot bits on region variables *) - fun prefix_sm_kill_gen1(sma,dst_reg:reg,size_ff,C) = - (case sma of - LS.ATTOP_LI(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATTOP_LF(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATTOP_FI(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATTOP_FF(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATBOT_LI(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATBOT_LF(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.SAT_FI(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.SAT_FF(SS.DROPPED_RVAR_ATY,pp) => die "prefix_sm_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.IGNORE => die "prefix_sm_kill_gen1: IGNORE not implemented." - | LS.ATTOP_LI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,C) - | LS.ATTOP_LF(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,C) - | LS.ATTOP_FI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,clear_atbot_bit(dst_reg,C)) - | LS.ATTOP_FF(aty,pp) => - move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff, - clear_atbot_bit(dst_reg,C)) (* It is necessary to clear atbot bit because the region may be infinite *) - | LS.ATBOT_LI(SS.REG_I_ATY offset_reg_i,pp) => - base_plus_offset_kill_gen1(sp,BYTES(~size_ff*4+offset_reg_i*4(*+BI.inf_bit+BI.atbot_bit*)),dst_reg, - set_inf_bit(dst_reg, - set_atbot_bit(dst_reg,C))) - | LS.ATBOT_LI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,set_atbot_bit(dst_reg,C)) - | LS.ATBOT_LF(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,C) - | LS.SAT_FI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,C) - | LS.SAT_FF(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,dst_reg,size_ff,C)) - - (* Used to build a region vector *) - fun store_sm_in_record_kill_gen1(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_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATTOP_LF(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATTOP_FI(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATTOP_FF(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATBOT_LI(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.ATBOT_LF(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.SAT_FI(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.SAT_FF(SS.DROPPED_RVAR_ATY,pp) => die "store_sm_in_record_kill_gen1: DROPPED_RVAR_ATY not implemented." - | LS.IGNORE => die "store_sm_in_record_kill_gen1: IGNORE not implemented." - | LS.ATTOP_LI(SS.PHREG_ATY phreg,pp) => store_indexed_kill_gen1(base_reg,offset,phreg,C) - | LS.ATTOP_LI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,tmp,size_ff, - store_indexed_kill_gen1(base_reg,offset,tmp,C)) - | LS.ATTOP_LF(SS.PHREG_ATY phreg,pp) => store_indexed_kill_gen1(base_reg,offset,phreg,C) - | LS.ATTOP_LF(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,tmp,size_ff, - store_indexed_kill_gen1(base_reg,offset,tmp,C)) - | LS.ATTOP_FI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,tmp,size_ff, - clear_atbot_bit(tmp, - store_indexed_kill_gen1(base_reg,offset,tmp,C))) - | LS.ATTOP_FF(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,tmp,size_ff, - clear_atbot_bit(tmp, (* The region may be infinite so we clear the atbot bit *) - store_indexed_kill_gen1(base_reg,offset,tmp,C))) - | LS.ATBOT_LI(SS.REG_I_ATY offset_reg_i,pp) => - base_plus_offset_kill_gen1(sp,BYTES(~size_ff*4+offset_reg_i*4(*+BI.inf_bit+BI.atbot_bit*)),tmp, - set_inf_bit(tmp, - set_atbot_bit(tmp, - store_indexed_kill_gen1(base_reg,offset,tmp,C)))) - | LS.ATBOT_LI(aty,pp) => - move_aty_into_reg_kill_gen1_ap(aty,tmp,size_ff, - set_atbot_bit(tmp, - store_indexed_kill_gen1(base_reg,offset,tmp,C))) - | LS.ATBOT_LF(SS.PHREG_ATY phreg,pp) => store_indexed_kill_gen1(base_reg,offset,phreg,C) (* The region is finite so no atbot bit is necessary *) - | LS.ATBOT_LF(aty,pp) => - move_aty_into_reg_kill_gen1_ap(aty,tmp,size_ff, - store_indexed_kill_gen1(base_reg,offset,tmp,C)) - | LS.SAT_FI(SS.PHREG_ATY phreg,pp) => store_indexed_kill_gen1(base_reg,offset,phreg,C) (* The storage bit is already recorded in phreg *) - | LS.SAT_FI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,tmp,size_ff, - store_indexed_kill_gen1(base_reg,offset,tmp,C)) - | LS.SAT_FF(SS.PHREG_ATY phreg,pp) => store_indexed_kill_gen1(base_reg,offset,phreg,C) (* The storage bit is already recorded in phreg *) - | LS.SAT_FF(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,tmp,size_ff, - store_indexed_kill_gen1(base_reg,offset,tmp,C))) - - fun force_reset_aux_region_kill_gen1_tmp0(sma,t:reg,size_ff,C) = - (case sma of - LS.ATBOT_LI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,t,size_ff, - reset_region(t,tmp_reg0,size_ff,C)) - | LS.SAT_FI(aty,pp) => move_aty_into_reg_kill_gen1_ap(aty,t,size_ff, (* We do not check the storage mode *) - reset_region(t,tmp_reg0,size_ff,C)) - | LS.SAT_FF(aty,pp) => - let - val default_lab = new_local_lab "no_reset" - in - move_aty_into_reg_kill_gen1_ap(aty,t,size_ff, (* We check the inf bit but not the storage mode *) - META_IF_BIT{r=t,bitNo=31,target=default_lab} :: (* Is region infinite? kill tmp_reg0. *) - reset_region(t,tmp_reg0,size_ff,LABEL default_lab :: C)) - end - | _ => C) - - fun maybe_reset_aux_region_kill_gen1_tmp0(sma,t:reg,size_ff,C) = - (case sma of - LS.ATBOT_LI(aty,pp) => move_aty_into_reg_kill_gen1_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_kill_gen1_ap(aty,t,size_ff, - META_IF_BIT{r=t,bitNo=30,target=default_lab} :: (* Is storage mode atbot? kill tmp_reg0. *) - reset_region(t,tmp_reg0,size_ff,LABEL default_lab :: C)) - end - | LS.SAT_FF(aty,pp) => - let - val default_lab = new_local_lab "no_reset" - in - move_aty_into_reg_kill_gen1_ap(aty,t,size_ff, - META_IF_BIT{r=t,bitNo=31,target=default_lab} :: (* Is region infinite? *) - META_IF_BIT{r=t,bitNo=30,target=default_lab} :: (* Is atbot bit set? *) - reset_region(t,tmp_reg0,size_ff,LABEL default_lab :: C)) - end - | _ => C) - - (* Compile Switch Statements *) - local - fun comment(str,C) = COMMENT str :: C - fun new_label str = new_local_lab str - fun label(lab,C) = LABEL lab :: C - fun jmp(lab,C) = META_B{n=false,target=lab} :: C - in - fun linear_search(sels, - default, - compile_sel:'sel * RiscInst list -> RiscInst list, - if_no_match_go_lab: lab * RiscInst list -> RiscInst list, - compile_insts,C) = - JumpTables.linear_search(sels, - default, - comment, - new_label, - compile_sel, - if_no_match_go_lab, - compile_insts, - label, - jmp, - C) - - fun binary_search(sels, - default, - opr_reg: reg, - compile_insts, - C) = - let - val compile_sel = fn (i,C) => load_immed(IMMED i, mrp, C) (* compile_sel *) - val if_not_equal_go_lab = fn (lab,C) => META_IF{cond=EQUAL,r1=opr_reg,r2=mrp,target=lab} :: C (* if_not_equal_go_lab *) - in - if jump_tables then - JumpTables.binary_search(sels, - default, - comment, - new_label, - compile_sel, - if_not_equal_go_lab, - fn (lab,C) => META_IF{cond=GREATEREQUAL,r1=opr_reg,r2=mrp,target=lab} :: C, (* if_less_than_go_lab *) - fn (lab,C) => META_IF{cond=LESSEQUAL,r1=opr_reg,r2=mrp,target=lab} :: C, (* if_greater_than_go_lab *) - compile_insts, - label, - jmp, - fn (sel1,sel2) => Int.abs(sel1-sel2), (* sel_dist *) - fn (lab,sel,C) => (ADDIL{i="L'" ^ (pp_lab lab) ^ "-(4*" ^ int_to_string sel ^ ")", r=Gen 0} :: (* jump_table_header *) - SH2ADD{cond=NEVER, r1=opr_reg, r2=Gen 1, t=Gen 1} :: - LDW{d="R'" ^ (pp_lab lab) ^ "-(4*" ^ int_to_string sel ^ ")", s=Space 0, b=Gen 1, t=mrp} :: - META_BV{n=false, x=Gen 0, b=mrp} :: C), - fn (lab,C) => DOT_WORD (pp_lab lab) :: C, (* add_label_to_jump_tab *) - eq_lab, - C) - else - linear_search(sels, - default, - compile_sel, - if_not_equal_go_lab, - compile_insts, - C) - end - end - - fun cmpi(cond,x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,mrp,size_ff,C) - in - if x_reg=d_reg orelse y_reg=d_reg then (* In this case, we must preserve x_reg and y_reg. *) - x_C(y_C(LDI {i=int_to_string BI.ml_true, t=rp} :: - COMCLR {cond=cond,r1=x_reg,r2=y_reg,t=Gen 1} :: - LDI {i=int_to_string BI.ml_false,t=rp} :: - copy(rp,d_reg,C'))) - else - x_C(y_C(LDI {i=int_to_string BI.ml_true, t=d_reg} :: - COMCLR {cond=cond,r1=x_reg,r2=y_reg,t=Gen 1} :: - LDI {i=int_to_string BI.ml_false,t=d_reg} :: C')) - end - - fun cmpi_and_jmp(cond,x,y,lab_t,lab_f,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - in - x_C(y_C(META_IF{cond=cond,r1=x_reg,r2=y_reg,target=lab_f} :: - META_B{n=false,target=lab_t} :: C)) - end - - fun maybe_tag_integers(inst,C) = - if BI.tag_integers() then - inst :: C - else - C - - fun subi(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(SUBO{cond=NEVER,r1=x_reg,r2=y_reg,t=d_reg} :: - maybe_tag_integers(LDO{d="1",b=d_reg,t=d_reg},C'))) - end - - fun addi(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(ADDO{cond=NEVER,r1=x_reg,r2=y_reg,t=d_reg} :: - maybe_tag_integers(LDO{d="-1",b=d_reg,t=d_reg},C'))) - end - - fun muli(x:reg,y:reg,d:reg,C) = (* A[i*j] = 1 + (A[i] >> 1) * (A[j]-1) *) - if BI.tag_integers() then - (add_lib_function("$$mulI"); - SHD{cond=NEVER,r1=Gen 0,r2=arg1,p="1",t=arg1} :: - LDO {d="-1",b=arg0,t=arg0} :: - META_BL {n=false,target=NameLab "$$mulI",rpLink=mrp, - callStr=";in=25,26;out=29;(MILLICALL)"} :: - LDO{d="1",b=ret1,t=ret1} :: - copy(ret1,d, C)) - else - (add_lib_function("$$muloI"); - META_BL {n=false,target=NameLab "$$muloI",rpLink=mrp, - callStr=";in=25,26;out=29; (MILLICALL)"} :: - copy(ret1,d, C)) - - fun negi(x,d,size_ff,C) = (* Exception Overflow not implemented *) - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - val base = - if BI.tag_integers() then - "2" - else - "0" - in - x_C(SUBI{cond=NEVER,i=base,r=x_reg,t=d_reg} :: C') - end - - fun absi(x,d,size_ff,C) = (* Exception Overflow not implemented *) - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - val base = - if BI.tag_integers() then - "2" - else - "0" - in - if x_reg = d_reg then (* We must preserve d_reg *) - x_C(ADD{cond=GREATERTHAN,r1=x_reg,r2=Gen 0,t=rp} :: - SUBI{cond=NEVER,i=base,r=x_reg,t=rp} :: copy(rp,d_reg,C')) - else - x_C(ADD{cond=GREATERTHAN,r1=x_reg,r2=Gen 0,t=d_reg} :: - SUBI{cond=NEVER,i=base,r=x_reg,t=d_reg} :: C') - end - - fun addf(x,y,b,d,size_ff,C) = - let - val (x_float_reg,x_C) = resolve_float_aty_arg_kill_gen1(x,tmp_reg0,tmp_float_reg0,size_ff) - val (y_float_reg,y_C) = resolve_float_aty_arg_kill_gen1(y,tmp_reg0,tmp_float_reg1,size_ff) - val (b_reg,b_C) = resolve_arg_aty_kill_gen1(b,tmp_reg0,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg0,size_ff,C) - in - x_C(y_C(FADD{fmt=DBL,r1=x_float_reg,r2=y_float_reg,t=tmp_float_reg2} :: - b_C(box_float_reg(b_reg,tmp_float_reg2,mrp, - copy(b_reg,d_reg, C'))))) - end - - fun subf(x,y,b,d,size_ff,C) = - let - val (x_float_reg,x_C) = resolve_float_aty_arg_kill_gen1(x,tmp_reg0,tmp_float_reg0,size_ff) - val (y_float_reg,y_C) = resolve_float_aty_arg_kill_gen1(y,tmp_reg0,tmp_float_reg1,size_ff) - val (b_reg,b_C) = resolve_arg_aty_kill_gen1(b,tmp_reg0,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg0,size_ff,C) - in - x_C(y_C(FSUB{fmt=DBL,r1=x_float_reg,r2=y_float_reg,t=tmp_float_reg2} :: - b_C(box_float_reg(b_reg,tmp_float_reg2,mrp, - copy(b_reg,d_reg,C'))))) - end - - fun mulf(x,y,b,d,size_ff,C) = - let - val (x_float_reg,x_C) = resolve_float_aty_arg_kill_gen1(x,tmp_reg0,tmp_float_reg0,size_ff) - val (y_float_reg,y_C) = resolve_float_aty_arg_kill_gen1(y,tmp_reg0,tmp_float_reg1,size_ff) - val (b_reg,b_C) = resolve_arg_aty_kill_gen1(b,tmp_reg0,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg0,size_ff,C) - in - x_C(y_C(FMPY{fmt=DBL,r1=x_float_reg,r2=y_float_reg,t=tmp_float_reg2} :: - b_C(box_float_reg(b_reg,tmp_float_reg2,mrp, - copy(b_reg,d_reg,C'))))) - end - - fun divf(x,y,b,d,size_ff,C) = - let - val (b_reg,b_C) = resolve_arg_aty_kill_gen1(b,tmp_reg0,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg0,size_ff,C) - in - compile_c_call_prim("divFloat",[b,x,y],NONE,size_ff,tmp_reg0, - b_C(copy(b_reg,d_reg,C'))) - end - - fun negf(b,x,d,size_ff,C) = - let - val (x_float_reg,x_C) = resolve_float_aty_arg_kill_gen1(x,tmp_reg0,tmp_float_reg0,size_ff) - val (b_reg,b_C) = resolve_arg_aty_kill_gen1(b,tmp_reg0,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg0,size_ff,C) - in - x_C(FSUB{fmt=DBL,r1=Float 0,r2=x_float_reg,t=tmp_float_reg0} :: - b_C(box_float_reg(b_reg,tmp_float_reg0,mrp, - copy(b_reg,d_reg,C')))) - end - - fun absf(b,x,d,size_ff,C) = - let - val (x_float_reg,x_C) = resolve_float_aty_arg_kill_gen1(x,tmp_reg0,tmp_float_reg0,size_ff) - val (b_reg,b_C) = resolve_arg_aty_kill_gen1(b,tmp_reg0,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg0,size_ff,C) - in - x_C(FABS{fmt=DBL,r=x_float_reg,t=tmp_float_reg0} :: - b_C(box_float_reg(b_reg,tmp_float_reg0,mrp, - copy(b_reg,d_reg,C')))) - end - - fun cmpf(cond,x,y,d,size_ff,C) = - let - val (x_float_reg,x_C) = resolve_float_aty_arg_kill_gen1(x,tmp_reg0,tmp_float_reg0,size_ff) - val (y_float_reg,y_C) = resolve_float_aty_arg_kill_gen1(y,tmp_reg0,tmp_float_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg0,size_ff,C) - in - (* Assume true; *) - (* don't clear anything *) - x_C(y_C(LDI{i=int_to_string BI.ml_true,t=d_reg} :: - FCMP{fmt=DBL,cond=cond,r1=x_float_reg,r2=y_float_reg} :: - FTEST :: - LDI{i=int_to_string BI.ml_false,t=d_reg} :: C')) - end - - (* Tagging? 09/01/1999, Niels *) - fun addw8(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(ADD{cond=NEVER,r1=x_reg,r2=y_reg,t=d_reg} :: - DEPI{cond=NEVER,i="0",p="23",len="23",t=d_reg} :: C')) - end - - (* Tagging? 09/01/1999, Niels *) - fun subw8(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - in - x_C(y_C(copy(x_reg,mrp, (* I may not destroy x_reg *) - DEPI{cond=NEVER,i="1",p="23",len="1",t=mrp} :: - SUB{cond=NEVER,r1=mrp,r2=y_reg,t=mrp} :: - DEPI{cond=NEVER,i="0",p="23",len="23",t=mrp} :: - move_reg_into_aty_kill_gen1(mrp,d,size_ff,C)))) - end - - (* Tagging? 09/01/1999, Niels *) - fun mulw8(x:reg,y:reg,d:reg,C) = - (add_lib_function("$$mulI"); - META_BL{n=false,target=NameLab "$$mulI",rpLink=mrp, - callStr=";in=25,26;out=29; (MILLICALL)"} :: - DEPI{cond=NEVER,i="0",p="23",len="23",t=ret1} :: - copy(ret1,d,C)) - - fun andi(x,y,d,size_ff,C) = (* A[x&y] = A[x] & A[y] tagging *) - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(AND{cond=NEVER,r1=x_reg,r2=y_reg,t=d_reg} :: C')) - end - - fun ori(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(OR{cond=NEVER,r1=x_reg,r2=y_reg,t=d_reg} :: C')) - end - - (* Shouldn't we set the tag bit if tagging integers? 09/01/1999, Niels *) - fun xori(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(XOR{cond=NEVER,r1=x_reg,r2=y_reg,t=d_reg} :: C')) - end - - (* Tagging? 09/01/1999, Niels *) - fun shift_lefti(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - in - x_C(y_C(SUBI{cond=NEVER,i="31",r=y_reg,t=mrp} :: (* I may not destroy x_reg *) - MTSAR{r=mrp} :: - ZVDEP{cond=NEVER,r=x_reg,d="32",t=mrp} :: - move_reg_into_aty_kill_gen1(mrp,d,size_ff,C))) - end - - (* Tagging? 09/01/1999, Niels *) - fun shift_right_signedi(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - in - x_C(y_C(SUBI{cond=NEVER,i="31",r=y_reg,t=mrp} :: (* I may not destroy x_reg *) - MTSAR{r=mrp} :: - VEXTRS{cond=NEVER,r=x_reg,d="32",t=mrp} :: - move_reg_into_aty_kill_gen1(mrp,d,size_ff,C))) - end - - (* Tagging? 09/01/1999, Niels *) - fun shift_right_unsignedi(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(MTSAR{r=y_reg} :: - VSHD{cond=NEVER,r1=Gen 0,r2=x_reg,t=d_reg} :: C')) - end - - (* Tagging? 09/01/1999, Niels *) - fun addw(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(ADD{cond=NEVER,r1=x_reg,r2=y_reg,t=d_reg} :: C')) - end - - (* Tagging? 09/01/1999, Niels *) - fun subw(x,y,d,size_ff,C) = - let - val (x_reg,x_C) = resolve_arg_aty_kill_gen1(x,tmp_reg0,size_ff) - val (y_reg,y_C) = resolve_arg_aty_kill_gen1(y,tmp_reg1,size_ff) - val (d_reg,C') = resolve_aty_def_kill_gen1(d,tmp_reg1,size_ff,C) - in - x_C(y_C(SUB{cond=NEVER,r1=x_reg,r2=y_reg,t=d_reg} :: C')) - end - - (* Tagging? 09/01/1999, Niels *) - fun mulw(x,y,d,C) = - (add_lib_function("$$mulI"); - META_BL{n=false,target=NameLab "$$mulI",rpLink=mrp, - callStr=";in=25,26;out=29; (MILLICALL)"} :: - copy(ret1,d,C)) - - (*******************) - (* Code Generation *) - (*******************) - - 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 not_impl(s,C) = COMMENT s :: C - 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 - META_B{n=false,target=LocalLab lab_t} :: C - else - if Con.eq(con,Con.con_FALSE) then - META_B{n=false,target=LocalLab lab_f} :: C - else - die "CG_lss: unmatched assign on flow variable" - | LS.ASSIGN{pat,bind} => - COMMENT (pr_ls ls) :: - (case bind of - LS.ATOM src_aty => move_aty_to_aty_kill_gen1(src_aty,pat,size_ff,C) - | LS.LOAD label => load_from_label_kill_gen1(DatLab label,pat,tmp_reg1,size_ff,C) - | LS.STORE(src_aty,label) => - (gen_data_lab label; - store_in_label_kill_gen1(src_aty,DatLab label,tmp_reg1,size_ff,C)) - | LS.STRING str => - let - val string_lab = gen_string_lab str - in - load_label_addr_kill_gen1(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 [DOT_DATA, - DOT_ALIGN 8, - LABEL float_lab, - DOT_WORD(BI.pr_tag_w(BI.tag_real(true))), - DOT_WORD "0", (* dummy *) - DOT_DOUBLE str] - else - add_static_data [DOT_DATA, - DOT_ALIGN 8, - LABEL float_lab, - DOT_DOUBLE str] - in - load_label_addr_kill_gen1(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_kill_gen1(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_gen1_tmp0_1_2(alloc,reg_for_result,num_elems+2,size_ff, - load_immed(IMMED(Word32.toInt(BI.tag_clos(false,num_elems+1,n_skip))),mrp, - store_indexed_kill_gen1(reg_for_result,WORDS 0,mrp, - load_label_addr_kill_gen1(MLFunLab label,SS.PHREG_ATY mrp,mrp,size_ff, - store_indexed_kill_gen1(reg_for_result,WORDS 1,mrp, - #2(foldr (fn (aty,(offset,C)) => - (offset-1,store_aty_in_reg_record_kill_gen1(aty,mrp,reg_for_result,WORDS offset,size_ff, - C))) (num_elems+1,C') (LS.smash_free elems))))))) - else - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,num_elems+1,size_ff, - load_label_addr_kill_gen1(MLFunLab label,SS.PHREG_ATY mrp,mrp,size_ff, - store_indexed_kill_gen1(reg_for_result,WORDS 0,mrp, - #2(foldr (fn (aty,(offset,C)) => - (offset-1,store_aty_in_reg_record_kill_gen1(aty,mrp,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_kill_gen1(pat,tmp_reg1,size_ff,C) - val num_elems = List.length elems - in - if BI.tag_values() then - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,num_elems+1,size_ff, - load_immed(IMMED(Word32.toInt(BI.tag_regvec(false,num_elems))),mrp, - store_indexed_kill_gen1(reg_for_result,WORDS 0,mrp, - #2(foldr (fn (sma,(offset,C)) => - (offset-1,store_sm_in_record_kill_gen1(sma,mrp,reg_for_result,WORDS offset,size_ff, - C))) (num_elems,C') elems)))) - else - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,num_elems,size_ff, - #2(foldr (fn (sma,(offset,C)) => - (offset-1,store_sm_in_record_kill_gen1(sma,mrp,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_kill_gen1(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_gen1_tmp0_1_2(alloc,reg_for_result,num_elems+1,size_ff, - load_immed(IMMED(Word32.toInt(BI.tag_sclos(false,num_elems,n_skip))),mrp, - store_indexed_kill_gen1(reg_for_result,WORDS 0,mrp, - #2(foldr (fn (aty,(offset,C)) => - (offset-1,store_aty_in_reg_record_kill_gen1(aty,mrp,reg_for_result,WORDS offset,size_ff, - C))) (num_elems,C') (LS.smash_free elems))))) - else - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,num_elems,size_ff, - #2(foldr (fn (aty,(offset,C)) => - (offset-1,store_aty_in_reg_record_kill_gen1(aty,mrp,reg_for_result,WORDS offset,size_ff, - C))) (num_elems-1,C') (LS.smash_free elems))) - end - | LS.RECORD{elems=[],alloc,tag} => move_aty_to_aty_kill_gen1(SS.UNIT_ATY,pat,size_ff,C) (* Unit is unboxed *) - | LS.RECORD{elems,alloc,tag} => - let - val (reg_for_result,C') = resolve_aty_def_kill_gen1(pat,tmp_reg1,size_ff,C) - val num_elems = List.length elems - in - if BI.tag_values() then - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,num_elems+1,size_ff, - load_immed(IMMED(Word32.toInt tag),mrp, - store_indexed_kill_gen1(reg_for_result,WORDS 0,mrp, - #2(foldr (fn (aty,(offset,C)) => - (offset-1,store_aty_in_reg_record_kill_gen1(aty,mrp,reg_for_result,WORDS offset,size_ff, - C))) (num_elems,C') elems)))) - else - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,num_elems,size_ff, - #2(foldr (fn (aty,(offset,C)) => - (offset-1,store_aty_in_reg_record_kill_gen1(aty,mrp,reg_for_result,WORDS offset,size_ff, - C))) (num_elems-1,C') elems)) - end - | LS.SELECT(i,aty) => - if BI.tag_values() then - move_index_aty_to_aty_kill_gen1(aty,pat,WORDS(i+1),tmp_reg1,size_ff,C) - else - move_index_aty_to_aty_kill_gen1(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_kill_gen1(pat,tmp_reg1,size_ff,C) - in - load_immed(IMMED tag,reg_for_result,C') - end - | LS.UNBOXED i => - let - val tag = 4*i+3 - val (reg_for_result,C') = resolve_aty_def_kill_gen1(pat,tmp_reg1,size_ff,C) - fun reset_regions C = - foldr (fn (alloc,C) => maybe_reset_aux_region_kill_gen1_tmp0(alloc,mrp,size_ff,C)) C aux_regions - in - reset_regions(load_immed(IMMED tag,reg_for_result,C')) - end - | LS.BOXED i => - let - val tag = Word32.toInt(BI.tag_con0(false,i)) - val (reg_for_result,C') = resolve_aty_def_kill_gen1(pat,tmp_reg1,size_ff,C) - fun reset_regions C = - List.foldr (fn (alloc,C) => maybe_reset_aux_region_kill_gen1_tmp0(alloc,mrp,size_ff,C)) C aux_regions - in - reset_regions(alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,1,size_ff, - load_immed(IMMED tag,mrp, - store_indexed_kill_gen1(reg_for_result,WORDS 0,mrp,C')))) - end) - | LS.CON1{con,con_kind,alloc,arg} => - (case con_kind of - LS.UNBOXED 0 => move_aty_to_aty_kill_gen1(arg,pat,size_ff,C) - | LS.UNBOXED i => - let - val (reg_for_result,C') = resolve_aty_def_kill_gen1(pat,tmp_reg1,size_ff,C) - in - (case i of - 1 => move_aty_into_reg_kill_gen1(arg,reg_for_result,size_ff, - DEPI{cond=NEVER, i="1", p="31", len="1", t=reg_for_result} :: C') - | 2 => move_aty_into_reg_kill_gen1(arg,reg_for_result,size_ff, - DEPI{cond=NEVER, i="1", p="30", len="1", t=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_kill_gen1(pat,tmp_reg1,size_ff,C) - val tag = Word32.toInt(BI.tag_con1(false,i)) - in - if SS.eq_aty(pat,arg) then (* We must preserve arg. *) - alloc_ap_kill_gen1_tmp0_1_2(alloc,tmp_reg1,2,size_ff, - load_immed(IMMED tag,mrp, - store_indexed_kill_gen1(tmp_reg1,WORDS 0,mrp, - store_aty_in_reg_record_kill_gen1(arg,mrp,tmp_reg1,WORDS 1,size_ff, - copy(tmp_reg1,reg_for_result,C'))))) - else - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,2,size_ff, - load_immed(IMMED tag,mrp, - store_indexed_kill_gen1(reg_for_result,WORDS 0,mrp, - store_aty_in_reg_record_kill_gen1(arg,mrp,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_kill_gen1(con_aty,pat,size_ff,C) - | LS.UNBOXED _ => - let - val (reg_for_result,C') = resolve_aty_def_kill_gen1(pat,tmp_reg1,size_ff,C) - in - move_aty_into_reg_kill_gen1(con_aty,reg_for_result,size_ff, - DEPI{cond=NEVER, i="0", p="31", len="2", t=reg_for_result} :: C') - end - | LS.BOXED _ => move_index_aty_to_aty_kill_gen1(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_kill_gen1(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_kill_gen1(pat,tmp_reg1,size_ff,C) - fun maybe_tag_value C = - if BI.tag_values() then - load_immed(IMMED (Word32.toInt(BI.tag_ref(false))),mrp, - store_indexed_kill_gen1(reg_for_result,WORDS 0,mrp,C)) - else C - in - if SS.eq_aty(pat,aty) then (* We must preserve aty *) - alloc_ap_kill_gen1_tmp0_1_2(alloc,tmp_reg1,BI.size_of_ref(),size_ff, - store_aty_in_reg_record_kill_gen1(aty,mrp,tmp_reg1,WORDS offset,size_ff, - copy(tmp_reg1,reg_for_result,maybe_tag_value C'))) - else - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,BI.size_of_ref(),size_ff, - store_aty_in_reg_record_kill_gen1(aty,mrp,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_kill_gen1(pat,tmp_reg1,size_ff,C) - val offset = if BI.tag_values() then 1 else 0 - in - store_aty_in_aty_record_kill_reg1(aty2,aty1,WORDS offset,tmp_reg1,mrp,size_ff, - load_immed(IMMED BI.ml_unit,reg_for_result,C')) - end - | LS.PASS_PTR_TO_MEM(alloc,i) => - let - val (reg_for_result,C') = resolve_aty_def_kill_gen1(pat,tmp_reg1,size_ff,C) - in - alloc_ap_kill_gen1_tmp0_1_2(alloc,reg_for_result,i,size_ff,C') - end - | LS.PASS_PTR_TO_RHO(alloc) => - let - val (reg_for_result,C') = resolve_aty_def_kill_gen1(pat,tmp_reg1,size_ff,C) - in - prefix_sm_kill_gen1(alloc,reg_for_result,size_ff,C') - end) - | LS.FLUSH(aty,offset) => COMMENT (pr_ls ls) :: store_aty_in_reg_record_kill_gen1(aty,tmp_reg1,sp,WORDS(~size_ff+offset),size_ff,C) - | LS.FETCH(aty,offset) => COMMENT (pr_ls ls) :: load_aty_from_reg_record_kill_gen1(aty,tmp_reg1,sp,WORDS(~size_ff+offset),size_ff,C) - | LS.FNJMP(cc as {opr,args,clos,res,bv}) => - COMMENT (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 "4" else "0" - in - if List.length spilled_args > 0 then - CG_ls(LS.FNCALL cc,C) - else - case opr of (* We fetch the addr from the closure and opr points at the closure *) - SS.PHREG_ATY opr_reg => - LDW{d=offset_codeptr,s=Space 0,b=opr_reg,t=tmp_reg1} :: (* Fetch code label from closure *) - base_plus_offset_kill_gen1(sp,WORDS(~size_ff-size_ccf),sp, (* return label is now at top of stack *) - META_BV{n=false,x=Gen 0,b=tmp_reg1} :: C) (* Is C dead code? *) - | _ => move_aty_into_reg_kill_gen1(opr,tmp_reg1,size_ff, - LDW{d=offset_codeptr,s=Space 0,b=tmp_reg1,t=tmp_reg1} :: (* Fetch code label from closure *) - base_plus_offset_kill_gen1(sp,WORDS(~size_ff-size_ccf),sp, (* return label is now at top of stack *) - META_BV{n=false,x=Gen 0,b=tmp_reg1}::C)) (* Is C dead code? *) - end - | LS.FNCALL{opr,args,clos,res,bv} => - COMMENT (pr_ls ls) :: - let - val offset_codeptr = if BI.tag_values() then "4" else "0" - val (spilled_args,spilled_res,return_lab_offset) = - 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 return_lab = new_local_lab "return_from_app" - fun flush_args C = - foldr (fn ((aty,offset),C) => push_aty_kill_gen1(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_kill_gen1(aty,tmp_reg1,size_ff+offset,C)) C (rev spilled_res) - fun jmp C = - case opr of (* We fetch the add from the closure and opr points at the closure *) - SS.PHREG_ATY opr_reg => - LDW{d=offset_codeptr,s=Space 0,b=opr_reg,t=tmp_reg1} :: (* Fetch code pointer *) - META_BV{n=false,x=Gen 0,b=tmp_reg1} :: C - | _ => - move_aty_into_reg_kill_gen1(opr,tmp_reg1,size_ff+size_cc, (* sp is now pointing after the call *) - LDW{d=offset_codeptr,s=Space 0,b=tmp_reg1,t=tmp_reg1} :: (* convention, i.e., size_ff+size_cc *) - META_BV{n=false,x=Gen 0,b=tmp_reg1}::C) - in - load_label_addr_kill_gen1(return_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, (* Fetch return label address *) - base_plus_offset_kill_gen1(sp,WORDS(size_rcf),sp, (* Move sp after rcf *) - STWM{r=tmp_reg1,d="4",s=Space 0,b=sp} :: (* Push Return Label *) - flush_args(jmp(gen_bv(bv,LABEL return_lab :: fetch_res C))))) - end - | LS.JMP(cc as {opr,args,reg_vec,reg_args,clos,res,bv}) => - COMMENT (pr_ls ls) :: - let - val (spilled_args,_,_) = - CallConv.resolve_act_cc RI.args_phreg RI.res_phreg {args=args,clos=clos,reg_args=reg_args,reg_vec=reg_vec,res=res} - fun jmp C = META_B{n=false,target=MLFunLab opr} :: C (* Is C dead code? *) - in - if List.length spilled_args > 0 then - CG_ls(LS.FUNCALL cc,C) - else - base_plus_offset_kill_gen1(sp,WORDS(~size_ff-size_ccf),sp, - jmp C) - end - | LS.FUNCALL{opr,args,reg_vec,reg_args,clos,res,bv} => - COMMENT (pr_ls ls) :: - let - val (spilled_args,spilled_res,return_lab_offset) = - 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_kill_gen1(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_kill_gen1(aty,tmp_reg1,size_ff+offset,C)) C (rev spilled_res) - fun jmp C = META_B{n=false,target=MLFunLab opr} :: C - in - load_label_addr_kill_gen1(return_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, (* Fetch return label address *) - base_plus_offset_kill_gen1(sp,WORDS(size_rcf),sp, (* Move sp after rcf *) - STWM{r=tmp_reg1,d="4",s=Space 0,b=sp} :: (* Push Return Label *) - flush_args(jmp(gen_bv(bv,LABEL return_lab :: fetch_res C))))) - end - | LS.LETREGION{rhos,body} => - COMMENT "letregion" :: - let - fun alloc_region_prim((_,offset),C) = - base_plus_offset_kill_gen1(sp,WORDS(~size_ff+offset),tmp_reg1, - compile_c_call_prim("allocateRegion",[SS.PHREG_ATY tmp_reg1],NONE,size_ff,tmp_reg0,C)) - fun dealloc_region_prim C = - compile_c_call_prim("deallocateRegionNew",[],NONE,size_ff,tmp_reg0(*not used*),C) - fun remove_finite_rhos([]) = [] - | remove_finite_rhos(((place,LineStmt.WORDS i),offset)::rest) = remove_finite_rhos rest - | remove_finite_rhos(rho::rest) = rho :: remove_finite_rhos rest - val rhos_to_allocate = remove_finite_rhos rhos - in - foldr alloc_region_prim - (CG_lss(body,size_ff,size_ccf, - foldl (fn (_,C) => dealloc_region_prim C) C rhos_to_allocate)) rhos_to_allocate - 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 staring 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_kill_gen1(handl_lv,tmp_reg1,sp,WORDS(~size_ff+offset+1),size_ff,C) - fun store_handl_return_lab C = - COMMENT "STORE HANDL RETURN LAB: sp[offset] = handl_return_lab" :: - load_label_addr_kill_gen1(handl_return_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, - store_indexed_kill_gen1(sp,WORDS(~size_ff+offset),tmp_reg1,C)) - fun store_exn_ptr C = - COMMENT "STORE EXN PTR: sp[offset+2] = exnPtr" :: - load_from_label_kill_gen1(exn_ptr_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, - store_indexed_kill_gen1(sp,WORDS(~size_ff+offset+2),tmp_reg1, - COMMENT "CALC NEW expPtr: expPtr = sp-size_ff+offset+size_of_handle" :: - base_plus_offset_kill_gen1(sp,WORDS(~size_ff+offset+BI.size_of_handle()),tmp_reg1, - store_in_label_kill_gen1(SS.PHREG_ATY tmp_reg1,exn_ptr_lab,mrp,size_ff,C)))) - fun store_sp C = - COMMENT "STORE SP: sp[offset+3] = sp" :: - store_indexed_kill_gen1(sp,WORDS(~size_ff+offset+3),sp,C) - fun default_code C = COMMENT "HANDLER DEFAULT CODE" :: - CG_lss(default,size_ff,size_ccf,C) - fun restore_exp_ptr C = - COMMENT "RESTORE EXP PTR: exnPtr = sp[offset+2]":: - load_indexed_kill_gen1(tmp_reg1,sp,WORDS(~size_ff+offset+2), - store_in_label_kill_gen1(SS.PHREG_ATY tmp_reg1,exn_ptr_lab,tmp_reg1,size_ff, - META_B{n=false,target=handl_join_lab} ::C)) - fun handl_return_code C = - let - val res_reg = lv_to_reg(CallConv.handl_return_phreg RI.res_phreg) - in - COMMENT "HANDL RETRUN CODE: handl_return_aty = res_phreg" :: - gen_bv(bv, - LABEL handl_return_lab :: - move_aty_to_aty_kill_gen1(SS.PHREG_ATY res_reg,handl_return_aty,size_ff, - CG_lss(handl_return,size_ff,size_ccf, - LABEL 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} => - (* To raise arg we fetch the top most exception handler and pass arg to the handler function. *) - (* We put the label to which the handler function must return on top of the activation record. *) - (* arg_aty isn't currently preserved!!! Problem whit RA - should we reserve a slot in the handler! *) - let - val (clos_lv,arg_lv) = CallConv.handl_arg_phreg RI.args_phreg - val (clos_reg,arg_reg) = (lv_to_reg clos_lv,lv_to_reg arg_lv) - val offset_codeptr = if BI.tag_values() then "4" else "0" - - fun deallocate_regions_until C = - COMMENT "DEALLOCATE REGIONS UNTIL" :: - load_from_label_kill_gen1(exn_ptr_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, - compile_c_call_prim("deallocateRegionsUntil",[SS.PHREG_ATY tmp_reg1],NONE,size_ff,tmp_reg1,C)) - fun restore_exn_ptr C = - COMMENT "RESTORE EXN PTR" :: - load_from_label_kill_gen1(exn_ptr_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, - load_indexed_kill_gen1(mrp,tmp_reg1,WORDS(~2), - store_in_label_kill_gen1(SS.PHREG_ATY mrp,exn_ptr_lab,mrp,size_ff,C))) - fun push_return_lab C = - COMMENT "LOAD ARGUMENT, RESTORE SP AND PUSH RETURN LAB" :: - (* Note that we are still in the activation record where arg_aty is raised *) - move_aty_into_reg_kill_gen1(arg_aty,arg_reg,size_ff, - load_indexed_kill_gen1(sp,tmp_reg1,WORDS(~1), (* Restore sp *) - load_indexed_kill_gen1(mrp,tmp_reg1,WORDS(~4), (* Push Return Lab *) - STWM{r=mrp,d="4",s=Space 0,b=sp} :: C))) - fun jmp C = - COMMENT "JUMP TO HANDLE FUNCTION" :: - load_indexed_kill_gen1(clos_reg,tmp_reg1,WORDS(~3), (* Fetch Closure into Closure Argument Register *) - LDW{d=offset_codeptr,s=Space 0,b=clos_reg,t=mrp} :: - META_BV{n=false,x=Gen 0,b=mrp}::C) - in - COMMENT ("START OF RAISE: " ^ pr_ls ls) :: - deallocate_regions_until(restore_exn_ptr(push_return_lab(jmp(COMMENT "END OF RAISE" :: C)))) - end - | LS.SWITCH_I(LS.SWITCH(SS.FLOW_VAR_ATY(lv,lab_t,lab_f),[(sel_val,lss)],default)) => - let - val (t_lab,f_lab) = if sel_val = BI.ml_true then (lab_t,lab_f) else (lab_f,lab_t) - val lab_exit = new_local_lab "lab_exit" - in - LABEL(LocalLab t_lab) :: - CG_lss(lss,size_ff,size_ccf, - META_B{n=false,target=lab_exit} :: - LABEL(LocalLab f_lab) :: - CG_lss(default,size_ff,size_ccf, - LABEL lab_exit :: C)) - end - | LS.SWITCH_I(LS.SWITCH(SS.PHREG_ATY opr_reg,sels,default)) => - binary_search(sels, - default, - opr_reg, - fn (lss,C) => CG_lss(lss,size_ff,size_ccf,C), (* compile_insts *) - C) - | LS.SWITCH_I(LS.SWITCH(opr_aty,sels,default)) => - move_aty_into_reg_kill_gen1(opr_aty,tmp_reg1,size_ff, - binary_search(sels, - default, - tmp_reg1, - fn (lss,C) => CG_lss(lss,size_ff,size_ccf,C), (* compile_insts *) - C)) - | LS.SWITCH_S sw => die "SWITCH_S is unfolded in ClosExp" - (* Match LS.SWITCH on flow variable 31/03/1999, Niels*) - | 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 - LABEL(LocalLab t_lab) :: - CG_lss(lss,size_ff,size_ccf, - META_B{n=false,target=lab_exit} :: - LABEL(LocalLab f_lab) :: - CG_lss(default,size_ff,size_ccf, - LABEL lab_exit :: C)) - end - | LS.SWITCH_C(LS.SWITCH(opr_aty,sels,default)) => - let (* NOTE: selectors in sels are tagged in ClosExp but the operand is tagged here! *) - val con_kind = - (case sels of - [] => die "CG_ls: SWITCH_C sels is empty" - | ((con,con_kind),_)::rest => con_kind) - val sels' = map (fn ((con,con_kind),sel_insts) => - case con_kind of - LS.ENUM i => (i,sel_insts) - | LS.UNBOXED i => (i,sel_insts) - | LS.BOXED i => (i,sel_insts)) sels - fun UbTagCon(src_aty,C) = - move_aty_into_reg_kill_gen1(src_aty,tmp_reg0,size_ff, - copy(tmp_reg0, tmp_reg1, (* operand is in tmp_reg1, see SWITCH_I *) - DEPI{cond=NEVER, i="0", p="29", len="30", t=tmp_reg1} :: - ADDI{cond=NOTEQUAL, i="-3", r=tmp_reg1, t=Gen 1} :: (* nullify copy if tr = 3 *) - copy(tmp_reg0, tmp_reg1, C))) - in - (case con_kind of - LS.ENUM _ => CG_ls(LS.SWITCH_I(LS.SWITCH(opr_aty,sels',default)),C) - | LS.UNBOXED _ => UbTagCon(opr_aty, - CG_ls(LS.SWITCH_I(LS.SWITCH(SS.PHREG_ATY tmp_reg1,sels',default)),C)) - | LS.BOXED _ => move_index_aty_to_aty_kill_gen1(opr_aty,SS.PHREG_ATY tmp_reg1,WORDS 0,tmp_reg1,size_ff, - CG_ls(LS.SWITCH_I(LS.SWITCH(SS.PHREG_ATY tmp_reg1,sels',default)),C))) - end - | LS.SWITCH_E sw => die "SWITCH_E is unfolded in ClosExp" - | LS.RESET_REGIONS{force=false,regions_for_resetting} => - COMMENT (pr_ls ls) :: - foldr (fn (alloc,C) => maybe_reset_aux_region_kill_gen1_tmp0(alloc,tmp_reg1,size_ff,C)) C regions_for_resetting - | LS.RESET_REGIONS{force=true,regions_for_resetting} => - COMMENT (pr_ls ls) :: - foldr (fn (alloc,C) => force_reset_aux_region_kill_gen1_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 (pr_ls ls) :: - let - val (lab_t,lab_f) = (LocalLab lab_t,LocalLab lab_f) - in - (case (name,args) of - ("__equal_int",[x,y]) => cmpi_and_jmp(EQUAL,x,y,lab_t,lab_f,size_ff,C) - | ("__less_int",[x,y]) => cmpi_and_jmp(LESSTHAN,x,y,lab_t,lab_f,size_ff,C) - | ("__lesseq_int",[x,y]) => cmpi_and_jmp(LESSEQUAL,x,y,lab_t,lab_f,size_ff,C) - | ("__greater_int",[x,y]) => cmpi_and_jmp(GREATERTHAN,x,y,lab_t,lab_f,size_ff,C) - | ("__greatereq_int",[x,y]) => cmpi_and_jmp(GREATEREQUAL,x,y,lab_t,lab_f,size_ff,C) - | _ => die "CG_ls: Unknown PRIM used on Flow Variable") - end - | LS.PRIM{name,args,res} => - COMMENT (pr_ls ls) :: - (* Note that the prim names are defined in BackendInfo! *) - (case (name,args,res) - of ("__equal_int",[x,y],[d]) => cmpi(EQUAL,x,y,d,size_ff,C) - | ("__minus_int",[x,y],[d]) => subi(x,y,d,size_ff,C) - | ("__plus_int",[x,y],[d]) => addi(x,y,d,size_ff,C) - | ("__neg_int",[x],[d]) => negi(x,d,size_ff,C) - | ("__abs_int",[x],[d]) => absi(x,d,size_ff,C) - | ("__less_int",[x,y],[d]) => cmpi(LESSTHAN,x,y,d,size_ff,C) - | ("__lesseq_int",[x,y],[d]) => cmpi(LESSEQUAL,x,y,d,size_ff,C) - | ("__greater_int",[x,y],[d]) => cmpi(GREATERTHAN,x,y,d,size_ff,C) - | ("__greatereq_int",[x,y],[d]) => cmpi(GREATEREQUAL,x,y,d,size_ff,C) - | ("__plus_float",[b,x,y],[d]) => addf(x,y,b,d,size_ff,C) - | ("__minus_float",[b,x,y],[d]) => subf(x,y,b,d,size_ff,C) - | ("__mul_float",[b,x,y],[d]) => mulf(x,y,b,d,size_ff,C) - | ("__neg_float",[b,x],[d]) => negf(b,x,d,size_ff,C) - | ("__abs_float",[b,x],[d]) => absf(b,x,d,size_ff,C) - | ("__less_float",[x,y],[d]) => cmpf(LESSTHAN,x,y,d,size_ff,C) - | ("__lesseq_float",[x,y],[d]) => cmpf(LESSEQUAL,x,y,d,size_ff,C) - | ("__greater_float",[x,y],[d]) => cmpf(GREATERTHAN,x,y,d,size_ff,C) - | ("__greatereq_float",[x,y],[d]) => cmpf(GREATEREQUAL,x,y,d,size_ff,C) - - | ("less_word__",[x,y],[d]) => cmpi(LESSTHAN_UNSIGNED,x,y,d,size_ff,C) - | ("greater_word__",[x,y],[d]) => cmpi(GREATERTHAN_UNSIGNED,x,y,d,size_ff,C) - | ("lesseq_word__",[x,y],[d]) => cmpi(LESSEQUAL_UNSIGNED,x,y,d,size_ff,C) - | ("greatereq_word__",[x,y],[d]) => cmpi(GREATEREQUAL_UNSIGNED,x,y,d,size_ff,C) - - | ("plus_word8__",[x,y],[d]) => addw8(x,y,d,size_ff,C) - | ("minus_word8__",[x,y],[d]) => subw8(x,y,d,size_ff,C) - - | ("and__",[x,y],[d]) => andi(x,y,d,size_ff,C) - | ("or__",[x,y],[d]) => ori(x,y,d,size_ff,C) - | ("xor__",[x,y],[d]) => xori(x,y,d,size_ff,C) - | ("shift_left__",[x,y],[d]) => shift_lefti(x,y,d,size_ff,C) - | ("shift_right_signed__",[x,y],[d]) => shift_right_signedi(x,y,d,size_ff,C) - | ("shift_right_unsigned__",[x,y],[d]) => shift_right_unsignedi(x,y,d,size_ff,C) - - | ("plus_word__",[x,y],[d]) => addw(x,y,d,size_ff,C) - | ("minus_word__",[x,y],[d]) => subw(x,y,d,size_ff,C) - - | ("__fresh_exname",[],[aty]) => - load_label_addr_kill_gen1(exn_counter_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,size_ff, - LDW{d="0",s=Space 0,b=tmp_reg1,t=mrp} :: - move_reg_into_aty_kill_gen1(mrp,aty,size_ff, - ADDI {cond=NEVER, i="1", r=mrp, t=mrp} :: - STW {r=mrp, d="0", s=Space 0, b=tmp_reg1} :: C)) - | _ => die ("PRIM(" ^ name ^ ") not implemented")) - - | LS.CCALL{name,args,rhos_for_result,res} => - COMMENT (pr_ls ls) :: - (case (name, rhos_for_result@args, res) - of ("__mul_int", [SS.PHREG_ATY x, SS.PHREG_ATY y], [SS.PHREG_ATY d]) => muli(x,y,d,C) - | ("mul_word__", [SS.PHREG_ATY x, SS.PHREG_ATY y], [SS.PHREG_ATY d]) => mulw(x,y,d,C) - | ("mul_word8__", [SS.PHREG_ATY x, SS.PHREG_ATY y], [SS.PHREG_ATY d]) => mulw8(x,y,d,C) - | ("__div_float",[b,x,y],[d]) => divf(x,y,b,d,size_ff,C) - | (_,all_args,[]) => compile_c_call_prim(name,all_args,NONE,size_ff,tmp_reg1,C) - | (_,all_args,[res_aty]) => compile_c_call_prim(name,all_args,SOME res_aty,size_ff,tmp_reg1,C) - | _ => die "CCall with more than one result variable")) - in - foldr (fn (ls,C) => CG_ls(ls,C)) C lss - end - - 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 C = base_plus_offset_kill_gen1(sp,WORDS(~size_ff-size_ccf),sp, - LDWM{d="-4",s=Space 0,b=sp,t=tmp_reg1} :: - META_BV{n=false,x=Gen 0,b=tmp_reg1}::[]) - val reg_args = map lv_to_reg_no (CallConv.get_register_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, - LABEL(MLFunLab lab) :: - do_gc(reg_map,base_plus_offset_kill_gen1(sp,WORDS(size_ff),sp, - CG_lss(lss,size_ff,size_ccf,C)))) - end - - fun CG_top_decl(LS.FUN(lab,cc,lss)) = CG_top_decl' FUN (lab,cc,lss) - | CG_top_decl(LS.FN(lab,cc,lss)) = CG_top_decl' FN (lab,cc,lss) - - (*********************************************************) - (* Init, Static Data and Exit Code for this program unit *) - (*********************************************************) - fun static_data() = - DOT_DATA :: - COMMENT "START OF STATIC DATA AREA" :: - get_static_data([DOT_IMPORT (NameLab "$global$", "DATA"), - COMMENT "END OF STATIC DATA AREA", - DOT_END]) - fun init_hppa_code() = DOT_CODE :: [] - fun exit_hppa_code () = get_lib_functions([]) - 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 "[Code Generation..." - val _ = reset_static_data() - val _ = reset_label_counter() - val _ = reset_lib_functions() - val _ = add_static_data (map (fn lab => DOT_IMPORT(MLFunLab lab, "CODE")) (#1 imports)) - val _ = add_static_data (map (fn lab => DOT_IMPORT(DatLab lab, "DATA")) (#2 imports)) - val _ = add_static_data (map (fn lab => DOT_EXPORT(MLFunLab lab, "CODE")) (main_lab::(#1 exports))) - val _ = add_static_data (map (fn lab => DOT_EXPORT(DatLab lab, "DATA")) (#2 exports)) - val _ = add_static_data [DOT_IMPORT(exn_ptr_lab, "DATA"), - DOT_IMPORT(exn_counter_lab,"DATA")] - val _ = - if gc_p() then - add_static_data [DOT_IMPORT(time_to_gc_lab,"DATA")] - else - () - val _ = add_static_data (map (fn lab => DOT_IMPORT(DatLab lab, "DATA")) global_region_labs) - val hp_parisc_prg_meta = {top_decls = foldr (fn (func,acc) => CG_top_decl func :: acc) [] ss_prg, - init_code = init_hppa_code(), - exit_code = exit_hppa_code(), - static_data = static_data()} - val _ = - if Flags.is_on "print_HP-PARISC_program_meta" then - display("\nReport: AFTER CODE GENERATION(HP-PARISC WITH META INSTRUCTIONS):", HpPaRisc.layout_AsmPrg hp_parisc_prg_meta) - else - () - - val hp_parisc_prg = HppaResolveJumps.RJ hp_parisc_prg_meta -(*{top_decls = foldr (fn (func,acc) => CG_top_decl func :: acc) [] ss_prg, - init_code = init_hppa_code(), - exit_code = exit_hppa_code(), - static_data = static_data()}29/03/1999, Niels*) - val _ = - if Flags.is_on "print_HP-PARISC_program" then - display("\nReport: AFTER CODE GENERATION(HP-PARISC):", HpPaRisc.layout_AsmPrg hp_parisc_prg) - else - () - val _ = chat "]\n" - in - hp_parisc_prg - end - - (* ------------------------------------------------------------------------------ *) - (* Generate Link Code for Incremental Compilation *) - (* ------------------------------------------------------------------------------ *) - fun generate_link_code (linkinfos:label list,exports: label list * label list) = - let - val _ = reset_static_data() - val _ = reset_label_counter() - val _ = reset_lib_functions() - - 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 *) - - fun slot_for_datlab(l,C) = - DOT_DATA :: - DOT_ALIGN 4 :: - DOT_EXPORT(DatLab l, "DATA") :: - LABEL (DatLab l) :: - DOT_WORD "0" :: C - fun slots_for_datlabs(l,C) = foldr slot_for_datlab C l - fun add_progunits(l,C) = foldr (fn (lab,C) => DOT_IMPORT(MLFunLab lab,"CODE") :: C) C l - - fun toplevel_handler C = - let - val (clos_lv,arg_lv) = CallConv.handl_arg_phreg RI.args_phreg - val (clos_reg,arg_reg) = (lv_to_reg clos_lv,lv_to_reg arg_lv) - in - if BI.tag_values() then - LABEL (NameLab "TopLevelHandlerLab") :: - load_indexed_kill_gen1(arg_reg,arg_reg,WORDS 1, - load_indexed_kill_gen1(arg_reg,arg_reg,WORDS 2, (* Fetch pointer to exception string *) - compile_c_call_prim("uncaught_exception",[SS.PHREG_ATY arg_reg],NONE,0,tmp_reg1,C))) - else - LABEL (NameLab "TopLevelHandlerLab") :: - load_indexed_kill_gen1(arg_reg,arg_reg,WORDS 0, - load_indexed_kill_gen1(arg_reg,arg_reg,WORDS 1, (* Fetch pointer to exception string *) - compile_c_call_prim("uncaught_exception",[SS.PHREG_ATY arg_reg],NONE,0,tmp_reg1,C))) - end - - fun raise_insts C = (* expects exception value in arg0 *) - let - val _ = add_static_data [DOT_EXPORT(NameLab "raise_exn","CODE")] - val (clos_lv,arg_lv) = CallConv.handl_arg_phreg RI.args_phreg - val (clos_reg,arg_reg) = (lv_to_reg clos_lv,lv_to_reg arg_lv) - val offset_codeptr = if BI.tag_values() then "4" else "0" - in - LABEL (NameLab "raise_exn") :: - copy(arg0,arg_reg, (* We assume that arg_reg is preserved across C calls *) - - COMMENT "DEALLOCATE REGIONS UNTIL" :: - load_from_label_kill_gen1(exn_ptr_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - compile_c_call_prim("deallocateRegionsUntil",[SS.PHREG_ATY tmp_reg1],NONE,0,tmp_reg1, - - COMMENT "RESTORE EXN PTR" :: - load_from_label_kill_gen1(exn_ptr_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - load_indexed_kill_gen1(mrp,tmp_reg1,WORDS(~2), - store_in_label_kill_gen1(SS.PHREG_ATY mrp,exn_ptr_lab,mrp,0, - - COMMENT "RESTORE SP AND PUSH RETURN LAB" :: - load_indexed_kill_gen1(sp,tmp_reg1,WORDS(~1), (* Restore sp *) - load_indexed_kill_gen1(mrp,tmp_reg1,WORDS(~4), (* Push Return Lab *) - STWM{r=mrp,d="4",s=Space 0,b=sp} :: - - COMMENT "JUMP TO HANDLE FUNCTION" :: - load_indexed_kill_gen1(clos_reg,tmp_reg1,WORDS(~3), (* Fetch Closure into Closure Argument Register *) - LDW{d=offset_codeptr,s=Space 0,b=clos_reg,t=mrp} :: - META_BV{n=false,x=Gen 0,b=mrp}::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 [DOT_DATA, - DOT_ALIGN 4, - DOT_EXPORT (exn_lab, "DATA"), - LABEL exn_lab, - DOT_WORD(BI.pr_tag_w(BI.tag_exname(true))), - DOT_WORD "0", (*dummy for pointer to next word*) - DOT_WORD(BI.pr_tag_w(BI.tag_excon0(true))), - DOT_WORD (int_to_string n), - DOT_WORD "0" (*dummy for pointer to string*), - DOT_DATA, - DOT_ALIGN 4, - DOT_EXPORT (exn_flush_lab, "DATA"), - LABEL exn_flush_lab, (* The Primitive Exception is Flushed at this Address *) - DOT_WORD "0"] - else - add_static_data [DOT_DATA, - DOT_ALIGN 4, - DOT_EXPORT (exn_lab, "DATA"), - LABEL exn_lab, - DOT_WORD "0", (*dummy for pointer to next word*) - DOT_WORD (int_to_string n), - DOT_WORD "0" (*dummy for pointer to string*), - DOT_DATA, - DOT_ALIGN 4, - DOT_EXPORT (exn_flush_lab, "DATA"), - LABEL exn_flush_lab, (* The Primitive Exception is Flushed at this Address *) - DOT_WORD "0"] - in - if BI.tag_values() then - COMMENT ("SETUP PRIM EXN: " ^ exn_string) :: - load_label_addr_kill_gen1(exn_lab,SS.PHREG_ATY tmp_reg0,tmp_reg0,0, - ADDI{cond=NEVER,i="8",r=tmp_reg0,t=tmp_reg1} :: - STW{r=tmp_reg1,d="4",s=Space 0,b=tmp_reg0} :: - load_label_addr_kill_gen1(string_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - STW{r=tmp_reg1,d="16",s=Space 0,b=tmp_reg0} :: - load_label_addr_kill_gen1(exn_flush_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, (* Now flush the exception *) - STW{r=tmp_reg0,d="0",s=Space 0,b=tmp_reg1} :: C))) - else - COMMENT ("SETUP PRIM EXN: " ^ exn_string) :: - load_label_addr_kill_gen1(exn_lab,SS.PHREG_ATY tmp_reg0,tmp_reg0,0, - ADDI{cond=NEVER,i="4",r=tmp_reg0,t=tmp_reg1} :: - STW{r=tmp_reg1,d="0",s=Space 0,b=tmp_reg0} :: - load_label_addr_kill_gen1(string_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - STW{r=tmp_reg1,d="8",s=Space 0,b=tmp_reg0} :: - load_label_addr_kill_gen1(exn_flush_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, (* Now flush the exception *) - STW{r=tmp_reg0,d="0",s=Space 0,b=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, - add_progunits(linkinfos, - DOT_EXPORT (NameLab "code", "ENTRY,PRIV_LEV=3") :: - DOT_DATA :: - DOT_IMPORT (NameLab "$global$", "DATA") :: - - LABEL exn_counter_lab :: (* The Global Exception Counter *) - DOT_WORD (int_to_string initial_exnname_counter) :: - DOT_EXPORT (exn_counter_lab, "DATA") :: - - LABEL exn_ptr_lab :: (* The Global Exception Pointer *) - DOT_WORD "0" :: - DOT_EXPORT(exn_ptr_lab, "DATA") :: - - DOT_IMPORT(stack_bot_gc_lab, "DATA") :: - - DOT_END :: [])) - val _ = add_static_data static_data - - fun ccall_stub(stubname, cfunction, args, ret, C) = (* args in tmp_reg1 and mrp; result in tmp_reg1. *) - let - val _ = add_static_data [DOT_EXPORT(NameLab stubname,"CODE")] - fun push_callersave_regs C = - foldl (fn (r, C) => STWM{r=r,d="4",s=Space 0,b=sp} :: C) C HpPaRisc.caller_save_regs_ccall - fun pop_callersave_regs C = - foldr (fn (r, C) => LDWM{d="-4",s=Space 0,b=sp,t=r} :: C) C HpPaRisc.caller_save_regs_ccall - val size_ff = 0 (*dummy*) - in - DOT_CODE :: - LABEL (NameLab stubname) :: - push_callersave_regs - (compile_c_call_prim(cfunction,map SS.PHREG_ATY args, - Option.map SS.PHREG_ATY ret, size_ff, tmp_reg0, - pop_callersave_regs - (LDWM{d="-4",s=Space 0,b=sp,t=mrp} :: - META_BV{n=false,x=Gen 0,b=mrp} :: C))) - end - - fun allocate C = ccall_stub("__allocate", "alloc", [tmp_reg1, mrp], SOME tmp_reg1, C) - - fun reset_region C = ccall_stub("__reset_region","resetRegion", [tmp_reg1], SOME tmp_reg1, C) - - (* args: tmp_reg1=region pointer and mrp=n bytes to allocate. Result in tmp_reg1 *) - (* return address is pushed on the stack *) - fun inline_alloc_gc C = - let - val _ = add_lib_function "alloc" - val _ = add_static_data [DOT_EXPORT(NameLab "__inline_allocate_gc","CODE")] - (* Note, that tmp_reg2 and tmp_reg3 are in caller_save_regs_ccall! *) - fun push_caller_save_ccall C = - foldl (fn (r, C) => STWM{r=r,d="4",s=Space 0,b=sp} :: C) C HpPaRisc.caller_save_regs_ccall - fun pop_caller_save_ccall C = - foldr (fn (r, C) => LDWM{d="-4",s=Space 0,b=sp,t=r} :: C) C HpPaRisc.caller_save_regs_ccall - val lab = new_local_lab "after_free_list" - val size_ff = 0 (* dummy *) - in - DOT_CODE :: - LABEL (NameLab "__inline_allocate_gc") :: - STWM{r=tmp_reg2,d="4",s=Space 0,b=sp} :: (* push(t2) *) - STWM{r=tmp_reg3,d="4",s=Space 0,b=sp} :: (* push(t3) *) - DEPI{cond=NEVER, i="0", p="31", len="2", t=tmp_reg1} :: (* clear status bits *) - load_indexed_kill_gen1(tmp_reg2,tmp_reg1,WORDS BI.aOff, (* t2=t1->a *) - ADD{cond=NEVER,r1=tmp_reg2,r2=mrp,t=tmp_reg3} :: (* t3=t2+mrp *) - load_indexed_kill_gen1(rp,tmp_reg1,WORDS BI.bOff, (* rp=t1->b *) - META_IF{cond=GREATERTHAN,r1=tmp_reg3,r2=rp,target=lab} :: (* if t3>rp { *) - push_caller_save_ccall( (* flush registers *) - - align_stack_kill_gen1(tmp_reg0, - copy(tmp_reg1,arg0, - copy(mrp,arg1, - META_BL{n=false,target=NameLab "alloc",rpLink=rp, - callStr="ARGW0=GR, ARGW1=GR, RTNVAL=GR"} :: (* alloc in new page. *) - copy(ret0,tmp_reg1, - restore_stack( - - pop_caller_save_ccall( (* fetch registers *) - LDWM{d="-4",s=Space 0,b=sp,t=tmp_reg3} :: (* pop(t3) *) - LDWM{d="-4",s=Space 0,b=sp,t=tmp_reg2} :: (* pop(t2) *) - LDWM{d="-4",s=Space 0,b=sp,t=mrp} :: (* pop(return_address) *) - META_BV{n=false,x=Gen 0,b=mrp} :: (* return to caller *) - LABEL lab :: (* } *) - - store_indexed_kill_gen1(tmp_reg1,WORDS BI.aOff,tmp_reg3, (* t1->a=t3 *) - copy(tmp_reg2,tmp_reg1, (* t1=t2 *) - LDWM{d="-4",s=Space 0,b=sp,t=tmp_reg3} :: (* pop(t3) *) - LDWM{d="-4",s=Space 0,b=sp,t=tmp_reg2} :: (* pop(t2) *) - LDWM{d="-4",s=Space 0,b=sp,t=mrp} :: (* pop(return_address) *) - META_BV{n=false,x=Gen 0,b=mrp} :: C))))))))))) (* return to caller *) - end - - (* args: tmp_reg1=region pointer and mrp=n bytes to allocate. Result in tmp_reg1 *) - (* return address is pushed on the stack *) - fun inline_alloc C = - let - val _ = add_lib_function "callSbrk" - val _ = add_static_data [DOT_EXPORT(NameLab "__inline_allocate","CODE")] - (* Note, that tmp_reg2 and tmp_reg3 are in caller_save_regs_ccall! *) - fun push_caller_save_ccall C = - foldl (fn (r, C) => STWM{r=r,d="4",s=Space 0,b=sp} :: C) C HpPaRisc.caller_save_regs_ccall - fun pop_caller_save_ccall C = - foldr (fn (r, C) => LDWM{d="-4",s=Space 0,b=sp,t=r} :: C) C HpPaRisc.caller_save_regs_ccall - val lab = new_local_lab "after_free_list" - val afterSbrk = new_local_lab "after_SBRK" - val size_ff = 0 (* dummy *) - in - DOT_CODE :: - LABEL (NameLab "__inline_allocate") :: - STWM{r=tmp_reg2,d="4",s=Space 0,b=sp} :: (* push(t2) *) - STWM{r=tmp_reg3,d="4",s=Space 0,b=sp} :: (* push(t3) *) - DEPI{cond=NEVER, i="0", p="31", len="2", t=tmp_reg1} :: (* clear status bits *) - load_indexed_kill_gen1(tmp_reg2,tmp_reg1,WORDS BI.aOff, (* t2=t1->a *) - ADD{cond=NEVER,r1=tmp_reg2,r2=mrp,t=tmp_reg3} :: (* t3=t2+mrp *) - load_indexed_kill_gen1(rp,tmp_reg1,WORDS BI.bOff, (* rp=t1->b *) - META_IF{cond=GREATERTHAN,r1=tmp_reg3,r2=rp,target=lab} :: (* if t3>rp { *) - load_label_addr_kill_gen1(NameLab "freelist", SS.PHREG_ATY tmp_reg2,tmp_reg2,size_ff, (* t2 = &freelist *) - LDW{d="0",s=Space 0,b=tmp_reg2,t=tmp_reg3} :: (* t3 = freelist *) - - META_IF {cond=EQUAL,r1=tmp_reg3,r2=Gen 0,target=afterSbrk} :: (* if freelist==NULL { *) - STWM{r=tmp_reg1,d="4",s=Space 0,b=sp} :: (* push(t1) *) - STWM{r=mrp,d="4",s=Space 0,b=sp} :: (* push(mrp) *) - push_caller_save_ccall( (* flush registers *) - - align_stack_kill_gen1(tmp_reg0, - META_BL{n=false,target=NameLab "callSbrk",rpLink=rp,callStr=""} :: (* update free list. *) - restore_stack( - - pop_caller_save_ccall( (* fetch registers *) - LDWM{d="-4",s=Space 0,b=sp,t=mrp} :: (* pop(mrp) *) - LDWM{d="-4",s=Space 0,b=sp,t=tmp_reg1} :: (* pop(t1) *) - load_indexed_kill_gen1(rp,tmp_reg1,WORDS BI.bOff, (* rp=t1->b *) - LDW{d="0",s=Space 0,b=tmp_reg2,t=tmp_reg3} :: (* t3 = freelist *) - LABEL afterSbrk :: (* } *) - - LDW{d="0",s=Space 0,b=tmp_reg3,t=tmp_reg0} :: (* t0=t3->k.n *) - STW{r=tmp_reg0,d="0",s=Space 0,b=tmp_reg2} :: (* freelist=t0 *) - STW{r=Gen 0,d="0",s=Space 0,b=tmp_reg3} :: (* t3->k.n = NULL *) - - store_indexed_kill_gen1(rp,WORDS(~BI.regionPageTotalSize),tmp_reg3, (* ((rp->b)-1)->k.n=t3 *) - base_plus_offset_kill_gen1(tmp_reg3,WORDS BI.regionPageTotalSize,rp, (* rp=&(t3+1) *) - store_indexed_kill_gen1(tmp_reg1,WORDS BI.bOff, rp, (* t1->b=rp *) - - base_plus_offset_kill_gen1(tmp_reg3, WORDS BI.regionPageHeaderSize, tmp_reg2, (* t2=&(t3->k.i) *) - ADD{cond=NEVER,r1=tmp_reg2,r2=mrp,t=tmp_reg3} :: (* t3=t2+mrp *) - LABEL lab :: (* } *) - - store_indexed_kill_gen1(tmp_reg1,WORDS BI.aOff,tmp_reg3, (* t1->a=t3 *) - copy(tmp_reg2,tmp_reg1, (* t1=t2 *) - LDWM{d="-4",s=Space 0,b=sp,t=tmp_reg3} :: (* pop(t3) *) - LDWM{d="-4",s=Space 0,b=sp,t=tmp_reg2} :: (* pop(t2) *) - LDWM{d="-4",s=Space 0,b=sp,t=mrp} :: (* pop(return_address) *) - META_BV{n=false,x=Gen 0,b=mrp} :: C)))))))))))))) (* return to caller *) - end - - fun gc_stub C = (* tmp_reg1 must contain the register map and mrp the return address. *) - if gc_p() then - let - val _ = add_static_data [DOT_EXPORT(gc_stub_lab,"CODE")] - fun push_all_regs C = - foldr (fn (r, C) => STWM{r=r,d="4",s=Space 0,b=sp} :: C) C all_regs - fun pop_all_regs C = - foldl (fn (r, C) => LDWM{d="-4",s=Space 0,b=sp,t=r} :: C) C all_regs - val size_ff = 0 (*dummy*) - in - DOT_CODE :: - LABEL gc_stub_lab :: - push_all_regs (* The return lab and mrp are also preserved *) - (copy(sp,mrp, - compile_c_call_prim("gc",[SS.PHREG_ATY mrp,SS.PHREG_ATY tmp_reg1],NONE,size_ff,tmp_reg0, - pop_all_regs (* The return lab and mrp are also popped again *) - (META_BV{n=false,x=Gen 0,b=mrp} :: C)))) - 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" :: - load_label_addr_kill_gen1(next_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - STWM{r=tmp_reg1,d="4",s=Space 0,b=sp} :: - COMMENT "JUMP TO NEXT PROGRAM UNIT" :: - META_B{n=false,target=l} :: - DOT_WORD "0XFFFFFFFF" :: (* Marks, no more frames on stack. Used to calculate the rootset. *) - DOT_WORD "0XFFFFFFFF" :: (* An arbitrary function number. *) - LABEL next_lab :: C) - end) C progunit_labs - - val _ = add_lib_function "allocateRegion" - fun allocate_global_regions(region_labs,C) = - foldl (fn (lab,C) => - copy(sp, arg0, - LDO {d=(Int.toString(BI.size_of_reg_desc()*4)),b=sp,t=sp} :: - align_stack_kill_gen1(tmp_reg0, - META_BL{n=false,target=NameLab "allocateRegion",rpLink=rp,callStr="ARGW0=GR, RTNVAL=GR"} :: - restore_stack(store_in_label_kill_gen1(SS.PHREG_ATY ret0,DatLab lab,tmp_reg1,0,C))))) C region_labs - - - fun push_top_level_handler C = - if BI.tag_values() then - (* Push top-level handler on stack *) - COMMENT "PUSH TOP-LEVEL HANDLER ON STACK" :: - copy(sp, tmp_reg1, - load_label_addr_kill_gen1(NameLab "TopLevelHandlerLab", SS.PHREG_ATY mrp,mrp,0, - STWM{r=mrp,d="4",s=Space 0,b=sp} :: - LDO{d="-4",b=tmp_reg1,t=mrp} :: - STWM{r=mrp,d="4",s=Space 0,b=sp} :: (* Push TopLevelHandlerClosure, code ptr at offset 4 from mrp!!! *) - load_label_addr_kill_gen1(exn_ptr_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - LDW{d="0",s=Space 0,b=tmp_reg1,t=mrp} :: - STWM{r=mrp,d="4",s=Space 0,b=sp} :: - LDO{d="4",b=sp,t=sp} :: - STW{r=sp,d="-4",s=Space 0,b=sp} :: - STW{r=sp,d="0",s=Space 0,b=tmp_reg1} :: C))) (* Update exnPtr *) - else - (* Push top-level handler on stack *) - COMMENT "PUSH TOP-LEVEL HANDLER ON STACK" :: - copy(sp, tmp_reg1, - load_label_addr_kill_gen1(NameLab "TopLevelHandlerLab", SS.PHREG_ATY mrp,mrp,0, - STWM{r=mrp,d="4",s=Space 0,b=sp} :: - STWM{r=tmp_reg1,d="4",s=Space 0,b=sp} :: (* Push TopLevelHandlerClosure *) - load_label_addr_kill_gen1(exn_ptr_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - LDW{d="0",s=Space 0,b=tmp_reg1,t=mrp} :: - STWM{r=mrp,d="4",s=Space 0,b=sp} :: - LDO{d="4",b=sp,t=sp} :: - STW{r=sp,d="-4",s=Space 0,b=sp} :: - STW{r=sp,d="0",s=Space 0,b=tmp_reg1} :: C))) (* Update exnPtr *) - - fun init_insts C = - DOT_CODE :: - LABEL (NameLab "code") :: - DOT_PROC :: - DOT_CALLINFO "CALLS, FRAME=0, SAVE_RP, SAVE_SP, ENTRY_GR=18" :: - DOT_ENTRY :: - - (* 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( - - (* Double Align SP *) - COMMENT "DOUBLE ALIGN SP" :: - LDI{i="4",t=tmp_reg1} :: - AND{cond=EQUAL,r1=tmp_reg1,r2=sp,t=tmp_reg1} :: - LDO{d="4",b=sp,t=sp} :: - - (* Initialize stack_bot_gc. *) - load_label_addr_kill_gen1(stack_bot_gc_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, (* tmp_reg1 = &stack_bot_gc *) - STW{r=sp,d="0",s=Space 0,b=tmp_reg1} :: (* *tmp_reg1 = sp *) - - (* Code that jump to progunits. *) - COMMENT "JUMP CODE TO PROGRAM UNITS" :: - generate_jump_code_progunits(progunit_labs, - (* Jump to lab_exit *) - COMMENT "JUMP TO LAB_EXIT" :: - META_B{n=false,target=lab_exit} :: C))))) - - fun lab_exit_insts C = - let val res = if BI.tag_values() then 1 (* 2 * 0 + 1 *) - else 0 - in - LABEL(lab_exit) :: - COMMENT "**** Link Exit code ****" :: - compile_c_call_prim("terminate", [SS.INTEGER_ATY (Int.toString res)], NONE,0,tmp_reg0, - DOT_EXIT :: - DOT_PROCEND :: C) - end - - val init_link_code = init_insts(lab_exit_insts(raise_insts(toplevel_handler(allocate(gc_stub(inline_alloc(inline_alloc_gc(reset_region [])))))))) - in - HppaResolveJumps.RJ{top_decls = [], - init_code = init_link_code, - exit_code = get_lib_functions [], - static_data = get_static_data []} - end - end - - - (* ------------------------------------------------------------ *) - (* Emitting Target Code *) - (* ------------------------------------------------------------ *) - fun emit(prg: AsmPrg,filename: string) : unit = - let - val os = TextIO.openOut filename - in - HpPaRisc.output_AsmPrg(os,prg); - TextIO.closeOut os; - TextIO.output(TextIO.stdOut, "[wrote HP code file:\t" ^ filename ^ "]\n") - end - handle IO.Io {name,...} => Crash.impossible ("HppaKAMBackend.emit:\nI cannot open \"" - ^ filename ^ "\":\n" ^ name) -end; - - - diff --git a/src/Compiler/Backend/HpPaRisc/ExecutionHPPA.sml b/src/Compiler/Backend/HpPaRisc/ExecutionHPPA.sml deleted file mode 100644 index 6e5b85187..000000000 --- a/src/Compiler/Backend/HpPaRisc/ExecutionHPPA.sml +++ /dev/null @@ -1,189 +0,0 @@ - -functor ExecutionHPPA(BuildCompile : BUILD_COMPILE) : EXECUTION = - struct - structure ExecutionArgs = BuildCompile.ExecutionArgs - open ExecutionArgs - - structure Basics = Elaboration.Basics - structure TopdecGrammar = Elaboration.PostElabTopdecGrammar - structure Tools = Basics.Tools - structure AllInfo = Basics.AllInfo - structure PP = Tools.PrettyPrint - structure Name = Basics.Name - structure IntFinMap = Tools.IntFinMap - structure Flags = Tools.Flags - structure Report = Tools.Report - structure Crash = Tools.Crash - - structure HpPaRisc = HpPaRisc(structure Labels = Labels - structure Lvars = Lvars - structure Lvarset = Lvarset - structure Crash = Crash - structure PP = PP) - - structure BackendInfo = - BackendInfo(structure Labels = Labels - structure PP = PP - structure Flags = Flags - structure Report = Report - structure Crash = Crash - val down_growing_stack : bool = false (* false for HPPA code generation *) - val double_alignment_required : bool = true (* true for HPPA code generation *) - val extra_prims = nil) - - structure NativeCompile = NativeCompile(open ExecutionArgs - open BuildCompile - structure BackendInfo = BackendInfo - structure RegisterInfo = HpPaRisc.RI) - - structure CompileBasis = CompileBasis(structure CompBasis = BuildCompile.CompBasis - structure ClosExp = NativeCompile.ClosExp - structure PP = PP - structure Flags = Flags) - - structure JumpTables = JumpTables(structure BI = BackendInfo - structure Crash = Crash) - - structure HppaResolveJumps = - HppaResolveJumps(structure HpPaRisc = HpPaRisc - structure Labels = Labels - structure Crash = Crash - structure IntFinMap = IntFinMap) - - structure HpPaDelaySlotOptimization = - HpPaDelaySlotOptimization(structure HpPaRisc = HpPaRisc - structure Flags = Tools.Flags - structure Crash = Tools.Crash) - - structure CodeGen = CodeGen(structure BI = BackendInfo - structure HpPaRisc = HpPaRisc - structure JumpTables = JumpTables - structure HppaResolveJumps = HppaResolveJumps - structure Con = Con - structure Excon = Excon - structure Lvars = Lvars - structure Lvarset = Lvarset - structure Labels = Labels - structure CallConv = NativeCompile.CallConv - structure LineStmt = NativeCompile.LineStmt - structure SubstAndSimplify = NativeCompile.SubstAndSimplify - structure PP = PP - structure Flags = Tools.Flags - structure Report = Tools.Report - structure Crash = Tools.Crash) - - - structure Compile = BuildCompile.Compile - structure CompilerEnv = BuildCompile.CompilerEnv - - val backend_name = "HPPA" - - (****************************************************************) - (* Add Dynamic Flags *) - (****************************************************************) - - val _ = Flags.add_bool_entry - {long="delay_slot_optimization", short=NONE,item=ref true,neg=true, - menu=["Control", "delay slot optimization"], desc=""} - - 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."} - - val dso_flag = Flags.lookup_flag_entry "delay_slot_optimization" - - val _ = Flags.add_string_entry - {long="clibs", short=NONE, item=ref "-lM", - menu=["Control", "clibs"], - desc="If you have added your own object files to a project, you\n\ - \might also need to link with libraries other than\n\ - \libM.so (\"-lM\")."} - - type CompileBasis = CompileBasis.CompileBasis - type CEnv = BuildCompile.CompilerEnv.CEnv - type strdec = TopdecGrammar.strdec - type target = CodeGen.AsmPrg - type label = NativeCompile.label - - type linkinfo = {code_label:label, imports: label list * label list, exports : label list * label 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 - - datatype res = CodeRes of CEnv * CompileBasis * target * linkinfo - | CEnvOnlyRes of CEnv - - fun compile (ce, CB, strdecs, vcg_file) : res = - let val (cb,closenv) = CompileBasis.de_CompileBasis CB - in case Compile.compile (ce, cb, strdecs, vcg_file) - of Compile.CEnvOnlyRes ce => CEnvOnlyRes ce - | Compile.CodeRes(ce,cb,target,safe) => - let - val (closenv, target_new) = NativeCompile.compile(closenv,target,safe) - val {main_lab, code, imports, exports, safe} = target_new - val asm_prg = Tools.Timing.timing "CG" CodeGen.CG target_new - val asm_prg_dso = - if !dso_flag then Tools.Timing.timing "DSO" HpPaDelaySlotOptimization.DSO asm_prg - else asm_prg - 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) => - if !dso_flag then HpPaDelaySlotOptimization.DSO (CodeGen.generate_link_code (labs,exports)) - else CodeGen.generate_link_code (labs,exports)) - - - fun delete_file f = OS.FileSys.remove f handle _ => () - fun execute_command command : unit = - (OS.Process.system command; ()) -(* handle OS.SysErr(s,_) => die ("\nCommand " ^ command ^ "\nfailed (" ^ s ^ ");") *) - - val delete_target_files = Flags.lookup_flag_entry "delete_target_files" - val clibs = Flags.lookup_string_entry "clibs" - fun assemble (file_s, file_o) = - (execute_command (!(Flags.lookup_string_entry "c_compiler") ^ " -c -o " ^ file_o ^ " " ^ file_s); - if !delete_target_files then delete_file file_s - else ()) - - (*e.g., "cc -Aa -c -o link.o link.s" - - man cc: - -c Suppress the link edit phase of the compilation, and - force an object (.o) file to be produced for each .c - file even if only one program is compiled. Object - files produced from C programs must be linked before - being executed. - - -ooutfile Name the output file from the linker outfile. The - default name is a.out.*) - - 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 link_files_with_runtime_system path_to_runtime files run = - let val files = map (fn s => s ^ " ") files - val shell_cmd = !(Flags.lookup_string_entry "c_compiler") ^ " -o " ^ run ^ " " ^ - concat files ^ path_to_runtime() ^ " " ^ !clibs - in execute_command shell_cmd; - TextIO.output (TextIO.stdOut, "[wrote executable file:\t" ^ run ^ "]\n") - end - - end; diff --git a/src/Compiler/Backend/HpPaRisc/HPPA_RESOLVE_JUMPS.sml b/src/Compiler/Backend/HpPaRisc/HPPA_RESOLVE_JUMPS.sml deleted file mode 100644 index bd0761883..000000000 --- a/src/Compiler/Backend/HpPaRisc/HPPA_RESOLVE_JUMPS.sml +++ /dev/null @@ -1,11 +0,0 @@ -signature HPPA_RESOLVE_JUMPS = - sig - - (* ---------------------------------------------------------------------- - * Resolvation of jumps for HP Precision Architecture code. - * ---------------------------------------------------------------------- *) - - type AsmPrg - val RJ : AsmPrg -> AsmPrg - - end diff --git a/src/Compiler/Backend/HpPaRisc/HP_PA_DELAY_SLOT_OPTIMIZATION.sml b/src/Compiler/Backend/HpPaRisc/HP_PA_DELAY_SLOT_OPTIMIZATION.sml deleted file mode 100644 index 1f4e92328..000000000 --- a/src/Compiler/Backend/HpPaRisc/HP_PA_DELAY_SLOT_OPTIMIZATION.sml +++ /dev/null @@ -1,11 +0,0 @@ -signature HP_PA_DELAY_SLOT_OPTIMIZATION = - sig - - (* ---------------------------------------------------------------------- - * Delay slot optimization for HP Precision Architecture code. - * ---------------------------------------------------------------------- *) - - type AsmPrg - val DSO : AsmPrg -> AsmPrg - - end diff --git a/src/Compiler/Backend/HpPaRisc/HP_PA_RISC.sml b/src/Compiler/Backend/HpPaRisc/HP_PA_RISC.sml deleted file mode 100644 index 4458afd02..000000000 --- a/src/Compiler/Backend/HpPaRisc/HP_PA_RISC.sml +++ /dev/null @@ -1,225 +0,0 @@ -(* Specification of HPPA Risc code. *) - -signature HP_PA_RISC = - sig - - (*----------------------------------------------------------*) - (* Register definitions. *) - (*----------------------------------------------------------*) - - datatype reg = Gen of int (* General Purpose Register *) - | Float of int (* Floating Point Register *) - | Ctrl of int (* Control Register *) - | Space of int (* Space Register *) - - val dp : reg (* Data pointer. *) - val sp : reg (* Stack pointer. *) - val rp : reg (* Return link. *) - val mrp : reg (* Milicode return link. *) - - val tmp_gr1 : reg - val tmp_reg0 : reg - val tmp_reg1 : reg - val tmp_reg2 : reg (* Used in inline_alloc only *) - val tmp_reg3 : reg (* Used in inline_alloc only *) - - val arg0 : reg (* Argument and return registers *) - val arg1 : reg (* for C function calls. *) - val arg2 : reg - val arg3 : reg - val ret0 : reg (* Result from ordinary calls. *) - val ret1 : reg (* Result from millicode calls. *) - - val tmp_float_reg0 : reg (* 8-11 are caller-saves regs. *) - val tmp_float_reg1 : reg - val tmp_float_reg2 : reg - val arg_float0 : reg - val ret_float0 : reg - - (*-----------------------------------------------------------*) - (* Converting Between General Registers and Precolored Lvars *) - (* As Used In The Phases Preceeding Code Generation *) - (*-----------------------------------------------------------*) - - type lvar - - structure RI : REGISTER_INFO - where type reg = reg - where type lvar = lvar - - val lv_to_reg_no : lvar -> int - val callee_save_regs_ccall : reg list - val caller_save_regs_ccall : reg list - val all_regs : reg list - - (*----------------------------------------------------------*) - (* HPPA RISC Syntax *) - (* *) - (* We do not specify cache hints in instructions... *) - (* *) - (*----------------------------------------------------------*) - - val is_im5 : int -> bool - val is_im11 : int -> bool - val is_im12 : int -> bool - val is_im14 : int -> bool - val is_im17 : int -> bool - val is_im19 : int -> bool - - 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 cond = NEVER - | ALWAYS - | EQUAL - | NOTEQUAL - | GREATERTHAN - | GREATEREQUAL - | LESSTHAN - | LESSEQUAL - | GREATERTHAN_UNSIGNED - | GREATEREQUAL_UNSIGNED - | LESSTHAN_UNSIGNED - | LESSEQUAL_UNSIGNED - | ODD - | EVEN - - val revCond : cond -> cond - - datatype comp = EMPTY - | MODIFYBEFORE - | MODIFYAFTER - - datatype fmt = DBL | SGL | QUAD - - datatype RiscInst = - ADD of {cond: cond, r1: reg, r2: reg, t: reg} - | ADDO of {cond: cond, r1: reg, r2: reg, t: reg} - | ADDI of {cond: cond, i: string, r: reg, t: reg} - | ADDIO of {cond: cond, i: string, r: reg, t: reg} - | ADDIL of {i: string, r: reg} - | ADDIL' of {pr_i: unit->string, r: reg} - | AND of {cond: cond, r1: reg, r2: reg, t: reg} - | ANDCM of {cond: cond, r1: reg, r2: reg, t: reg} - - | B of {n: bool, target: lab} - | BL of {n: bool, target: lab, t: reg} - | BLE of {n: bool, wd: string, sr: reg, b: reg} - | BV of {n: bool, x: reg, b: reg} - | BB of {n: bool, cond: cond, r: reg, p: int, target: lab} - - | COMB of {cond: cond, n: bool, r1: reg, r2: reg, target: lab} - | COMCLR of {cond: cond, r1: reg, r2: reg, t: reg} - | COPY of {r: reg, t: reg} - - | DEPI of {cond: cond, i: string, p: string, len: string, t: reg} - - | FABS of {fmt: fmt, r: reg, t: reg} - | FADD of {fmt: fmt, r1: reg, r2: reg, t: reg} - | FCMP of {fmt: fmt, cond: cond, r1: reg, r2: reg} - | FLDDS of {complt: comp, d:string, s: reg, b:reg, t:reg} - | FMPY of {fmt: fmt, r1: reg, r2: reg, t: reg} - | FSTDS of {complt: comp, r:reg, d:string, s: reg, b:reg} - | FSUB of {fmt: fmt, r1: reg, r2: reg, t: reg} - | FTEST - | XMPYU of {r1:reg, r2: reg, t:reg} - - | LDI of {i: string, t: reg} - | LDIL of {i: string, t: reg} - | LDO of {d: string, b: reg, t: reg} - | LDO' of {pr_d: unit->string, b: reg, t: reg} - | LDW of {d: string, s: reg, b: reg, t: reg} - | LDW' of {pr_d: unit->string, s: reg, b: reg, t: reg} - | LDWS of {cmplt: comp, d: string, s: reg, b: reg, t: reg} - | LDWM of {d: string, s: reg, b: reg, t: reg} - - | NOP - - | OR of {cond: cond, r1: reg, r2: reg, t: reg} - | XOR of {cond: cond, r1: reg, r2: reg, t: reg} - | SH1ADD of {cond: cond, r1: reg, r2: reg, t: reg} - | SH2ADD of {cond: cond, r1: reg, r2: reg, t: reg} - - | SHD of {cond: cond, r1: reg, r2: reg, p: string, t: reg} - | SUB of {cond: cond, r1: reg, r2: reg, t: reg} - | SUBO of {cond: cond, r1: reg, r2: reg, t: reg} - | SUBI of {cond: cond, i: string, r: reg, t: reg} - | STW of {r: reg, d: string, s: reg, b: reg} - | STW' of {r: reg, pr_d: unit->string, s: reg, b: reg} - | STWS of {cmplt: comp, r: reg, d: string, s: reg, b: reg} - | STWM of {r: reg, d: string, s: reg, b: reg} - | ZVDEP of {cond:cond, r:reg,d:string,t:reg} - | MTSAR of {r:reg} - | VEXTRS of {cond:cond, r: reg,d:string,t:reg} - | VSHD of {cond:cond, r1:reg, r2:reg,t:reg} - | LABEL of lab - | COMMENT of string - | NOT_IMPL of string - - | DOT_ALIGN of int - | DOT_BLOCKZ of int - | DOT_CALL of string - | DOT_CALLINFO of string - | DOT_CODE - | DOT_DATA - | DOT_DOUBLE of string - | DOT_END - | DOT_ENTER - | DOT_ENTRY - | DOT_EQU of int - | DOT_EXPORT of lab * string - | DOT_IMPORT of lab * string - | DOT_LEAVE - | DOT_EXIT - | DOT_PROC - | DOT_PROCEND - | DOT_STRINGZ of string - | DOT_WORD of string - | DOT_BYTE of string - - | META_IF of {cond: cond, r1: reg, r2: reg, target: lab} - | META_BL of {n: bool, target: lab, rpLink: reg, callStr : string} - | META_BV of {n: bool, x: reg, b: reg} - | META_IF_BIT of {r: reg, bitNo: int, target: lab} - | META_B of {n: bool, target: lab} - - datatype TopDecl = - FUN of label * RiscInst list - | FN of label * RiscInst list - - type AsmPrg = {top_decls: TopDecl list, - init_code: RiscInst list, - exit_code: RiscInst list, - static_data: RiscInst list} - - (*******************************) - (* Basic Compilation Functions *) - (*******************************) - val regs_defd : RiscInst -> reg list - val regs_used : RiscInst -> reg list - val does_inst_nullify : RiscInst -> bool - val is_jmp : RiscInst -> bool - val is_asm_directive : RiscInst -> bool - - (******************) - (* PrettyPrinting *) - (******************) - type StringTree - val layout_AsmPrg : AsmPrg -> StringTree - - (* To Emit Code *) - val pr_inst : RiscInst -> string - val pp_lab : lab -> string -(* val pr_reg : reg -> string *) - val output_AsmPrg : TextIO.outstream * AsmPrg -> unit - - end - diff --git a/src/Compiler/Backend/HpPaRisc/HpPaDelaySlotOptimization.sml b/src/Compiler/Backend/HpPaRisc/HpPaDelaySlotOptimization.sml deleted file mode 100644 index b3c4d8a50..000000000 --- a/src/Compiler/Backend/HpPaRisc/HpPaDelaySlotOptimization.sml +++ /dev/null @@ -1,384 +0,0 @@ -functor HpPaDelaySlotOptimization(structure HpPaRisc : HP_PA_RISC - structure Flags : FLAGS - structure Crash : CRASH) : HP_PA_DELAY_SLOT_OPTIMIZATION = - struct - val debug = true - - (* ---------------------------------------------------------------------- - * Delay slot optimization for HP Precision Architecture code. - * ---------------------------------------------------------------------- *) - open HpPaRisc - - (* ----------------------------- - * Some Basic Tools - * ----------------------------- *) - - fun msg(s: string) = (TextIO.output(TextIO.stdOut, s); TextIO.flushOut TextIO.stdOut) - fun chat s = if !Flags.chat then msg(s ^ " ...\n") else () - fun die s = Crash.impossible ("HpPaDelaySlotOptimization." ^ s) - - (* Function does_inst_nullify is in module HpPaRisc *) - fun doesFirstInstNullify ([]) = false - | doesFirstInstNullify (i::C) = does_inst_nullify(i) - - fun fold f [] a = a - | fold f (x::xs) a = fold f xs (f(x,a)) - - (* Returns true if lists l1 and l2 have no same elements. *) - fun check(l1, l2) = - fold (fn (r1, akk1) => (fold (fn (r2, akk2) => akk2 andalso (r1 <> r2)) l2 akk1)) l1 true; - - (* Returns true if i1 does not define registers used by i2 and *) - (* if i1 does not use registers defined by i2. *) - fun checkDefUse(i1, i2) = check(regs_defd(i1), regs_used(i2)) andalso check(regs_used(i1), regs_defd(i2)) - - (* Checks that inst1 can be put in the delay slot of inst2, and that there are *) - (* no def/use problems between the two instructions. *) - (* When we check def/use dependencies, we do not check for flag registers, so *) - (* therefore some instructions returns false even though they can be put in a *) - (* delay slot. *) - (* We would have to update the functions regs_defd and regs_used in HpPaRisc *) - (* with status registers. *) - fun instOkInDelaySlot (inst1, inst2) = - let - fun chk(i1, i2) = checkDefUse(i1, i2) andalso (not (does_inst_nullify(i1))) - in - case inst1 of - ADD _ => chk(inst1, inst2) - | ADDO _ => chk(inst1, inst2) - | ADDI _ => chk(inst1, inst2) - | ADDIO _ => chk(inst1, inst2) - | ADDIL _ => chk(inst1, inst2) - | ADDIL' _ => chk(inst1, inst2) - | AND _ => false - | ANDCM _ => false - - | B _ => false - | BB _ => false - | BL _ => false - | BLE _ => false - | BV _ => false - - | COMB _ => false - | COMCLR _ => false - | COPY _ => chk(inst1, inst2) - - | DEPI _ => chk(inst1, inst2) - - | FABS _ => false - | FADD _ => false - | FCMP _ => false - | FLDDS _ => false - | FMPY _ => false - | FSTDS _ => false - | FSUB _ => false - | FTEST => false - | XMPYU _ => false - - | LDI _ => chk(inst1, inst2) - | LDIL _ => chk(inst1, inst2) - | LDO _ => chk(inst1, inst2) - | LDO' _ => chk(inst1, inst2) - | LDW _ => chk(inst1, inst2) - | LDW' _ => chk(inst1, inst2) - | LDWS _ => chk(inst1, inst2) - | LDWM _ => chk(inst1, inst2) - - | NOP => false - - | OR _ => false - | XOR _ => false - | SH1ADD _ => false - | SH2ADD _ => false - - | SHD _ => chk(inst1, inst2) - | SUB _ => chk(inst1, inst2) - | SUBO _ => chk(inst1, inst2) - | SUBI _ => chk(inst1, inst2) - | STW _ => chk(inst1, inst2) - | STW' _ => chk(inst1, inst2) - | STWS _ => chk(inst1, inst2) - | STWM _ => chk(inst1, inst2) - - | ZVDEP _ => false - | MTSAR _ => false - | VEXTRS _ => false - | VSHD _ => false - - | LABEL _ => false - | COMMENT _ => false - | NOT_IMPL _ => die "instOkInDelaySlot - NOT_IMPL" - | DOT_ALIGN _ => false - | DOT_BLOCKZ _ => false - | DOT_CALL _ => false - | DOT_CALLINFO _ => false - | DOT_CODE => false - | DOT_DATA => false - | DOT_DOUBLE _ => false - | DOT_END => false - | DOT_ENTER => false - | DOT_ENTRY => false - | DOT_EQU _ => false - | DOT_EXPORT _ => false - | DOT_IMPORT _ => false - | DOT_LEAVE => false - | DOT_EXIT => false - | DOT_PROC => false - | DOT_PROCEND => false - | DOT_STRINGZ _ => false - | DOT_WORD _ => false - | DOT_BYTE _ => false - - | META_IF _ => die "instOkInDelaySlot - META_IF" - | META_BL _ => die "instOkInDelaySlot - META_BL" - | META_BV _ => die "instOkInDelaySlot - META_BV" - | META_IF_BIT _ => die "instOkInDelaySlot - META_IF_BIT" - | META_B _ => die "instOkInDelaySlot - META_B" - end - - (* It is only assembler directives that we do not have to stop for. *) - val haveToStop = - fn ADD _ => true - | ADDO _ => true - | ADDI _ => true - | ADDIO _ => true - | ADDIL _ => true - | ADDIL' _ => true - | AND _ => true - | ANDCM _ => true - - | B _ => true - | BB _ => true - | BL _ => true - | BLE _ => true - | BV _ => true - - | COMB _ => true - | COMCLR _ => true - | COPY _ => true - - | DEPI _ => true - - | FABS _ => true - | FADD _ => true - | FCMP _ => true - | FLDDS _ => true - | FMPY _ => true - | FSTDS _ => true - | FSUB _ => true - | FTEST => true - | XMPYU _ => true - - | LDI _ => true - | LDIL _ => true - | LDO _ => true - | LDO' _ => true - | LDW _ => true - | LDW' _ => true - | LDWS _ => true - | LDWM _ => true - - | NOP => true - - | OR _ => true - | XOR _ => true - | SH1ADD _ => true - | SH2ADD _ => true - - | SHD _ => true - | SUB _ => true - | SUBO _ => true - | SUBI _ => true - | STW _ => true - | STW' _ => true - | STWS _ => true - | STWM _ => true - - | ZVDEP _ => true - | MTSAR _ => true - | VEXTRS _ => true - | VSHD _ => true - - | LABEL _ => true - | COMMENT _ => false - | NOT_IMPL _ => die "haveToStop - NOT_IMPL" - | DOT_ALIGN _ => false - | DOT_BLOCKZ _ => false - | DOT_CALL _ => false - | DOT_CALLINFO _ => false - | DOT_CODE => false - | DOT_DATA => false - | DOT_DOUBLE _ => false - | DOT_END => false - | DOT_ENTER => false - | DOT_ENTRY => false - | DOT_EQU _ => false - | DOT_EXPORT _ => false - | DOT_IMPORT _ => false - | DOT_LEAVE => false - | DOT_EXIT => false - | DOT_PROC => false - | DOT_PROCEND => false - | DOT_STRINGZ _ => false - | DOT_WORD _ => false - | DOT_BYTE _ => false - - | META_IF _ => die "haveToStop - META_IF" - | META_BL _ => die "haveToStop - META_BL" - | META_BV _ => die "haveToStop - META_BV" - | META_IF_BIT _ => die "haveToStop - META_IF_BIT" - | META_B _ => die "haveToStop - META_B" - - fun DSO(prg as {top_decls: TopDecl list, - init_code: RiscInst list, - exit_code: RiscInst list, - static_data: RiscInst list}) = - (* Don't remove init_code - it has to come first *) - (* Don't remove exit_code - it has to come last *) - let - (* Some statistics *) - val numberOfNOP = ref 0 - val numberOfBopt = ref 0 - val numberOfBnoOpt = ref 0 - val numberOfBLopt = ref 0 - val numberOfBLnoOpt = ref 0 - val numberOfBVopt = ref 0 - val numberOfBVnoOpt = ref 0 - val numberOfBLEopt = ref 0 - val numberOfBLEnoOpt = ref 0 - val numberOfBBopt = ref 0 - val numberOfBBnoOpt = ref 0 - - fun findSubInst ([], bInst) = (NOP, []) - | findSubInst (inst::C, bInst) = - if instOkInDelaySlot(inst, bInst) andalso not (doesFirstInstNullify C) then - (inst, C) - else - (if haveToStop inst then - (NOP, inst::C) - else - let - val (sub_inst,C_res) = findSubInst(C, bInst) - in - (sub_inst,inst::C_res) - end) - - fun isNOP NOP = true - | isNOP _ = false - - fun delaySlotOptimizationList(C: RiscInst list,sinceLastLab: RiscInst list -> RiscInst list,result: RiscInst list) = - case C of - [] => sinceLastLab result - | NOP::C' => - let - val _ = numberOfNOP := !numberOfNOP + 1 - in - (case C' of - BL{n,target,t} :: C'' => - let - val (subInst, C_next) = findSubInst(C'',BL{n=n,target=target,t=t}) - val _ = (if isNOP subInst then - numberOfBLnoOpt := !numberOfBLnoOpt + 1 - else - numberOfBLopt := !numberOfBLopt + 1) - in - if doesFirstInstNullify(C'') then - delaySlotOptimizationList(C_next, fn C => BL{n=false,target=target,t=t}::subInst::(sinceLastLab C), result) - else - delaySlotOptimizationList(C_next, fn C => BL{n=false,target=target,t=t}::subInst::C, result) - end - | BV{n=n,x=x,b=base} :: C'' => - let - val (subInst, C_next) = findSubInst(C'',BV{n=n,x=x,b=base}) - val _ = (if isNOP subInst then - numberOfBVnoOpt := !numberOfBVnoOpt + 1 - else - numberOfBVopt := !numberOfBVopt + 1) - in - if doesFirstInstNullify C'' then - delaySlotOptimizationList(C_next, fn C => BV{n=false,x=x,b=base}::subInst::(sinceLastLab C), result) - else - delaySlotOptimizationList(C_next, fn C => BV{n=false,x=x,b=base}::subInst::C, result) - end - | B{n,target} :: C'' => - let - val (subInst, C_next) = findSubInst(C'',B{n=n,target=target}) - val _ = (if isNOP subInst then - numberOfBnoOpt := !numberOfBnoOpt + 1 - else - numberOfBopt := !numberOfBopt + 1) - in - if doesFirstInstNullify C'' then - delaySlotOptimizationList(C_next, fn C => B{n=false,target=target}::subInst::(sinceLastLab C), result) - else - delaySlotOptimizationList(C_next, fn C => B{n=false,target=target}::subInst:: C, result) - end - | BLE{n,wd,sr,b=b'} :: C'' => - let - val (subInst, C_next) = findSubInst(C'', BLE{n=n,wd=wd,sr=sr,b=b'}) - val _ = (if isNOP subInst then - numberOfBLEnoOpt := !numberOfBLEnoOpt + 1 - else - numberOfBLEopt := !numberOfBLEopt + 1) - in - if doesFirstInstNullify C'' then - delaySlotOptimizationList(C_next, fn C => BLE{n=false,wd=wd,sr=sr,b=b'}::subInst::(sinceLastLab C), result) - else - delaySlotOptimizationList(C_next, fn C => BLE{n=false,wd=wd,sr=sr,b=b'}::subInst::C, result) - end - | BB{n,cond,r,p,target} :: C'' => - let - val (subInst, C_next) = findSubInst(C'',BB{n=n,cond=cond,r=r,p=p,target=target}) - val _ = (if isNOP subInst then - numberOfBBnoOpt := !numberOfBBnoOpt + 1 - else - numberOfBBopt := !numberOfBBopt + 1) - in - if doesFirstInstNullify C'' then - delaySlotOptimizationList(C_next, fn C => BB{n=false,cond=cond,r=r,p=p,target=target}::subInst::(sinceLastLab C), result) - else - delaySlotOptimizationList(C_next, fn C => BB{n=false,cond=cond,r=r,p=p,target=target}::subInst::C, result) - end - | _ => delaySlotOptimizationList(C', fn C => NOP::(sinceLastLab C), result)) - end - | LABEL lab :: C' => - let - fun keep_asm_directives([], C) = ([], C) - | keep_asm_directives(i::is,C) = if is_asm_directive i then keep_asm_directives(is,i::C) else (i::is,C) - val (C'',res) = keep_asm_directives(C',LABEL lab::(sinceLastLab result)) - in - delaySlotOptimizationList(C'', fn C => C, res) - end - | inst :: C' => delaySlotOptimizationList(C', fn C => inst::(sinceLastLab C), result) - - fun do_top_decl(FUN(lab,inst_list)) = FUN(lab,delaySlotOptimizationList(List.rev inst_list,fn C => C, [])) - | do_top_decl(FN(lab,inst_list)) = FN(lab,delaySlotOptimizationList(List.rev inst_list,fn C => C, [])) - - val init_code' = delaySlotOptimizationList(List.rev init_code, fn C => C, []) - val top_decls' = List.map do_top_decl top_decls - val exit_code' = delaySlotOptimizationList(List.rev exit_code, fn C => C, []) - - val _ = - if debug then - (chat ("Number of NOPs : " ^ (Int.toString (!numberOfNOP))); - chat ("Number of B optimized : " ^ (Int.toString (!numberOfBopt))); - chat ("Number of B not optimized : " ^ (Int.toString (!numberOfBnoOpt))); - chat ("Number of BL optimized : " ^ (Int.toString (!numberOfBLopt))); - chat ("Number of BL not optimized : " ^ (Int.toString (!numberOfBLnoOpt))); - chat ("Number of BV optimized : " ^ (Int.toString (!numberOfBVopt))); - chat ("Number of BV not optimized : " ^ (Int.toString (!numberOfBVnoOpt))); - chat ("Number of BLE optimized : " ^ (Int.toString (!numberOfBLEopt))); - chat ("Number of BLE not optimized : " ^ (Int.toString (!numberOfBLEnoOpt))); - chat ("Number of BB optimized : " ^ (Int.toString (!numberOfBBopt))); - chat ("Number of BB not optimized : " ^ (Int.toString (!numberOfBBnoOpt)))) - else () - in - {top_decls = top_decls', - init_code = init_code', - exit_code = exit_code', - static_data = static_data} - end - end - - - diff --git a/src/Compiler/Backend/HpPaRisc/HpPaRisc.sml b/src/Compiler/Backend/HpPaRisc/HpPaRisc.sml deleted file mode 100644 index abbd8dd94..000000000 --- a/src/Compiler/Backend/HpPaRisc/HpPaRisc.sml +++ /dev/null @@ -1,1051 +0,0 @@ -(* Specification of HPPA Risc code. *) - -functor HpPaRisc(structure Labels : ADDRESS_LABELS - structure Lvars : LVARS - structure Lvarset : LVARSET - sharing type Lvarset.lvar = Lvars.lvar - structure PP : PRETTYPRINT - structure Crash : CRASH):HP_PA_RISC = - struct - - (***********) - (* Logging *) - (***********) - fun die s = Crash.impossible ("HpPaRisc." ^ s) - - (*----------------------------------------------------------*) - (* Register definitions. *) - (*----------------------------------------------------------*) - - datatype reg = Gen of int (* General Purpose Register *) - | Float of int (* Floating Point Register *) - | Ctrl of int (* Control Register *) - | Space of int (* Space Register *) - - val dp = Gen 27 (* Data pointer. *) - val sp = Gen 30 (* Stack pointer. *) - val rp = Gen 2 (* Return link. *) - val mrp = Gen 31 (* (Milicode) return link. *) - - val tmp_gr1 = Gen 1 - val tmp_reg0 = Gen 19 - val tmp_reg1 = Gen 20 - val tmp_reg2 = Gen 21 (* Used in inline_alloc only *) - val tmp_reg3 = Gen 22 (* Used in inline_alloc only *) - - val arg0 = Gen 26 (* Argument and return registers *) - val arg1 = Gen 25 (* for C function calls. *) - val arg2 = Gen 24 - val arg3 = Gen 23 - val ret0 = Gen 28 (* Result from ordinary calls. *) - val ret1 = Gen 29 (* Result from millicode calls. *) - - val tmp_float_reg0 = Float 8 (* 8-11 are caller-saves regs. *) - val tmp_float_reg1 = Float 9 - val tmp_float_reg2 = Float 10 - val arg_float0 = Float 5 - val ret_float0 = Float 4 - - fun pp_i i = Int.toString i - fun pp_reg(Gen i,acc) = "%r"::(pp_i i)::acc - | pp_reg(Float i,acc) = "%fr"::(pp_i i)::acc - | pp_reg(Ctrl i,acc) = "%cr"::(pp_i i)::acc - | pp_reg(Space i,acc) = "%sr"::(pp_i i)::acc - - (*-----------------------------------------------------------*) - (* Converting Between General Registers and Precolored Lvars *) - (* As Used In The Phases Preceeding Code Generation *) - (*-----------------------------------------------------------*) - - type lvar = Lvars.lvar - - structure RI = - struct - - type reg = reg - type lvar = lvar - type lvarset = Lvarset.lvarset - - structure LvarFinMap = Lvars.Map - - val regs = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31] - val all_regs0 = map Gen regs - val reg_lvs = map (fn i => Lvars.new_named_lvar ("ph"^Int.toString i)) regs - val map_lvs_to_reg = LvarFinMap.fromList(ListPair.zip(reg_lvs,all_regs0)) - val map_reg_to_lvs = Vector.fromList 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_phreg: lv not a register" - | SOME i => i) - - fun reg_to_lv(Gen i) = Vector.sub(map_reg_to_lvs,i) - | reg_to_lv _ = die "reg_to_lv: reg is not a general register (Gen)" - - val all_regs = map reg_to_lv all_regs0 - - val reg_args = map Gen [3,4,5,6,7,8,9,10] - val reg_args_as_lvs = map reg_to_lv reg_args - val args_phreg = reg_args_as_lvs - val reg_res = map Gen [10,9,8,7,6,5,4,3] - val reg_res_as_lvs = map reg_to_lv reg_res - val res_phreg = reg_res_as_lvs - val reg_args_ccall = map Gen [26,25,24,23] - val reg_args_ccall_as_lvs = map reg_to_lv reg_args_ccall - val args_phreg_ccall = reg_args_ccall_as_lvs - val reg_res_ccall = map Gen [28] - val reg_res_ccall_as_lvs = map reg_to_lv reg_res_ccall - val res_phreg_ccall = reg_res_ccall_as_lvs - - val caller_save_regs_mlkit = map Gen [3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,21,22,23,24,25,26,28,29] - val caller_save_regs_mlkit_as_lvs = map reg_to_lv caller_save_regs_mlkit - val caller_save_phregs = caller_save_regs_mlkit_as_lvs - val caller_save_phregset = Lvarset.lvarsetof caller_save_regs_mlkit_as_lvs - fun is_caller_save lv = Lvarset.member (lv,caller_save_phregset) - - val callee_save_regs_ccall = map Gen [3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18] - val callee_save_regs_ccall_as_lvs = map reg_to_lv callee_save_regs_ccall - val callee_save_ccall_phregs = callee_save_regs_ccall_as_lvs - val callee_save_ccall_phregset = Lvarset.lvarsetof callee_save_ccall_phregs - fun is_callee_save_ccall lv = Lvarset.member (lv,callee_save_ccall_phregset) - - (* tmp_reg0, tmp_reg1, mrp and rp should not be in this list as they are never live across a C call *) - val caller_save_regs_ccall = map Gen [21,22,23,24,25,26,28,29] - val caller_save_regs_ccall_as_lvs = map reg_to_lv caller_save_regs_ccall - val caller_save_ccall_phregs = caller_save_regs_ccall_as_lvs - val caller_save_ccall_phregset = Lvarset.lvarsetof caller_save_ccall_phregs - fun is_caller_save_ccall lv = Lvarset.member (lv,caller_save_ccall_phregset) - - fun pr_reg reg = concat(pp_reg(reg,[])) - - fun reg_eq(Gen i1,Gen i2) = i1 = i2 - | reg_eq(Float i1,Float i2) = i2 = i2 - | reg_eq(Ctrl i1,Ctrl i2) = i1 = i2 - | reg_eq(Space i1,Space i2) = i1 = i2 - | reg_eq _ = false - end - - val caller_save_regs_ccall = RI.caller_save_regs_ccall - val callee_save_regs_ccall = RI.callee_save_regs_ccall - val all_regs = RI.all_regs0 - fun lv_to_reg_no lv = - (case RI.lv_to_reg lv of - Gen i => i - | _ => die "lv_to_reg_no: lv is not a register") - - - (*----------------------------------------------------------*) - (* Some Basic Tools *) - (*----------------------------------------------------------*) - - fun die s = Crash.impossible ("HpPaRisc." ^ s) - - fun is_im5 n = n < 16 andalso n >= ~16 - fun is_im11 n = n < 1024 andalso n >= ~1024 - fun is_im12 n = n < 2048 andalso n >= ~2048 - fun is_im14 n = n < 8192 andalso n >= ~8192 - fun is_im17 n = n < 65536 andalso n >= ~65536 - fun is_im19 n = n < 262144 andalso n >= ~262144 - - (*----------------------------------------------------------*) - (* Code *) - (*----------------------------------------------------------*) - - 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 cond = NEVER - | ALWAYS - | EQUAL - | NOTEQUAL - | GREATERTHAN - | GREATEREQUAL - | LESSTHAN - | LESSEQUAL - | GREATERTHAN_UNSIGNED - | GREATEREQUAL_UNSIGNED - | LESSTHAN_UNSIGNED - | LESSEQUAL_UNSIGNED - | ODD - | EVEN - - fun revCond NEVER = ALWAYS - | revCond ALWAYS = NEVER - | revCond EQUAL = NOTEQUAL - | revCond NOTEQUAL = EQUAL - | revCond GREATERTHAN = LESSEQUAL - | revCond GREATEREQUAL = LESSTHAN - | revCond LESSTHAN = GREATEREQUAL - | revCond LESSEQUAL = GREATERTHAN - | revCond GREATERTHAN_UNSIGNED = LESSEQUAL_UNSIGNED - | revCond GREATEREQUAL_UNSIGNED = LESSTHAN_UNSIGNED - | revCond LESSTHAN_UNSIGNED = GREATEREQUAL_UNSIGNED - | revCond LESSEQUAL_UNSIGNED = GREATERTHAN_UNSIGNED - | revCond ODD = EVEN - | revCond EVEN = ODD - - datatype comp = EMPTY - | MODIFYBEFORE - | MODIFYAFTER - - datatype fmt = DBL | SGL | QUAD - - datatype RiscInst = - ADD of {cond: cond, r1: reg, r2: reg, t: reg} - | ADDO of {cond: cond, r1: reg, r2: reg, t: reg} - | ADDI of {cond: cond, i: string, r: reg, t: reg} - | ADDIO of {cond: cond, i: string, r: reg, t: reg} (* Trap on overflow *) - | ADDIL of {i: string, r: reg} - | ADDIL' of {pr_i: unit->string, r: reg} - | AND of {cond: cond, r1: reg, r2: reg, t: reg} - | ANDCM of {cond: cond, r1: reg, r2: reg, t: reg} - - | B of {n: bool, target: lab} - | BL of {n: bool, target: lab, t: reg} - | BLE of {n: bool, wd: string, sr: reg, b: reg} - | BV of {n: bool, x: reg, b: reg} - | BB of {n: bool, cond: cond, r: reg, p: int, target: lab} - - | COMB of {cond: cond, n: bool, r1: reg, r2: reg, target: lab} - | COMCLR of {cond: cond, r1: reg, r2: reg, t: reg} - | COPY of {r: reg, t: reg} - - | DEPI of {cond: cond, i: string, p: string, len: string, t: reg} - - | FABS of {fmt: fmt, r: reg, t: reg} - | FADD of {fmt: fmt, r1: reg, r2: reg, t: reg} - | FCMP of {fmt: fmt, cond: cond, r1: reg, r2: reg} - | FLDDS of {complt: comp, d:string, s: reg, b:reg, t:reg} - | FMPY of {fmt: fmt, r1: reg, r2: reg, t: reg} - | FSTDS of {complt: comp, r:reg, d:string, s: reg, b:reg} - | FSUB of {fmt: fmt, r1: reg, r2: reg, t: reg} - | FTEST - | XMPYU of {r1:reg, r2: reg, t:reg} - - | LDI of {i: string, t: reg} - | LDIL of {i: string, t: reg} - | LDO of {d: string, b: reg, t: reg} - | LDO' of {pr_d: unit->string, b: reg, t: reg} - | LDW of {d: string, s: reg, b: reg, t: reg} - | LDW' of {pr_d: unit->string, s: reg, b: reg, t: reg} - | LDWS of {cmplt: comp, d: string, s: reg, b: reg, t: reg} - | LDWM of {d: string, s: reg, b: reg, t: reg} - - | NOP - - | OR of {cond: cond, r1: reg, r2: reg, t: reg} - | XOR of {cond: cond, r1: reg, r2: reg, t: reg} - | SH1ADD of {cond: cond, r1: reg, r2: reg, t: reg} - | SH2ADD of {cond: cond, r1: reg, r2: reg, t: reg} - - | SHD of {cond: cond, r1: reg, r2: reg, p: string, t: reg} - | SUB of {cond: cond, r1: reg, r2: reg, t: reg} - | SUBO of {cond: cond, r1: reg, r2: reg, t: reg} - | SUBI of {cond: cond, i: string, r: reg, t: reg} - | STW of {r: reg, d: string, s: reg, b: reg} - | STW' of {r: reg, pr_d: unit->string, s: reg, b: reg} - | STWS of {cmplt: comp, r: reg, d: string, s: reg, b: reg} - | STWM of {r: reg, d: string, s: reg, b: reg} - - | ZVDEP of {cond:cond, r:reg,d:string,t:reg} - | MTSAR of {r:reg} - | VEXTRS of {cond:cond, r: reg,d:string,t:reg} - | VSHD of {cond:cond, r1:reg, r2:reg,t:reg} - - | LABEL of lab - | COMMENT of string - | NOT_IMPL of string - - | DOT_ALIGN of int - | DOT_BLOCKZ of int - | DOT_CALL of string - | DOT_CALLINFO of string - | DOT_CODE - | DOT_DATA - | DOT_DOUBLE of string - | DOT_END - | DOT_ENTER - | DOT_ENTRY - | DOT_EQU of int - | DOT_EXPORT of lab * string - | DOT_IMPORT of lab * string - | DOT_LEAVE - | DOT_EXIT - | DOT_PROC - | DOT_PROCEND - | DOT_STRINGZ of string - | DOT_WORD of string - | DOT_BYTE of string - - | META_IF of {cond: cond, r1: reg, r2: reg, target: lab} - | META_BL of {n: bool, target: lab, rpLink: reg, callStr : string} - | META_BV of {n: bool, x: reg, b: reg} - | META_IF_BIT of {r: reg, bitNo: int, target: lab} - | META_B of {n: bool, target: lab} - - datatype TopDecl = - FUN of label * RiscInst list - | FN of label * RiscInst list - - type AsmPrg = {top_decls: TopDecl list, - init_code: RiscInst list, - exit_code: RiscInst list, - static_data: RiscInst list} - - (*----------------------------------------------------------*) - (* Pretty printing *) - (*----------------------------------------------------------*) - - local - val output_stream : TextIO.outstream ref = ref TextIO.stdOut - fun out str = TextIO.output(!output_stream,str) - in - fun reset_output_stream () = output_stream := TextIO.stdOut - fun set_out_stream stream = output_stream := stream - fun out_list str_list = out (concat str_list) - end - - fun remove_ctrl s = "Lab" ^ String.implode (List.filter Char.isAlphaNum (String.explode s)) - fun remove_ctrl' s = String.implode (List.filter Char.isPrint (String.explode s)) - - fun pp_lab (DatLab l) = remove_ctrl(Labels.pr_label l) - | pp_lab (LocalLab l) = "L$" ^ remove_ctrl(Labels.pr_label l) (* L$ is not allowed in HP's as but we use gas *) - | pp_lab (NameLab s) = s - | pp_lab (MLFunLab l) = remove_ctrl(Labels.pr_label l) - - fun pp_lab' (DatLab l,acc) = remove_ctrl(Labels.pr_label l) :: acc - | pp_lab' (LocalLab l,acc) = "L$" :: remove_ctrl(Labels.pr_label l) :: acc (* L$ is not allowed in HP's as but we use gas *) - | pp_lab' (NameLab s,acc) = s :: acc - | pp_lab' (MLFunLab l,acc) = remove_ctrl(Labels.pr_label l) :: acc - - fun pp_cond NEVER = "" - | pp_cond ALWAYS = ",TR" - | pp_cond EQUAL = ",=" - | pp_cond NOTEQUAL = ",<>" - | pp_cond GREATERTHAN = ",>" - | pp_cond GREATEREQUAL = ",>=" - | pp_cond LESSTHAN = ",<" - | pp_cond LESSEQUAL = ",<=" - | pp_cond GREATERTHAN_UNSIGNED = ",>>" - | pp_cond GREATEREQUAL_UNSIGNED = ",>>=" - | pp_cond LESSTHAN_UNSIGNED = ",<<" - | pp_cond LESSEQUAL_UNSIGNED = ",<<=" - | pp_cond ODD = ",OD" - | pp_cond EVEN = ",EV" - - fun pp_comp EMPTY = "" - | pp_comp MODIFYBEFORE = ",MB" - | pp_comp MODIFYAFTER = ",MA" - - fun pp_fmt SGL = ",SGL" - | pp_fmt DBL = ",DBL" - | pp_fmt QUAD = ",QUAD" - - val indent = "\t" - - fun pp_inst (inst,acc) : string list = - case inst of - ADD {cond, r1, r2, t} => - (indent::"ADD"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | ADDO {cond, r1, r2, t} => - (indent::"ADDO"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | ADDI {cond, i, r, t} => - (indent::"ADDI"::(pp_cond cond)::indent::i::", "::(pp_reg (r,", "::(pp_reg (t,acc))))) - | ADDIO {cond, i, r, t} => - (indent::"ADDIO"::(pp_cond cond)::indent::i::", "::(pp_reg (r,", "::(pp_reg (t,acc))))) - | ADDIL {i, r} => - (indent::"ADDIL"::indent::i::", "::(pp_reg (r,acc))) - | ADDIL' {pr_i, r} => - (indent::"ADDIL"::indent::(pr_i())::", "::(pp_reg (r,acc))) - | AND {cond, r1, r2, t} => - (indent::"AND"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | ANDCM {cond, r1, r2, t} => - (indent::"ANDCM"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | B {n, target} => - (indent::"B"::(if n then ",n" else "")::indent::(pp_lab' (target,acc))) - | BB {n, cond, r, p, target} => - (indent::"BB"::(pp_cond cond)::(if n then ",n" else "")::indent::(pp_reg (r,", "::(Int.toString p)::", "::(pp_lab' (target,acc))))) - | BL {n, target, t} => - (indent::"BL"::(if n then ",n" else "")::indent::(pp_lab' (target,", "::(pp_reg (t,acc))))) - | BLE {n, wd, sr, b} => - (indent::"BLE"::(if n then ",n" else "")::indent::wd::"("::(pp_reg (sr,", "::(pp_reg (b,")"::acc))))) - | BV {n, x, b} => - (indent::"BV"::(if n then ",n" else "")::indent::(pp_reg (x,"("::(pp_reg (b,")"::acc))))) - | COMB {cond, n, r1, r2, target} => - (indent::"COMB"::(pp_cond cond)::(if n then ",n" else "")::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_lab' (target,acc))))))) - | COMCLR {cond, r1, r2, t} => - (indent::"COMCLR"::(pp_cond cond)::indent::pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc)))))) - | COPY {r, t} => - (indent::"COPY"::indent::(pp_reg (r,", "::(pp_reg (t,acc))))) - | DEPI {cond, i, p, len, t} => - (indent::"DEPI"::(pp_cond cond)::indent::i::", "::p::", "::len::", "::(pp_reg (t,acc))) - | FABS {fmt, r, t} => - (indent::"FABS"::(pp_fmt fmt)::indent::(pp_reg (r,", "::(pp_reg (t,acc))))) - | FADD {fmt, r1, r2, t} => - (indent::"FADD"::(pp_fmt fmt)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | FCMP {fmt, cond, r1, r2} => - (indent::"FCMP"::(pp_fmt fmt)::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,acc))))) - | FLDDS {complt, d, s, b, t} => - (indent::"FLDDS"::(pp_comp complt)::indent::d::"("::(pp_reg (s,", "::(pp_reg (b,"), "::(pp_reg (t,acc))))))) - | FMPY {fmt, r1, r2, t} => - (indent::"FMPY"::(pp_fmt fmt)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | FSTDS {complt, r, d, s, b} => - (indent::"FSTDS"::(pp_comp complt)::indent::(pp_reg (r,","::d::"("::(pp_reg (s,", "::(pp_reg (b,")"::acc))))))) - | FSUB {fmt, r1, r2, t} => - (indent::"FSUB"::(pp_fmt fmt)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | FTEST => (indent::"FTEST"::acc) - | XMPYU {r1, r2, t} => - (indent::"XMPYU"::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | LDI {i, t} => - (indent::"LDI"::indent::i::", "::(pp_reg (t,acc))) - | LDIL {i, t} => - (indent::"LDIL"::indent::i::", "::(pp_reg (t,acc))) - | LDO {d, b, t} => - (indent::"LDO"::indent::d::"("::(pp_reg (b,"), "::(pp_reg (t,acc))))) - | LDO' {pr_d, b, t} => - (indent::"LDO"::indent::(pr_d())::"("::(pp_reg (b,"), "::(pp_reg (t,acc))))) - | LDW {d, s, b, t} => - (indent::"LDW"::indent::d::"("::(pp_reg (s,", "::(pp_reg (b,"), "::(pp_reg (t,acc))))))) - | LDW'{pr_d, s, b, t} => - (indent::"LDW"::indent::(pr_d())::"("::(pp_reg (s,", "::(pp_reg (b,"), "::(pp_reg (t,acc))))))) - | LDWS {cmplt, d, s, b, t} => - (indent::"LDWS"::(pp_comp cmplt)::indent::d::"("::(pp_reg (s,", "::(pp_reg (b,"), "::(pp_reg (t,acc))))))) - | LDWM {d, s, b, t} => - (indent::"LDWM"::indent::d::"("::(pp_reg (s,", "::(pp_reg (b,"), "::(pp_reg (t,acc))))))) - | NOP => (indent::"NOP"::acc) - | OR {cond, r1, r2, t} => - (indent::"OR"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | XOR {cond, r1, r2, t} => - (indent::"XOR"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | SHD {cond, r1, r2, p, t} => - (indent::"SHD"::(pp_cond cond)::indent::pp_reg (r1,", "::(pp_reg (r2,", "::p::", "::(pp_reg (t,acc)))))) - | SH1ADD {cond, r1, r2, t} => - (indent::"SH1ADD"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | SH2ADD {cond, r1, r2, t} => - (indent::"SH2ADD"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | SUB {cond, r1, r2, t} => - (indent::"SUB"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | SUBO {cond, r1, r2, t} => - (indent::"SUBO"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - | SUBI {cond, i, r, t} => - (indent::"SUBI"::(pp_cond cond)::indent::i::", "::(pp_reg (r,", "::(pp_reg (t,acc))))) - | STW {r, d, s, b} => - (indent::"STW"::indent::(pp_reg (r,", "::d::"("::(pp_reg (s,", "::(pp_reg (b,")"::acc))))))) - | STW' {r, pr_d, s, b} => - (indent::"STW"::indent::(pp_reg (r,", "::(pr_d())::"("::(pp_reg (s,", "::(pp_reg (b,")"::acc))))))) - | STWS {cmplt, r, d, s, b} => - (indent::"STWS"::(pp_comp cmplt)::indent::(pp_reg (r,", "::d::"("::(pp_reg (s,", "::(pp_reg (b,")"::acc))))))) - | STWM {r, d, s, b} => - (indent::"STWM"::indent::(pp_reg (r,", "::d::"("::(pp_reg (s,", "::(pp_reg (b,")"::acc))))))) - - | ZVDEP {cond,r,d,t} => - (indent::"ZVDEP"::indent::(pp_cond cond)::indent::(pp_reg (r,", "::d::", "::(pp_reg (t,acc))))) - | MTSAR {r} => - (indent::"MTSAR"::indent::(pp_reg(r,acc))) - | VEXTRS {cond,r,d,t} => - (indent::"VEXTRS"::indent::(pp_cond cond)::indent::(pp_reg (r,", "::d::", "::(pp_reg (t,acc))))) - | VSHD {cond:cond,r1:reg, r2:reg,t:reg} => - (indent::"VSHD"::(pp_cond cond)::indent::(pp_reg (r1,", "::(pp_reg (r2,", "::(pp_reg (t,acc))))))) - - | LABEL lab => pp_lab' (lab,acc) - | COMMENT s => (indent::indent::indent::indent::"; ":: remove_ctrl' s::acc) - | NOT_IMPL s => (indent::indent::indent::";NOT IMPLEMENTED "::s::acc) - | DOT_ALIGN i => (indent::".ALIGN "::(Int.toString i)::acc) - | DOT_BLOCKZ i=> (indent::".BLOCKZ "::(Int.toString i)::acc) - | DOT_CALL s => (indent::".CALL "::s::acc) - | DOT_CALLINFO s => (indent::".CALLINFO "::s::acc) - | DOT_CODE => (indent::".CODE"::acc) - | DOT_DATA => (indent::".DATA"::acc) - | DOT_DOUBLE s => (indent::".DOUBLE "::s::acc) - | DOT_END => (indent::".END"::acc) - | DOT_ENTER => (indent::".ENTER"::acc) - | DOT_ENTRY => (indent::".ENTRY"::acc) - | DOT_EQU i => (indent::".EQU "::(Int.toString i)::acc) - | DOT_EXPORT (lab, s) => (indent::".EXPORT "::(pp_lab lab)::", "::s::acc) - | DOT_IMPORT (lab, s) => (indent::".IMPORT "::(pp_lab lab)::", "::s::acc) - | DOT_LEAVE => (indent::".LEAVE"::acc) - | DOT_EXIT => (indent::".EXIT"::acc) - | DOT_PROC => (indent::".PROC"::acc) - | DOT_PROCEND => (indent::".PROCEND"::acc) - | DOT_STRINGZ s => - (* generate a .BYTE pseudo instuction for each character in - the string and generate a .BYTE 0 instruction at the end. *) - foldr(fn (ch, acc) => - indent :: ".BYTE " :: Int.toString(ord ch) :: "\n" :: acc - )(indent :: ".BYTE 0" :: acc) (explode s) - | DOT_WORD w => (indent::".WORD "::w::acc) - | DOT_BYTE b => (indent::".BYTE "::b::acc) - - | META_IF {cond, r1, r2, target} => - (indent::"META_IF(cond: "::(pp_cond cond)::", r1: "::(pp_reg (r1,", r2: ":: - (pp_reg (r2,", target: "::(pp_lab' (target,")"::acc))))))) - | META_BL {n, target, rpLink, callStr} => - (indent::"META_BL(n: "::(if n then "true" else "false")::", target: "::(pp_lab' (target,", rpLink: ":: - (pp_reg (rpLink,", callStr: "::callStr::")"::acc))))) - | META_BV {n, x, b} => - (indent::"META_BV(n: "::(if n then "true" else "false")::", x: "::(pp_reg (x,", b: ":: - (pp_reg (b,")"::acc))))) - | META_IF_BIT {r, bitNo, target} => - (indent::"META_IF_BIT(r: "::(pp_reg (r,", bitNo: "::(Int.toString bitNo)::", target: "::(pp_lab' (target,")"::acc))))) - | META_B {n, target} => - (indent::"META_B(n: "::(if n then "true" else "false")::", target: "::(pp_lab' (target,")"::acc))) - - fun pr_inst i = concat(pp_inst(i,[])) - - fun output_AsmPrg (os,{top_decls,init_code,exit_code,static_data}) = - let - fun fold ([], acc) = acc - | fold (inst::insts, acc) = "\n"::(pp_inst(inst, fold (insts, acc))) - fun out_risc_insts insts = out_list (fold(insts, [])) - fun pp_top_decl(FUN(lab,insts)) = - (TextIO.output(os,"\n;fun " ^ Labels.pr_label lab ^ " is {"); - out_risc_insts insts; - TextIO.output(os,"\n;}\n")) - | pp_top_decl(FN(lab,insts)) = - (TextIO.output(os,"\n;fn " ^ Labels.pr_label lab ^ " is {"); - out_risc_insts insts; - TextIO.output(os,"\n;}\n")) - in - (set_out_stream os; - out_risc_insts init_code; - List.app pp_top_decl top_decls; - out_risc_insts exit_code; - out_risc_insts static_data; - TextIO.output(os,"\n\n"); - reset_output_stream()) - end - - type StringTree = PP.StringTree - fun layout_AsmPrg({top_decls,init_code,exit_code,static_data}) = - let - open PP - fun layout_risc_inst i = LEAF(concat(pp_inst(i,[]))) - val init_node = NODE{start="Begin InitCode", - finish="End InitCode", - indent=2, - childsep=RIGHT " ", - children = map layout_risc_inst init_code} - val exit_node = NODE{start="Begin ExitCode", - finish="End ExitCode", - indent=2, - childsep=RIGHT " ", - children=map layout_risc_inst exit_code} - val static_data_node = NODE{start="Begin Static Data", - finish="End Static Data", - indent=2, - childsep=RIGHT " ", - children=map layout_risc_inst static_data} - fun layout_top_decl(FUN(lab,risc_insts)) = - NODE{start = "FUN " ^ Labels.pr_label lab ^ " is {", - finish = "}", - indent = 2, - childsep = RIGHT ";", - children = map layout_risc_inst risc_insts} - | layout_top_decl (FN(lab,risc_insts)) = - NODE{start = "FN " ^ Labels.pr_label lab ^ " is {", - finish = "}", - indent = 2, - childsep = RIGHT ";", - children = map layout_risc_inst risc_insts} - val body_node = NODE{start="", - finish="", - indent=0, - childsep=RIGHT " ", - children=map layout_top_decl top_decls} - in - NODE{start="HP-PARISC program begin", - finish="HP-PARISC program end", - indent=2, - childsep=NOSEP, - children = [init_node,body_node,exit_node,static_data_node]} - end - - (*----------------------------------------------------------*) - (* Defs and Uses (for scheduling) *) - (*----------------------------------------------------------*) - - fun regs_defd i = - case i of - ADD {cond, r1, r2, t} => [t] - | ADDO {cond, r1, r2, t} => [t] - | ADDI {cond, i, r, t} => [t] - | ADDIO {cond, i, r, t} => [t] - | ADDIL {i, r} => [Gen 1] - | ADDIL' {pr_i, r} => [Gen 1] - | AND {cond, r1, r2, t} => [t] - | ANDCM {cond, r1, r2, t} => [t] - - | B {n, target} => [] - | BB {n, cond, r, p, target} => [] - | BL {n, target, t} => [t] - | BLE {n, wd, sr, b} => [mrp] (* The millicall return pointer is defined *) - | BV {n, x, b} => [] - - | COMB {cond, n, r1, r2, target} => die "regs_defd - COMB" - | COMCLR {cond, r1, r2, t} => [t] - | COPY {r, t} => [t] - - | DEPI {cond, i, p, len, t} => [t] - - | FABS {fmt, r, t} => [t] - | FADD {fmt, r1, r2, t} => [t] - | FCMP {fmt, cond, r1, r2} => [] (* FStatusReg *) - | FLDDS {complt, d, s, b, t} => [t,b] - | FMPY {fmt, r1, r2, t} => [t] - | FSTDS {complt, r, d, s, b} => [b] - | FSUB {fmt, r1, r2, t} => [t] - | FTEST => [] - | XMPYU {r1, r2, t} => [t] - - | LDI {i, t} => [t] - | LDIL {i, t} => [t] - | LDO {d, b, t} => [t] - | LDO' {pr_d, b, t} => [t] - | LDW {d, s, b, t} => [t] - | LDW' {pr_d, s, b, t} => [t] - | LDWS {cmplt, d, s, b, t} => [t] - | LDWM {d, s, b, t} => [b, t] - - | NOP => die "regs_defd - NOP" - - | OR {cond, r1, r2, t} => [t] - | XOR {cond, r1, r2, t} => [t] - | SH1ADD {cond, r1, r2, t} => [t] - | SH2ADD {cond, r1, r2, t} => [t] - - | SHD {cond, r1, r2, p, t} => [t] - | SUB {cond, r1, r2, t} => [t] - | SUBO {cond, r1, r2, t} => [t] - | SUBI {cond, i, r, t} => [t] - | STW {r, d, s, b} => [] - | STW' {r, pr_d, s, b} => [] - | STWS {cmplt, r, d, s, b} => [] - | STWM {r, d, s, b} => [b] - - | ZVDEP {cond, r,d,t} => [t] - | MTSAR {r} => [Ctrl 11] - | VEXTRS {cond,r,d,t} => [t] - | VSHD {cond, r1,r2,t} => [t] - - | LABEL lab => [] - | COMMENT s => [] - | NOT_IMPL s => [] - | DOT_ALIGN i => [] - | DOT_BLOCKZ i=> [] - | DOT_CALL s => [] - | DOT_CALLINFO s => [] - | DOT_CODE => [] - | DOT_DATA => [] - | DOT_DOUBLE s => [] - | DOT_END => [] - | DOT_ENTER => [] - | DOT_ENTRY => [] - | DOT_EQU i => [] - | DOT_EXPORT (lab, s) => [] - | DOT_IMPORT (lab, s) => [] - | DOT_LEAVE => [] - | DOT_EXIT => [] - | DOT_PROC => [] - | DOT_PROCEND => [] - | DOT_STRINGZ s => [] - | DOT_WORD w => [] - | DOT_BYTE b => [] - - | META_IF {cond, r1, r2, target} => [] - | META_BL {n, target, rpLink, callStr} => [] - | META_BV {n, x, b} => [] - | META_IF_BIT {r, bitNo, target} => [] - | META_B {n, target} => [] - - fun regs_used i = - case i of - ADD {cond, r1, r2, t} => [r1,r2] - | ADDO {cond, r1, r2, t} => [r1,r2] - | ADDI {cond, i, r, t} => [r] - | ADDIO {cond, i, r, t} => [r] - | ADDIL {i, r} => [r] - | ADDIL' {pr_i, r} => [r] - | AND {cond, r1, r2, t} => [r1,r2] - | ANDCM {cond, r1, r2, t} => [r1,r2] - - | B {n, target} => [] - | BB {n, cond, r, p, target} => [r] - | BL {n, target, t} => [] - | BLE {n, wd, sr, b} => [b] - | BV {n, x, b} => [b,x] - - | COMB {cond, n, r1, r2, target} => [r1,r2] - | COMCLR {cond, r1, r2, t} => [r1,r2] - | COPY {r, t} => [r] - - | DEPI {cond, i, p, len, t} => [t] (* both use and def *) - - | FABS {fmt, r, t} => [r] - | FADD {fmt, r1, r2, t} => [r1,r2] - | FCMP {fmt, cond, r1, r2} => [r1,r2] - | FLDDS {complt, d, s, b, t} => [b] - | FMPY {fmt, r1, r2, t} => [r1,r2] - | FSTDS {complt, r, d, s, b} => [r,b] - | FSUB {fmt, r1, r2, t} => [r1,r2] - | FTEST => [] (* FStatusReg *) - | XMPYU {r1, r2, t} => [r1,r2] - - | LDI {i, t} => [] - | LDIL {i, t} => [] - | LDO {d, b, t} => [b] - | LDO' {pr_d, b, t} => [b] - | LDW {d, s, b, t} => [b] - | LDW' {pr_d, s, b, t} => [b] - | LDWS {cmplt, d, s, b, t} => [b] - | LDWM {d, s, b, t} => [b] - - | NOP => die "regs_used - NOP" - - | OR {cond, r1, r2, t} => [r1,r2] - | XOR {cond, r1, r2, t} => [r1,r2] - | SH1ADD {cond, r1, r2, t} => [r1,r2] - | SH2ADD {cond, r1, r2, t} => [r1,r2] - - | SHD {cond, r1, r2, p, t} => [r1,r2] - | SUB {cond, r1, r2, t} => [r1,r2] - | SUBO {cond, r1, r2, t} => [r1,r2] - | SUBI {cond, i, r, t} => [r] - | STW {r, d, s, b} => [b,r] - | STW' {r, pr_d, s, b} => [b,r] - | STWS {cmplt, r, d, s, b} => [b,r] - | STWM {r, d, s, b} => [b,r] - - | ZVDEP {cond, r,d,t} => [r,Ctrl 11] - | MTSAR {r} => [r] - | VEXTRS {cond,r,d,t} => [r,Ctrl 11] - | VSHD {cond, r1,r2,t} => [r1,r2,Ctrl 11] - - | LABEL lab => [] - | COMMENT s => [] - | NOT_IMPL s => [] - | DOT_ALIGN i => [] - | DOT_BLOCKZ i=> [] - | DOT_CALL s => [] - | DOT_CALLINFO s => [] - | DOT_CODE => [] - | DOT_DATA => [] - | DOT_DOUBLE s => [] - | DOT_END => [] - | DOT_ENTER => [] - | DOT_ENTRY => [] - | DOT_EQU i => [] - | DOT_EXPORT (lab, s) => [] - | DOT_IMPORT (lab, s) => [] - | DOT_LEAVE => [] - | DOT_EXIT => [] - | DOT_PROC => [] - | DOT_PROCEND => [] - | DOT_STRINGZ s => [] - | DOT_WORD w => [] - | DOT_BYTE b => [] - - | META_IF {cond, r1, r2, target} => [] - | META_BL {n, target, rpLink, callStr} => [] - | META_BV {n, x, b} => [] - | META_IF_BIT {r, bitNo, target} => [] - | META_B {n, target} => [] - - fun does_inst_nullify(i) = - case i of - ADD {cond, r1, r2, t} => cond<>NEVER - | ADDO {cond, r1, r2, t} => cond<>NEVER - | ADDI {cond, i, r, t} => cond<>NEVER - | ADDIO {cond, i, r, t} => cond<>NEVER - | ADDIL {i, r} => false - | ADDIL' {pr_i, r} => false - | AND {cond, r1, r2, t} => cond<>NEVER - | ANDCM {cond, r1, r2, t} => cond<>NEVER - - | B {n, target} => true - | BB {n, cond, r, p, target} => true - | BL {n, target, t} => true - | BLE {n, wd, sr, b} => true - | BV {n, x, b} => true - - | COMB {cond, n, r1, r2, target} => true - | COMCLR {cond, r1, r2, t} => cond<>NEVER - | COPY {r, t} => false - - | DEPI {cond, i, p, len, t} => cond<>NEVER - - | FABS {fmt, r, t} => true - | FADD {fmt, r1, r2, t} => true - | FCMP {fmt, cond, r1, r2} => true - | FLDDS {complt, d, s, b, t} => true - | FMPY {fmt, r1, r2, t} => true - | FSTDS {complt, r, d, s, b} => true - | FSUB {fmt, r1, r2, t} => true - | FTEST => true - | XMPYU {r1, r2, t} => true - - | LDI {i, t} => false - | LDIL {i, t} => false - | LDO {d, b, t} => false - | LDO' {pr_d, b, t} => false - | LDW {d, s, b, t} => false - | LDW' {pr_d, s, b, t} => false - | LDWS {cmplt, d, s, b, t} => false - | LDWM {d, s, b, t} => false - - | NOP => false - - | OR {cond, r1, r2, t} => cond<>NEVER - | XOR {cond, r1, r2, t} => cond<>NEVER - | SH1ADD {cond, r1, r2, t} => cond<>NEVER - | SH2ADD {cond, r1, r2, t} => cond<>NEVER - - | SHD {cond, r1, r2, p, t} => cond<>NEVER - | SUB {cond, r1, r2, t} => cond<>NEVER - | SUBO {cond, r1, r2, t} => cond<>NEVER - | SUBI {cond, i, r, t} => cond<>NEVER - | STW {r, d, s, b} => false - | STW' {r, pr_d, s, b} => false - | STWS {cmplt, r, d, s, b} => false - | STWM {r, d, s, b} => false - - | ZVDEP {cond, r,d,t} => cond<>NEVER - | MTSAR {r} => false - | VEXTRS {cond,r,d,t} => cond<>NEVER - | VSHD {cond, r1,r2,t} => cond<>NEVER - - | LABEL lab => false - | COMMENT s => false - | NOT_IMPL s => die "DelaySlotOptimization - doesInstNullify - NOT_IMPL" - | DOT_ALIGN i => false - | DOT_BLOCKZ i => false - | DOT_CALL s => false - | DOT_CALLINFO s => false - | DOT_CODE => false - | DOT_DATA => false - | DOT_DOUBLE s => false - | DOT_END => false - | DOT_ENTER => false - | DOT_ENTRY => false - | DOT_EQU i => false - | DOT_EXPORT (seg, sym) => false - | DOT_IMPORT (sym, seg) => false - | DOT_LEAVE => false - | DOT_EXIT => false - | DOT_PROC => false - | DOT_PROCEND => false - | DOT_STRINGZ s => false - | DOT_WORD w => false - | DOT_BYTE b => false - - | META_IF {cond, r1, r2, target} => die "DelaySlotOptimization - doesInstNullify - META_IF" - | META_BL {n, target, rpLink, callStr} => die "DelaySlotOptimization - doesInstNullify - META_BL" - | META_BV {n, x, b} => die "DelaySlotOptimization - doesInstNullify - META_BV" - | META_IF_BIT {r, bitNo, target} => die "DelaySlotOptimization - doesInstNullify - META_IF_BIT" - | META_B {n, target} => die "DelaySlotOptimization - doesInstNullify - META_B" - - fun is_jmp i = - case i of - ADD _ => false - | ADDO _ => false - | ADDI _ => false - | ADDIO _ => false - | ADDIL _ => false - | ADDIL' _ => false - | AND _ => false - | ANDCM _ => false - - | B _ => true - | BB _ => true - | BL _ => true - | BLE _ => true - | BV _ => true - - | COMB _ => true - | COMCLR _ => false - | COPY _ => false - - | DEPI _ => false - - | FABS _ => false - | FADD _ => false - | FCMP _ => false - | FLDDS _ => false - | FMPY _ => false - | FSTDS _ => false - | FSUB _ => false - | FTEST => false - | XMPYU _ => false - - | LDI _ => false - | LDIL _ => false - | LDO _ => false - | LDO' _ => false - | LDW _ => false - | LDW' _ => false - | LDWS _ => false - | LDWM _ => false - - | NOP => false - - | OR _ => false - | XOR _ => false - | SH1ADD _ => false - | SH2ADD _ => false - - | SHD _ => false - | SUB _ => false - | SUBO _ => false - | SUBI _ => false - | STW _ => false - | STW' _ => false - | STWS _ => false - | STWM _ => false - - | ZVDEP _ => false - | MTSAR _ => false - | VEXTRS _ => false - | VSHD _ => false - - | LABEL _ => false - | COMMENT _ => false - | NOT_IMPL _ => false - | DOT_ALIGN _ => false - | DOT_BLOCKZ _ => false - | DOT_CALL _ => false - | DOT_CALLINFO _ => false - | DOT_CODE => false - | DOT_DATA => false - | DOT_DOUBLE _ => false - | DOT_END => false - | DOT_ENTER => false - | DOT_ENTRY => false - | DOT_EQU _ => false - | DOT_EXPORT _ => false - | DOT_IMPORT _ => false - | DOT_LEAVE => false - | DOT_EXIT => false - | DOT_PROC => false - | DOT_PROCEND => false - | DOT_STRINGZ _ => false - | DOT_WORD _ => false - | DOT_BYTE _ => false - - | META_IF _ => true - | META_BL _ => true - | META_BV _ => true - | META_IF_BIT _ => true - | META_B _ => true - - fun is_asm_directive i = - case i of - ADD _ => false - | ADDO _ => false - | ADDI _ => false - | ADDIO _ => false - | ADDIL _ => false - | ADDIL' _ => false - | AND _ => false - | ANDCM _ => false - - | B _ => false - | BB _ => false - | BL _ => false - | BLE _ => false - | BV _ => false - - | COMB _ => false - | COMCLR _ => false - | COPY _ => false - - | DEPI _ => false - - | FABS _ => false - | FADD _ => false - | FCMP _ => false - | FLDDS _ => false - | FMPY _ => false - | FSTDS _ => false - | FSUB _ => false - | FTEST => false - | XMPYU _ => false - - | LDI _ => false - | LDIL _ => false - | LDO _ => false - | LDO' _ => false - | LDW _ => false - | LDW' _ => false - | LDWS _ => false - | LDWM _ => false - - | NOP => false - - | OR _ => false - | XOR _ => false - | SH1ADD _ => false - | SH2ADD _ => false - - | SHD _ => false - | SUB _ => false - | SUBO _ => false - | SUBI _ => false - | STW _ => false - | STW' _ => false - | STWS _ => false - | STWM _ => false - - | ZVDEP _ => false - | MTSAR _ => false - | VEXTRS _ => false - | VSHD _ => false - - | LABEL _ => true - | COMMENT _ => true - | NOT_IMPL _ => true - | DOT_ALIGN _ => true - | DOT_BLOCKZ _ => true - | DOT_CALL _ => true - | DOT_CALLINFO _ => true - | DOT_CODE => true - | DOT_DATA => true - | DOT_DOUBLE _ => true - | DOT_END => true - | DOT_ENTER => true - | DOT_ENTRY => true - | DOT_EQU _ => true - | DOT_EXPORT _ => true - | DOT_IMPORT _ => true - | DOT_LEAVE => true - | DOT_EXIT => true - | DOT_PROC => true - | DOT_PROCEND => true - | DOT_STRINGZ _ => true - | DOT_WORD _ => true - | DOT_BYTE _ => true - - | META_IF _ => die "Not possible at assembler level." - | META_BL _ => die "Not possible at assembler level." - | META_BV _ => die "Not possible at assembler level." - | META_IF_BIT _ => die "Not possible at assembler level." - | META_B _ => die "Not possible at assembler level." - - end - - diff --git a/src/Compiler/Backend/HpPaRisc/HppaResolveJumps.sml b/src/Compiler/Backend/HpPaRisc/HppaResolveJumps.sml deleted file mode 100644 index 834dc7bdb..000000000 --- a/src/Compiler/Backend/HpPaRisc/HppaResolveJumps.sml +++ /dev/null @@ -1,215 +0,0 @@ - -functor HppaResolveJumps(structure HpPaRisc : HP_PA_RISC - structure Labels : ADDRESS_LABELS - sharing type Labels.label = HpPaRisc.label - structure IntFinMap : MONO_FINMAP where type dom = int - structure Crash : CRASH) : HPPA_RESOLVE_JUMPS = - struct - - (* ---------------------------------------------------------------------- - * Resolvation of jumps for HP Precision Architecture code. - * ---------------------------------------------------------------------- *) - - open HpPaRisc - - (* ----------------------------- - * Some Basic Tools - * ----------------------------- *) - - fun die s = Crash.impossible ("HppaResolveJumps." ^ s) - - (* instSize inst: For all meta instructions we see below and count the max. number of - * instructions that the meta instruction may be expanded into. The pseudo instruction - * loadlabel generates 2 instructions (see the HpPaRisc functor.) I guess we could - * return zero for all data space pseudo instructions since we only resolve program - * space distances. 12/11/97-Martin: I *) - - val instSize = - fn META_IF _ => 4 - | META_BL _ => 4 - | META_BV _ => 2 - | META_IF_BIT _ => 5 (* was 3 *) - | META_B _ => 4 (* was 3 *) - | COMMENT _ => 0 - | DOT_ALIGN i => (i div 4) + 1 (* was i div 4 *) - | DOT_CALL _ => 10 - | DOT_CALLINFO _ => 40 - | DOT_ENTER => 40 - | DOT_LEAVE => 40 - | DOT_PROC => 0 - | DOT_PROCEND => 0 - | LABEL _ => 0 - | _ => 1 - - fun genOffsetMaps {top_decls: TopDecl list, - init_code: RiscInst list, - exit_code: RiscInst list, - static_data: RiscInst list} = - let - (* mlm : ML Fun label map *) - fun addMap (i, (mlm,lm,offset)) = case i (* lm : Local label map *) - of LABEL(MLFunLab label) => (IntFinMap.add (Labels.key label, offset, mlm),lm,offset) - | LABEL(LocalLab label) => (mlm, IntFinMap.add (Labels.key label,offset,lm),offset) - | LABEL _ => (mlm,lm,offset) - | _ => (mlm,lm,offset+instSize i) - fun genOffsetMapRiscInstList([], maps) = maps - | genOffsetMapRiscInstList(inst::inst_list,maps) = genOffsetMapRiscInstList(inst_list,addMap(inst,maps)) - fun genOffsetMapTopDecl(FUN(_,inst_list),maps) = genOffsetMapRiscInstList(inst_list,maps) - | genOffsetMapTopDecl(FN(_,inst_list),maps) = genOffsetMapRiscInstList(inst_list,maps) - val initMaps = genOffsetMapRiscInstList(init_code,(IntFinMap.empty, IntFinMap.empty,0)) - fun genOffsetMapTopDecls([],maps) = maps - | genOffsetMapTopDecls(top_decl::top_decls,maps) = genOffsetMapTopDecls(top_decls,genOffsetMapTopDecl(top_decl,maps)) - val funMaps = genOffsetMapTopDecls(top_decls,initMaps) - val (mlm,lm,offset) = genOffsetMapRiscInstList(exit_code,funMaps) - in - (mlm,lm) - end - - (* Note, that (only) tmp_reg0 and Gen 1 is used as temporary registers below. *) - fun RJ (prg as {top_decls: TopDecl list, - init_code: RiscInst list, - exit_code: RiscInst list, - static_data: RiscInst list}) = - (* Don't remove init_code - it has to come first *) - (* Don't remove exit_code - it has to come last *) - let - val (blockMap,localMap) = genOffsetMaps prg - fun lookup m n = case IntFinMap.lookup m n - of SOME i => i - | NONE => die "lookup" - - val longjump = 3000000 - val _ = if is_im19 longjump then die "longjump not long enough" else () - - fun jumpSize (MLFunLab label,offset) = (case IntFinMap.lookup blockMap (Labels.key label) - of SOME n => (n - offset) * 4 - | NONE => longjump) - | jumpSize (LocalLab label,offset) = (lookup localMap (Labels.key label) - offset) * 4 - | jumpSize (NameLab labStr,_) = longjump - | jumpSize _ = die "jumpSize" - - fun loadLabel(lab,destReg,C) = - ADDIL'{pr_i=fn() => "L'" ^ pp_lab lab ^ "-$global$", r=dp} :: - LDO'{pr_d=fn() => "R'" ^ pp_lab lab ^ "-$global$", b=Gen 1, t=destReg} :: C - - fun resolveInst(inst,offset,C) = - case inst - of META_IF {cond: cond, r1: reg, r2: reg, target: lab} => - let - val js = jumpSize(target,offset) - in - if is_im14 js then - COMB {cond=revCond cond, n=true, r1=r1, r2=r2, target=target} :: C - else - if is_im19 js then - COMCLR {cond=cond, r1=r1, r2=r2, t=Gen 1} :: - B {n=true, target=target} :: C - else - loadLabel(target,tmp_reg0, (* 2 insts *) - COMCLR{cond=cond,r1=r1,r2=r2,t=Gen 1} :: - BV{n=true,x=Gen 0, b=tmp_reg0} :: C) - end - | META_BL {n: bool, target: lab, rpLink: reg, callStr : string} => - let - val js = jumpSize(target,offset) - in - if is_im19 js then - DOT_CALL callStr :: - BL{n=false, target=target, t=rpLink} :: - NOP :: C - else - DOT_CALL callStr :: - LDIL {i="L'" ^ pp_lab target, t=Gen 1} :: - BLE {n=false, wd="R'" ^ pp_lab target, sr=Space 4, b=Gen 1} :: - COPY {r=Gen 31, t=rpLink} :: C - end - | META_BV {n: bool, x: reg, b: reg} => - (* This may only take up one instruction *) - BV {n=false,x=x,b=b} :: - NOP :: C - | META_IF_BIT {r: reg, bitNo: int, target: lab} => - let - val js = jumpSize(target,offset) - in - if is_im14 js then - BB {n=true, cond=GREATEREQUAL, r=r, p=bitNo, target=target} :: C - else - if is_im19 js then - if bitNo < 31 then - SHD{cond=NEVER, r1=Gen 0, r2=r, p=Int.toString (31-bitNo), t=Gen 1} :: - AND {cond=ODD, r1=Gen 1, r2=Gen 1, t=Gen 0} :: - B {n=true, target=target} :: C - else - AND {cond=ODD, r1=r, r2=r, t=Gen 0} :: - B {n=true, target=target} :: C - else - if bitNo < 31 then - loadLabel(target,tmp_reg0, (* 2 insts *) - SHD{cond=NEVER, r1=Gen 0, r2=r, p=Int.toString (31-bitNo), t=Gen 1} :: - AND{cond=ODD, r1=Gen 1, r2=Gen 1, t=Gen 0} :: - BV{n=true,x=Gen 0, b=tmp_reg0} :: C) - else - loadLabel(target,tmp_reg0, (* 2 insts *) - AND{cond=ODD, r1=r, r2=r, t=Gen 0} :: - BV{n=true,x=Gen 0, b=tmp_reg0} :: C) - end - | META_B {n: bool, target: lab} => - let - val js = jumpSize(target,offset) - in - if is_im19 js then - B{n=false, target=target} :: - NOP :: C - else - loadLabel(target, tmp_reg0, - BV{n=false,x=Gen 0, b=tmp_reg0} :: - NOP :: C) - end - | _ => inst :: C - - fun resolveRiscInstList(inst_list,offset) = - let - fun fold ([],offset) = ([],offset) - | fold (inst::insts,offset) = - let - val offset' = offset + instSize inst - val (C',offset'') = fold(insts,offset') - in - (resolveInst(inst,offset,C'),offset'') - end - in - fold(inst_list,offset) - end - fun do_top_decl(FUN(lab,inst_list),offset) = - let - val (inst_list',offset') = resolveRiscInstList(inst_list,offset) - in - (FUN(lab,inst_list'),offset') - end - | do_top_decl(FN(lab,inst_list),offset) = - let - val (inst_list',offset') = resolveRiscInstList(inst_list,offset) - in - (FN(lab,inst_list'),offset') - end - val (init_code',offset_init) = resolveRiscInstList(init_code,0) - fun do_top_decls([],offset) = ([],offset) - | do_top_decls(top_decl::top_decls,offset) = - let - val (top_decl',offset') = do_top_decl(top_decl,offset) - val (C',offset'') = do_top_decls(top_decls,offset') - in - (top_decl'::C',offset'') - end - val (top_decls',offset_top_decls) = do_top_decls(top_decls,offset_init) - val (exit_code',_) = resolveRiscInstList(exit_code,offset_top_decls) - in - {top_decls = top_decls', - init_code = init_code', - exit_code = exit_code', - static_data = static_data} - end - end - - - diff --git a/src/Compiler/Backend/KAM/.cvsignore b/src/Compiler/Backend/KAM/.cvsignore deleted file mode 100644 index b3700a6ae..000000000 --- a/src/Compiler/Backend/KAM/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB OpcodesKAM.sml OPCODES_KAM.sml BuiltInCFunctionsKAM.sml diff --git a/src/Compiler/Backend/KAM/.gitignore b/src/Compiler/Backend/KAM/.gitignore deleted file mode 100644 index 8dba29d7a..000000000 --- a/src/Compiler/Backend/KAM/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -BuiltInCFunctionsKAM.sml -OPCODES_KAM.sml -OpcodesKAM.sml diff --git a/src/Compiler/Backend/KAM/BUFF_CODE.sml b/src/Compiler/Backend/KAM/BUFF_CODE.sml deleted file mode 100644 index 569c20590..000000000 --- a/src/Compiler/Backend/KAM/BUFF_CODE.sml +++ /dev/null @@ -1,30 +0,0 @@ -(* To buffer bytecode during emission *) -(* Taken from the Moscow ML compiler *) - -signature BUFF_CODE = - sig - val out_position : int ref - val init_out_code : unit -> unit - - val out_i : int -> unit - val out_long_i32 : Int32.int -> unit - val out_short_i : int -> unit - val out_long_i : int -> unit - - val out_w : Word.word -> unit - val out_short_w : Word.word -> unit - val out_long_w : Word.word -> unit - - val out_long_w32 : Word32.word -> unit - - val out_real : real -> unit - - type key = int * string (*Label key; the string is the base (i.e., the program unit) *) - - val dump_buffer : {filename : string, - main_lab_opt : key option, - map_import_code : (int * key) list, - map_import_data : (int * key) list, - map_export_code : (key * int) list, - map_export_data : (key * int) list} -> unit - end diff --git a/src/Compiler/Backend/KAM/BuffCode.sml b/src/Compiler/Backend/KAM/BuffCode.sml deleted file mode 100644 index 678075682..000000000 --- a/src/Compiler/Backend/KAM/BuffCode.sml +++ /dev/null @@ -1,146 +0,0 @@ -(* To buffer bytecode during emission *) -(* Taken from the Moscow ML compiler *) - -structure BuffCode : BUFF_CODE = - struct - type key = int * string - local - fun make_buffer n = Word8Array.array(n, Word8.fromInt 0); - fun incr r = r := !r + 1; - in - val out_buffer = ref (make_buffer 512) - val out_position = ref 0 - - fun realloc_out_buffer () = - let - val len = Word8Array.length (!out_buffer) - val new_buffer = make_buffer (2 * len) - in - Word8Array.foldl (fn (e,i) => - (Word8Array.update(new_buffer,i,e); i+1)) - 0 (!out_buffer); - out_buffer := new_buffer - end - - fun init_out_code () = (out_position := 0) - - fun out_w8 (b : Word8.word) = - let - val out_w8 = b -(* val _ = print (Word8.toString out_w8 ^ ",") *) - in - (if !out_position < Word8Array.length (!out_buffer) then - () - else - realloc_out_buffer(); - Word8Array.update(!out_buffer, !out_position, out_w8); - incr out_position) - end - - fun wtow8 (w : Word.word) = Word8.fromLargeWord (Word.toLargeWord w) - fun w32tow8 (w : Word32.word) = Word8.fromLargeWord (Word32.toLargeWord w) - fun itow8 (i : int) = Word8.fromInt i - - val out_w = out_w8 o wtow8 - - fun out_i (b : int) = out_w8 (itow8 b) - - fun out_short_w (s : Word.word) = - (out_w8 (wtow8 s); - out_w8 (wtow8 (Word.>> (s,Word.fromInt 8)))) - - fun out_short_i (s : int) = - (out_w8 (wtow8 (Word.fromInt s)); - out_w8 (wtow8 (Word.~>> (Word.fromInt s,Word.fromInt 8)))) - - fun out_long_w (l : Word.word) = - (out_w8 (wtow8 l); - out_w8 (wtow8 (Word.>> (l,Word.fromInt 8))); - out_w8 (wtow8 (Word.>> (l,Word.fromInt 16))); - out_w8 (wtow8 (Word.>> (l,Word.fromInt 24)))) - - fun out_long_i (l : int) = - (out_w8 (itow8 l); - out_w8 (wtow8 (Word.>> (Word.fromInt l,Word.fromInt 8))); - out_w8 (wtow8 (Word.>> (Word.fromInt l,Word.fromInt 16))); - out_w8 (wtow8 (Word.~>> (Word.fromInt l,Word.fromInt 24)))) - - fun out_long_w32 (l : Word32.word) = - (out_w8 (w32tow8 l); - out_w8 (w32tow8 (Word32.>> (l,Word.fromInt 8))); - out_w8 (w32tow8 (Word32.>> (l,Word.fromInt 16))); - out_w8 (w32tow8 (Word32.>> (l,Word.fromInt 24)))) - - fun out_long_i32 (l : Int32.int) = - out_long_w32 (Word32.fromLargeInt (Int32.toLarge l)) - - fun out_long_w32' (os, l : Word32.word) = - (BinIO.output1 (os, w32tow8 l); - BinIO.output1 (os, w32tow8 (Word32.>> (l,Word.fromInt 8))); - BinIO.output1 (os, w32tow8 (Word32.>> (l,Word.fromInt 16))); - BinIO.output1 (os, w32tow8 (Word32.>> (l,Word.fromInt 24)))) - - fun out_real (r : real) : unit = - Word8Vector.app out_w8 (PackRealLittle.toBytes r) - - fun out_string (os,s:string) : unit = - let val sz = size s - in out_long_w32' (os, Word32.fromInt sz) - ; BinIO.output (os, Byte.stringToBytes s) - - end - - fun out_lab (os, lab) = - let val (i,s) = lab - in out_long_w32'(os, Word32.fromInt i) - ; out_string(os, s) - end - - fun out_addr (os, addr) = - out_long_w32'(os, Word32.fromInt addr) - - fun out_addr_lab_pairs (os, ps) = - app (fn (addr,lab) => (out_addr (os,addr) ; out_lab(os,lab))) ps - - fun out_lab_addr_pairs (os, ps) = - app (fn (lab,addr) => (out_lab(os,lab); out_addr (os,addr))) ps - - fun extract(a,n) = - Word8Vector.tabulate(n,fn i => Word8Array.sub(a,i)) - - fun dump_buffer {filename : string, - main_lab_opt : key option, - map_import_code : (int * key) list, (* (address,label)-pairs *) (* meaning: at address in bytecode, there is a use of the label *) - map_import_data : (int * key) list, (* (address,label)-pairs *) - map_export_code : (key * int) list, (* (label,address)-pairs *) (* meaning: function labeled label is defined at address *) - map_export_data : (key * int) list} = (* (label,address)-pairs *) - let - val os : BinIO.outstream = BinIO.openOut filename - val main_lab = case main_lab_opt - of SOME lab => lab - | NONE => (0,"") - val magic = case Word32.fromString "0x4b303031" (*K001*) - of SOME magic => magic - | NONE => raise Fail "NO WAY!" - in -(* print ("Out position is " ^ Int.toString (!out_position) ^ "\n"); *) - (out_long_w32'(os, Word32.fromInt (!out_position)); - out_lab(os, main_lab); - out_long_w32'(os, Word32.fromInt (List.length map_import_code)); - out_long_w32'(os, Word32.fromInt (List.length map_import_data)); - out_long_w32'(os, Word32.fromInt (List.length map_export_code)); - out_long_w32'(os, Word32.fromInt (List.length map_export_data)); - out_long_w32'(os, magic); - BinIO.output(os, extract(!out_buffer, !out_position)); -(* print ("Writing code import (address,label)-pairs\n"); *) - out_addr_lab_pairs(os, map_import_code); -(* print ("Writing data import (address,label)-pairs\n"); *) - out_addr_lab_pairs(os, map_import_data); -(* print ("Writing code export (label,address)-pairs\n"); *) - out_lab_addr_pairs(os, map_export_code); -(* print ("Writing data export (label,address)-pairs\n"); *) - out_lab_addr_pairs(os, map_export_data); - BinIO.closeOut os) handle E => (BinIO.closeOut os; raise E) - end - end - end diff --git a/src/Compiler/Backend/KAM/BuiltInCFunctions.spec b/src/Compiler/Backend/KAM/BuiltInCFunctions.spec deleted file mode 100644 index 1b0de7d94..000000000 --- a/src/Compiler/Backend/KAM/BuiltInCFunctions.spec +++ /dev/null @@ -1,188 +0,0 @@ -stdErrStream -stdOutStream -stdInStream -sqrtFloat -lnFloat -negInfFloat -posInfFloat -sml_getrutime -sml_getrealtime -sml_localoffset -exnNameML -printReal -printStringML -printNum -printList -implodeCharsML -implodeStringML -concatStringML -__div_int32ub -__div_int31 -__div_word32ub -__div_word31 -__mod_int32ub -__mod_int31 -__mod_word32ub -__mod_word31 -word_table0 -word_table_init -allocStringML -chrCharML -greaterStringML -lessStringML -lesseqStringML -greatereqStringML -equalStringML -__quot_int32ub -__quot_int31 -__rem_int32ub -__rem_int31 -divFloat -remFloat -realFloor -realCeil -realTrunc -realRound -sinFloat -cosFloat -atanFloat -asinFloat -acosFloat -atan2Float -expFloat -powFloat -sinhFloat -coshFloat -tanhFloat -floorFloat -ceilFloat -truncFloat -stringOfFloat -isnanFloat -realInt -generalStringOfFloat -sml_real_to_bytes -sml_bytes_to_real -closeStream -openInStream -openOutStream -openAppendStream -flushStream -outputStream -outputBinStream -inputStream -input1Stream -lookaheadStream -openInBinStream -openOutBinStream -openAppendBinStream -sml_errormsg -sml_errno -sml_access -sml_getdir -sml_isdir -sml_mkdir -sml_chdir -sml_readlink -sml_islink -sml_realpath -sml_devinode -sml_rmdir -sml_modtime -sml_filesize -sml_remove -sml_rename -sml_settime -sml_opendir -sml_readdir -sml_rewinddir -sml_closedir -sml_system -sml_getenv -terminateML -sml_commandline_name -sml_commandline_args -sml_localtime -sml_gmtime -sml_mktime -sml_asctime -sml_strftime -precision -get_time_base -min_fixed_int -max_fixed_int -sml_dlopen -resolveFun -isResolvedFun -fromCtoMLstring -sml_WIFEXITED -sml_WIFSIGNALED -sml_WIFSTOPPED -sml_WEXITSTATUS -sml_WTERMSIG -sml_WSTOPSIG -sml_waitpid -exit -fork -sml_getStdNumbers -sml_microsleep -sml_exec -sml_sysconf -sml_times -sml_lower -link -rename -symlink -unlink -rmdir -chown -fchown -sml_pipe -close -sml_dupfd -isatty -sml_setFailNumber -sml_syserror -sml_findsignal -sml_errorName -alarm -kill -pause -sml_ctermid -sml_environ -getegid -getgid -geteuid -getuid -sml_getgroups -sml_getlogin -getpgrp -getpid -getppid -setgid -setsid -sml_gettime -sml_ttyname -setuid -setpgid -sml_uname -sml_lseek -sml_readVec -sml_writeVec -sml_readArr -sml_isreg -sml_setfl -sml_getfl -sml_filesizefd -sml_getgrgid -sml_getgrnam -sml_getpwnam -sml_getpwuid -sml_getTty -sml_fpathconf -sml_pathconf -ftruncate -sml_stat -sml_fstat -sml_lstat - diff --git a/src/Compiler/Backend/KAM/BuiltInCFunctionsApSml.spec b/src/Compiler/Backend/KAM/BuiltInCFunctionsApSml.spec deleted file mode 100644 index 977dfdbac..000000000 --- a/src/Compiler/Backend/KAM/BuiltInCFunctionsApSml.spec +++ /dev/null @@ -1,46 +0,0 @@ -ap_internal_redirect -apsml_rputs -apsml_returnHtml -apsml_returnRedirect -apsml_returnFile -apsml_log -apsml_getport -apsml_gethost -apsml_getserver -apsml_geturl -apsml_getpeer -apsml_getQueryData -apsml_headers -apsml_add_headers_out -apsml_PageRoot -apsml_encodeUrl -apsml_decodeUrl -apsml_method -apsml_scheme -apsml_contentlength -apsml_setMimeType -apsml_cacheCreate -apsml_cacheFind -apsml_cacheFlush -apsml_cacheSet -apsml_cacheGet -apsml_GetReqRec -apsml_conflookup -apsml_confinsert -apdns_getFQDN_MX -apsml_sendmail -apsml_mailget -apsml_mailer_initconn -apsml_closeconn -apsml_mailGetError -apsml_errnoToString -apsml_mailer_initconnCheckCon -apsml_getuptime -apsml_reg_schedule -apsml_getpage -getMaxHeapPoolSz -setMaxHeapPoolSz -sml_getAuxData -apsml_getuser -apsml_get_auth_type -apsml_mkrequest \ No newline at end of file diff --git a/src/Compiler/Backend/KAM/BuiltInCFunctionsNsSml.spec b/src/Compiler/Backend/KAM/BuiltInCFunctionsNsSml.spec deleted file mode 100644 index 3bcd275ee..000000000 --- a/src/Compiler/Backend/KAM/BuiltInCFunctionsNsSml.spec +++ /dev/null @@ -1,70 +0,0 @@ -nssml_LogRegionPageStat -Ns_ConnReturnFile -Ns_ConnReturnHtml -Ns_Log -Ns_TclGetConn -Ns_ConnGetQuery -nssml_SetGet -nssml_SetIGet -Ns_SetPut -nssml_isNullString -Ns_SetFree -Ns_SetCreate -nssml_SetSize -Ns_SetUnique -Ns_ConnPuts -Ns_ConnFlushHeaders -Ns_ConnSetRequiredHeaders -nssml_PageRoot -Ns_ConnReturnRedirect -Ns_DbPoolGetHandle -Ns_DbPoolPutHandle -Ns_DbDML -Ns_DbExec -Ns_DbSelect -Ns_DbGetRow - -nssml_ConnHost -Ns_ConnHeaders -nssml_ConnLocation -nssml_ConnPeer -Ns_ConnPeerPort -Ns_ConnPort -Ns_ConnRedirect -nssml_ConnServer -nssml_SetKey -nssml_SetValue -nssml_InfoConfigFile -nssml_InfoErrorLog -nssml_InfoHomePath -nssml_InfoHostname -Ns_InfoPid -nssml_InfoServerVersion -Ns_InfoUptime -nssml_GetMimeType -nssml_GetHostByAddr -nssml_EncodeUrl -nssml_DecodeUrl - -nssml_configGetValue -nssml_configGetValueExact -nssml_ConnUrl -nssml_ConnMethod -nssml_ConnContentLength -nssml_ConnCopy -nssml_ConnCopyToFile -nssml_FetchUrl - -Ns_CacheFind -nssml_CacheCreate -nssml_CacheCreateSz -Ns_CacheFlush -nssml_CacheSet -nssml_CacheGet - -nssml_registerTrap -nssml_scheduleScript -nssml_scheduleDaily -nssml_scheduleWeekly - -nssml_returnFile diff --git a/src/Compiler/Backend/KAM/CODE_GEN_KAM.sml b/src/Compiler/Backend/KAM/CODE_GEN_KAM.sml deleted file mode 100644 index 2b85478a4..000000000 --- a/src/Compiler/Backend/KAM/CODE_GEN_KAM.sml +++ /dev/null @@ -1,11 +0,0 @@ -signature CODE_GEN_KAM = - sig - type label - type AsmPrg - type ClosPrg - - val CG : {main_lab_opt:label option, - code: ClosPrg, - imports:label list * label list, - exports:label list * label list} -> AsmPrg - end \ No newline at end of file diff --git a/src/Compiler/Backend/KAM/CodeGenKAM.sml b/src/Compiler/Backend/KAM/CodeGenKAM.sml deleted file mode 100644 index d91fba721..000000000 --- a/src/Compiler/Backend/KAM/CodeGenKAM.sml +++ /dev/null @@ -1,1079 +0,0 @@ -functor CodeGenKAM(structure CallConv: CALL_CONV - where type lvar = Lvars.lvar - structure ClosExp: CLOS_EXP - where type con = Con.con - where type excon = Excon.excon - where type lvar = Lvars.lvar - where type place = Effect.place - where type label = AddressLabels.label - where type phsize = PhysSizeInf.phsize - sharing type CallConv.cc = ClosExp.cc - structure BI : BACKEND_INFO - structure JumpTables : JUMP_TABLES - ) : CODE_GEN_KAM (* : sig end *) = - -struct - structure PP = PrettyPrint - structure Labels = AddressLabels - structure LvarFinMap = Lvars.Map - structure RegvarFinMap = EffVarEnv - structure BuiltInCFunctions = BuiltInCFunctionsKAM - structure Opcodes = OpcodesKAM - - open Kam - - type place = Effect.place - type excon = Excon.excon - type con = Con.con - type lvar = Lvars.lvar - datatype phsize = datatype PhysSizeInf.phsize - type pp = PhysSizeInf.pp - type cc = CallConv.cc - type label = Labels.label - type ClosPrg = ClosExp.ClosPrg - - (***********) - (* 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 ("CodeGenKAM." ^ s) - - 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="print_kam_program", short=NONE, item=ref false, neg=false, - menu=["Printing of intermediate forms", "print KAM program"], - desc="Print Kit Abstract Machine code."} - - - val _ = Flags.add_bool_entry - {long="comments_in_kam_code", short=NONE, item=ref false, neg=false, - menu=["Printing of intermediate forms", "comments in KAM code"], - desc=""} - - val comments_in_kam_code = Flags.lookup_flag_entry "comments_in_kam_code" - val jump_tables = true - - (*************) - (* Utilities *) - (*************) - fun zip ([],[]) = [] - | zip ((x::xs),(y::ys)) = (x,y) :: (zip (xs,ys)) - | zip _ = die "zip: Cannot zip two lists." - -(* - fun is_region_real place = - (case Effect.get_place_ty place - of NONE => die "LETREGION.alloc.regvar has no runtype." - | SOME Effect.REAL_RT => true - | SOME Effect.STRING_RT => false - | SOME _ => false) -*) - - (* Check to inforce that datalabels that are exported are indeed defined *) - - local - val export_labs : label list ref = ref nil - fun member l = - let fun mem nil = false - | mem (x::xs) = Labels.eq(l,x) orelse mem xs - in mem (!export_labs) - end - in - fun setExportLabs ls = export_labs := ls - fun storeData l = - if member l then StoreData l - else die ("Label " ^ Labels.pr_label l ^ " is not defined") - end - - (***************************) - (* Compiler Environment CE *) - (***************************) - structure LvarFinMap = Lvars.Map - datatype access_type = - REG_I of int - | REG_F of int - | STACK of int - | ENV of int - | ENV_REG - - type VarEnv = access_type LvarFinMap.map - type RhoEnv = access_type RegvarFinMap.map - type env = {VarEnv : VarEnv, - RhoEnv : RhoEnv} - - val initialVarEnv : VarEnv = LvarFinMap.empty - val initialRhoEnv : RhoEnv = RegvarFinMap.empty - val initialEnv = {VarEnv = initialVarEnv, - RhoEnv = initialRhoEnv} - - fun plus ({VarEnv,RhoEnv}, {VarEnv=VarEnv',RhoEnv=RhoEnv'}) = - {VarEnv = LvarFinMap.plus(VarEnv,VarEnv'), - RhoEnv = RegvarFinMap.plus(RhoEnv,RhoEnv')} - - fun declareLvar (lvar,access_type,{VarEnv,RhoEnv}) = - {VarEnv = LvarFinMap.add(lvar,access_type,VarEnv), - RhoEnv = RhoEnv} - - fun declareRho (place,access_type,{VarEnv,RhoEnv}) = - {VarEnv = VarEnv, - RhoEnv = RegvarFinMap.add(place,access_type,RhoEnv)} - - fun lookupVar ({VarEnv,...} : env) lvar = - case LvarFinMap.lookup VarEnv lvar of - SOME access_type => access_type - | NONE => die ("lookupVar(" ^ (Lvars.pr_lvar lvar) ^ ")") - - fun lookupVarOpt ({VarEnv,...} : env) lvar = LvarFinMap.lookup VarEnv lvar - - fun lookupRho ({RhoEnv,...} : env) place = - case RegvarFinMap.lookup RhoEnv place of - SOME access_type => access_type - | NONE => die ("lookupRho(" ^ (PP.flatten1(Effect.layout_effect place)) ^ ")") -(* - fun lookupRhoOpt ({RhoEnv,...} : env) place = RegvarFinMap.lookup RhoEnv place -*) - (* --------------------------------------------------------------------- *) - (* Pretty Printing *) - (* --------------------------------------------------------------------- *) - - type StringTree = PP.StringTree - val rec layoutEnv : env -> StringTree = fn {VarEnv,RhoEnv} => - PP.NODE{start="CodeGenKamEnv(",finish=")",indent=2, - children=[layoutVarEnv VarEnv,layoutRhoEnv RhoEnv], - childsep=PP.RIGHT ","} - - and layoutVarEnv = fn VarEnv => - PP.NODE{start="VarEnv = ",finish="",indent=2,childsep=PP.NOSEP, - children=[LvarFinMap.layoutMap {start="{", eq=" -> ", sep=", ", finish="}"} - (PP.layoutAtom Lvars.pr_lvar) - layout_access_type - VarEnv]} - - and layoutRhoEnv = fn RhoEnv => - PP.NODE{start="RhoEnv = ",finish="",indent=2,childsep=PP.NOSEP, - children=[RegvarFinMap.layoutMap {start="{",eq=" -> ", sep=", ", finish="}"} - (PP.layoutAtom (PP.flatten1 o Effect.layout_effect)) - layout_access_type - RhoEnv]} - - and layout_access_type = - fn REG_I i => PP.LEAF("REG_I(" ^ (Int.toString i) ^ ")") - | REG_F i => PP.LEAF("REG_F(" ^ (Int.toString i) ^ ")") - | STACK i => PP.LEAF("STACK(" ^ (Int.toString i) ^ ")") - | ENV i => PP.LEAF("ENV(" ^ (Int.toString i) ^ ")") - | ENV_REG => PP.LEAF("ENVREG") - - and pr_access_type = - fn acc_ty => PP.flatten1(layout_access_type acc_ty) - - - - (* 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 - - 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) - - - (* ---------------------------------------------------------------------------- - * Dead code elimination; during code generation we eliminate code that is non- - * reachable by eliminating code from the continuation---down to a label---when - * a jump, a return, or a raise is generated. - * ---------------------------------------------------------------------------- *) - - fun dead_code_elim C = - case C - of Label _ :: _ => C - | DotLabel _ :: _ => C - | (i as StoreData _) :: C => i :: dead_code_elim C (* necessary for linking; problem is - * Raise instruct *) - | (i as FetchData _) :: C => i :: dead_code_elim C (* necessary for linking; problem is - * Raise instruct *) - | _ :: rest => dead_code_elim rest - | nil => C - - (* ----------------------------------------------------------------- - * Peep hole optimization: we define functions here that takes the - * continuation as an extra parameter, which can be inspected and - * merged with the instruction proper. - * ----------------------------------------------------------------- *) - - fun pop (i, acc) = - if i > 0 then - case acc - of Pop n :: Push :: acc => PopPush(n+i) :: acc - | PopPush n :: acc => PopPush(n+i) :: acc - | Push :: acc => PopPush i :: acc - | Pop n :: acc => Pop(n+i) :: acc - | _ => Pop i :: acc - else if i < 0 then die "pop(i). i < 0" - else (*i=0*) acc - - fun push acc = - case acc - of Pop i :: acc => - if i > 0 then pop(i-1, acc) - else if i < 0 then die "push" - else Push :: acc - | ImmedInt 1 :: PrimSubi :: acc => PrimSubi1 :: acc - | ImmedInt 2 :: PrimSubi :: acc => PrimSubi2 :: acc - | ImmedInt 1 :: PrimAddi :: acc => PrimAddi1 :: acc - | ImmedInt 2 :: PrimAddi :: acc => PrimAddi2 :: acc - | _ => Push :: acc - - fun selectEnv(i, s, acc) = - case acc - of ClearAtbotBit :: Push :: acc => SelectEnvClearAtbotBitPush i :: acc - | Push :: acc => SelectEnvPush i :: acc - | _ => SelectEnv (i,s) :: acc - - fun select(i, acc) = - case acc - of Push :: acc => SelectPush i :: acc - | _ => Select i :: acc - - fun immedInt (i : Int32.int, acc) = - case acc - of Push :: acc => ImmedIntPush i :: acc - | _ => ImmedInt i :: acc - - fun immedWord (w : Word32.word, acc) = - let val i = Int32.fromLarge (Word32.toLargeIntX w) - in case acc - of Push :: acc => ImmedIntPush i :: acc - | _ => ImmedInt i :: acc - end - - fun immedIntMaybeTag (a, acc) = immedInt (maybeTagInt a, acc) - fun immedWordMaybeTag (a, acc) = immedWord (maybeTagWord a, acc) - - - fun stackOffset(i, acc) = - case acc - of StackOffset n :: acc => StackOffset(n+i)::acc - | _ => StackOffset i :: acc - - (***********************) - (* Code Generation *) - (***********************) - - local - fun selectStack(i, s, acc) = - case acc - of Push :: acc => SelectStackPush i :: acc - | _ => SelectStack(i,s) :: acc - - fun envToAcc acc = - case acc - of Push :: acc => EnvPush :: acc - | _ => EnvToAcc :: acc - - fun stackAddrInfBit (i, s, acc) = - case acc - of SetAtbotBit :: Push :: acc => StackAddrInfBitAtbotBitPush i :: acc - | _ => StackAddrInfBit (i, s) :: acc - - fun stackAddr (i, s, acc) = - case acc - of Push :: acc => StackAddrPush (i,s) :: acc - | _ => StackAddr (i, s) :: acc - - fun access_lv(lv,env,sp,acc) = - case lookupVar env lv of - STACK i => selectStack(0-sp+i, Lvars.pr_lvar lv, acc) - | ENV i => selectEnv(i, Lvars.pr_lvar lv, acc) - | REG_I i => stackAddrInfBit(0-sp+i, Lvars.pr_lvar lv, acc) - | REG_F i => stackAddr(0-sp+i, Lvars.pr_lvar lv, acc) - | ENV_REG => envToAcc acc - - fun access_rho(rho,env,sp,acc) = - case lookupRho env rho of - STACK i => selectStack(0-sp+i, ClosExp.pr_rhos [rho], acc) - | ENV i => selectEnv(i, ClosExp.pr_rhos [rho], acc) - | REG_I i => stackAddrInfBit(0-sp+i, ClosExp.pr_rhos [rho], acc) - | REG_F i => stackAddr(0-sp+i, ClosExp.pr_rhos [rho], acc) - | ENV_REG => envToAcc acc - - fun comment(str,C) = - if !comments_in_kam_code then Comment str :: C - else C - - fun comment_fn (f, C) = - if !comments_in_kam_code then Comment (f()) :: C - else C - - (* Compile Switch Statements *) - local - fun new_label str = Labels.new_named str - fun label(lab,C) = Label lab :: C - fun jmp(lab,C) = JmpRel lab :: dead_code_elim C - fun inline_cont C = - case C - of (i as JmpRel lab) :: _ => SOME (fn C => i :: C) - | (i as Return _) :: _ => SOME (fn C => i :: C) - | (i1 as Pop _) :: (i2 as Return _) :: _ => SOME (fn C => i1 :: i2 :: C) - | _ => NONE - in - fun linear_search(sels, - default, - if_no_match_go_lab_sel: label * 'sel * KamInst list -> KamInst list, - compile_insts: ClosExp.ClosExp * KamInst list -> KamInst list, - C) = - JumpTables.linear_search_new(sels, - default, - comment, - new_label, - if_no_match_go_lab_sel, - compile_insts, - label, - jmp, - inline_cont, - C) - - fun binary_search(sels, - default, - if_not_equal_go_lab_sel: label * Int32.int * KamInst list -> KamInst list, - if_less_than_go_lab_sel: label * Int32.int * KamInst list -> KamInst list, - if_greater_than_go_lab_sel: label * Int32.int * KamInst list -> KamInst list, - compile_insts: ClosExp.ClosExp * KamInst list -> KamInst list, - precision, - toInt, - C) = - let - fun maybe_tag (i : Int32.int) : Int32.int = - if precision < 32 then 2*i+1 - else i - val sels = map (fn (i,e) => (maybe_tag(toInt i), e)) sels - in - if jump_tables then - JumpTables.binary_search_new(sels, - default, - comment, - new_label, - if_not_equal_go_lab_sel, - if_less_than_go_lab_sel, - if_greater_than_go_lab_sel, - compile_insts, - label, - jmp, - fn (sel1,sel2) => Int32.abs(sel1-sel2), - fn (lab,sel,length,C) => JmpVector(lab,sel,length)::C, - fn (lab,C) => DotLabel(lab) :: C, (* add_label_to_jump_tab *) - eq_lab, - inline_cont, - C) - else - linear_search(sels, - default, - if_not_equal_go_lab_sel, - compile_insts, - C) - end - end - - fun toCString acc = PrimAddi2 :: PrimAddi2 :: acc - fun untagBool acc = Primi31Toi :: acc - fun tagBool acc = PrimiToi31 :: acc - fun cconvert_arg ft acc = - case ft - of ClosExp.CharArray => toCString acc - | ClosExp.Bool => untagBool acc - | ClosExp.Int => acc - | ClosExp.ForeignPtr => acc - | ClosExp.Unit => acc - - fun cconvert_res ft acc = - case ft - of ClosExp.CharArray => die "cconvert_res.CharArray not allowed in C result" - | ClosExp.Bool => tagBool acc - | ClosExp.Int => acc - | ClosExp.ForeignPtr => acc - | ClosExp.Unit => acc - - fun name_to_built_in_C_function_index name = - if !Flags.SMLserver - then BuiltInCFunctions.name_to_built_in_C_function_index_apsml name - else BuiltInCFunctions.name_to_built_in_C_function_index name - - fun CG_ce(ClosExp.VAR lv,env,sp,cc,acc) = access_lv(lv,env,sp,acc) - | CG_ce(ClosExp.RVAR place,env,sp,cc,acc) = access_rho(place,env,sp,acc) - | CG_ce(ClosExp.DROPPED_RVAR place,env,sp,cc,acc) = acc (* die "DROPPED_RVAR not implemented" *) - | CG_ce(ClosExp.FETCH lab,env,sp,cc,acc) = FetchData lab :: acc - | CG_ce(ClosExp.STORE(ce,lab),env,sp,cc,acc) = CG_ce(ce,env,sp,cc, storeData lab :: acc) - | CG_ce(ClosExp.INTEGER i,env,sp,cc,acc) = immedIntMaybeTag (i, acc) - | CG_ce(ClosExp.WORD w,env,sp,cc,acc) = immedWordMaybeTag (w, acc) - | CG_ce(ClosExp.STRING s,env,sp,cc,acc) = ImmedString s :: acc - | CG_ce(ClosExp.REAL s,env,sp,cc,acc) = ImmedReal s :: acc - | CG_ce(ClosExp.PASS_PTR_TO_MEM(sma,i),env,sp,cc,acc) = alloc(sma,i,env,sp,cc,acc) - | CG_ce(ClosExp.PASS_PTR_TO_RHO sma,env,sp,cc,acc) = set_sm(sma,env,sp,cc,acc) - | CG_ce(ClosExp.UB_RECORD ces,env,sp,cc,acc) = comp_ces(ces,env,sp,cc,acc) - (* Layout of closure [label,rho1,...,rhon,excon1,...exconm,lv1,...,lvo], see build_clos_env in ClosExp *) - | CG_ce(ClosExp.CLOS_RECORD{label,elems=(lvs,excons,rhos),alloc},env,sp,cc,acc) = - PushLbl(label) :: (comp_ces_to_block(rhos @ excons @ lvs,1,env,sp+1,cc,alloc,acc)) - (* Layout of closure [rho1,...,rhon,excon1,...exconm,lv1,...,lvo], see build_clos_env in ClosExp *) - | CG_ce(ClosExp.SCLOS_RECORD{elems=(lvs,excons,rhos),alloc},env,sp,cc,acc) = - comp_ces_to_block(rhos @ excons @ lvs,0,env,sp,cc,alloc,acc) - | CG_ce(ClosExp.REGVEC_RECORD{elems,alloc},env,sp,cc,acc) = die "REGVEC_RECORD not used in this back end" - | CG_ce(ClosExp.RECORD{elems,alloc,tag,maybeuntag},env,sp,cc,acc) = comp_ces_to_block(elems,0,env,sp,cc,alloc,acc) - | CG_ce(ClosExp.SELECT(i,ce as ClosExp.VAR lv),env,sp,cc,acc) = - (* This may be a SelectEnv? *) - if Lvars.eq(lv,Lvars.env_lvar) then - selectEnv(i, Lvars.pr_lvar lv,acc) - else - CG_ce(ce,env,sp,cc, select(i,acc)) - | CG_ce(ClosExp.SELECT(i,ce),env,sp,cc,acc) = CG_ce(ce,env,sp,cc, select(i,acc)) - | CG_ce(ClosExp.FNJMP{opr,args,clos=NONE},env,sp,cc,acc) = - CG_ce(opr,env,sp,cc, - push (comp_ces(args,env,sp+1,cc, - ApplyFnJmp(List.length args, sp) :: - dead_code_elim acc))) - | CG_ce(ClosExp.FNJMP{opr,args,clos},env,sp,cc,acc) = die "FNJMP: clos is non-empty." - | CG_ce(ClosExp.FNCALL{opr,args,clos=NONE},env,sp,cc,acc) = - let - val return_lbl = Labels.new_named "return_from_app" - in - PushLbl(return_lbl) :: - CG_ce(opr,env,sp+1,cc, - push (comp_ces(args,env,sp+2,cc, - ApplyFnCall(List.length args) :: Label(return_lbl) :: acc))) - end - | CG_ce(ClosExp.FNCALL{opr,args,clos},env,sp,cc,acc) = - die "FNCALL: clos is non-empty." -(* - | CG_ce(ClosExp.JMP{opr,args,reg_vec=NONE,reg_args,clos=NONE},env,sp,cc,acc) = - ImmedIntPush "0" :: (* is it always all the region arguments that are reused? *) - comp_ces(args,env,sp+1,cc, - ApplyFunJmp(opr,List.length args,sp - (List.length reg_args)) :: - dead_code_elim acc) - | CG_ce(ClosExp.JMP{opr,args,reg_vec=NONE,reg_args,clos=SOME clos_ce},env,sp,cc,acc) = - CG_ce(clos_ce,env,sp,cc, - push (comp_ces(args,env,sp+1,cc, - ApplyFunJmp(opr,List.length args,sp - (List.length reg_args)) :: - dead_code_elim acc))) -*) -(* | CG_ce(ClosExp.JMP a,env,sp,cc,acc) = CG_ce(ClosExp.FUNCALL a,env,sp,cc,acc)*) - - | CG_ce(ClosExp.JMP{opr,args,reg_vec=NONE,reg_args,clos},env,sp,cc,acc) = - let - val allargs = reg_args @ args - fun push_clos NONE C = ImmedIntPush 0 :: C - | push_clos (SOME clos_ce) C = CG_ce(clos_ce,env,sp,cc, push C) - in push_clos clos (comp_ces(allargs, env, sp+1, cc, - ApplyFunJmp(opr, List.length allargs, sp) :: - dead_code_elim acc)) - end - | CG_ce(ClosExp.JMP{opr,args,reg_vec,reg_args,clos},env,sp,cc,acc) = die "JMP reg_vec is non-empty." - | CG_ce(ClosExp.FUNCALL{opr,args,reg_vec=NONE,reg_args,clos},env,sp,cc,acc) = - let - val allargs = reg_args @ args - val return_lbl = Labels.new_named "return_from_app" - fun push_clos NONE C = ImmedIntPush 0 :: C - | push_clos (SOME clos_ce) C = CG_ce(clos_ce,env,sp+1,cc, push C) - in - PushLbl(return_lbl) :: - push_clos clos (comp_ces(allargs,env,sp+2,cc, - ApplyFunCall(opr,List.length allargs) :: - Label(return_lbl) :: acc)) - end -(* - | CG_ce(ClosExp.FUNCALL{opr,args,reg_vec=NONE,reg_args,clos=SOME clos_ce},env,sp,cc,acc) = - let - val return_lbl = Labels.new_named "return_from_app" - in - PushLbl(return_lbl) :: - CG_ce(clos_ce,env,sp+1,cc, - push (comp_ces(reg_args @ args,env,sp+2,cc, - ApplyFunCall(opr,List.length args + List.length reg_args) :: - Label(return_lbl) :: acc))) - end -*) - | CG_ce(ClosExp.FUNCALL{opr,args,reg_vec,reg_args,clos},env,sp,cc,acc) = die "FUNCALL: reg_vec is non-empty." - | CG_ce(ClosExp.LETREGION{rhos,body},env,sp,cc,acc) = - let - fun comp_alloc_rhos([],env,sp,cc,fn_acc) = fn_acc(env,sp) - | comp_alloc_rhos((place,PhysSizeInf.INF)::rs,env,sp,cc,fn_acc) = - LetregionInf :: - comp_alloc_rhos(rs,declareRho(place,REG_I(sp),env),sp+(BI.size_of_reg_desc()),cc,fn_acc) - | comp_alloc_rhos((place,PhysSizeInf.WORDS 0)::rs,env,sp,cc,fn_acc) = - (* it seems that finite rhos of size 0 actually exists in env? 2000-10-08, Niels - * and code is actually generated when passing arguments in region polymorphic functions??? *) - comp_alloc_rhos(rs,declareRho(place,REG_F(sp),env),sp,cc,fn_acc) - | comp_alloc_rhos((place,PhysSizeInf.WORDS i)::rs,env,sp,cc,fn_acc) = - stackOffset(i, - comp_alloc_rhos(rs,declareRho(place,REG_F(sp),env),sp+i,cc,fn_acc)) - - fun comp_dealloc_rho((place,PhysSizeInf.INF), acc) = EndregionInf :: acc - | comp_dealloc_rho((place,PhysSizeInf.WORDS 0), acc) = acc - | comp_dealloc_rho((place,PhysSizeInf.WORDS i), acc) = pop(i, acc) - in - comment_fn (fn () => "Letregion <" ^ (ClosExp.pr_rhos (List.map #1 rhos)) ^ ">", - comp_alloc_rhos(rhos,env,sp,cc, - fn (env,sp) => CG_ce(body,env,sp,cc, - (List.foldl (fn (rho,acc) => - comp_dealloc_rho (rho,acc)) acc rhos)))) - end - | CG_ce(ClosExp.LET{pat=[],bind,scope},env,sp,cc,acc) = - comment ("Let _", - CG_ce(bind,env,sp,cc, - push (CG_ce(scope,env,sp+1,cc, pop(1,acc))))) - - | CG_ce(ClosExp.LET{pat,bind,scope},env,sp,cc,acc) = - let - val n = List.length pat - fun declareLvars([],sp,env) = env - | declareLvars(lv::lvs,sp,env) = declareLvars(lvs,sp+1,declareLvar(lv,STACK(sp),env)) - in - comment_fn (fn () => "Let <" ^ (ClosExp.pr_lvars pat) ^ ">", - CG_ce(bind,env,sp,cc, - push (CG_ce(scope,declareLvars(pat,sp,env),sp+n,cc, pop(n, acc))))) - end - - | CG_ce(ClosExp.RAISE ce,env,sp,cc,acc) = CG_ce(ce,env,sp,cc,Raise :: dead_code_elim acc) - - | CG_ce(ClosExp.HANDLE(ce1,ce2),env,sp,cc,acc) = - (* An exception handler on the stack contains the following fields: *) - (* sp[offset+2] = pointer to previous exception handler used when updating exnPtr. *) - (* sp[offset+1] = pointer to handle closure. *) - (* sp[offset] = label for handl_return code. *) - (* Note that we call deallocate_regions_until to the address above the exception handler, *) - (* when an exception is raised. *) - (* We must store the environment for the surrounding function in the handle to be restored when *) - (* returning from the handle function. Just some thoughts. 2000-12-10, Niels *) -(* original, 22.18 2000-12-10, Niels let - val return_lbl = Labels.new_named "return_handle" - in - CG_ce(ce2,env,sp,cc, PushLbl return_lbl :: Push :: PushExnPtr :: - CG_ce(ce1,env,sp+3,cc, PopExnPtr :: Pop(2) :: Label return_lbl :: acc)) - end*) - - let - val return_lbl = Labels.new_named "return_handle" - in - CG_ce(ce2,env,sp,cc, PushLbl return_lbl :: EnvPush :: Push :: PushExnPtr :: - CG_ce(ce1,env,sp+4,cc, PopExnPtr :: Pop(3) :: Label return_lbl :: acc)) - end - - | CG_ce(ClosExp.SWITCH_I {switch=ClosExp.SWITCH(ce,sels,default), - precision},env,sp,cc,acc) = - CG_ce(ce,env,sp,cc, - binary_search(sels, - default, - fn (lab,i,C) => IfNotEqJmpRelImmed (lab,i) :: C, - fn (lab,i,C) => IfLessThanJmpRelImmed (lab,i) :: C, - fn (lab,i,C) => IfGreaterThanJmpRelImmed (lab,i) :: C, - fn (ce,C) => CG_ce(ce,env,sp,cc,C), - precision, - fn i => i, - acc)) - | CG_ce(ClosExp.SWITCH_W {switch=ClosExp.SWITCH(ce,sels,default), - precision},env,sp,cc,acc) = - CG_ce(ce,env,sp,cc, - binary_search(sels, - default, - fn (lab,i,C) => IfNotEqJmpRelImmed (lab,i) :: C, - fn (lab,i,C) => IfLessThanJmpRelImmed (lab,i) :: C, - fn (lab,i,C) => IfGreaterThanJmpRelImmed (lab,i) :: C, - fn (ce,C) => CG_ce(ce,env,sp,cc,C), - precision, - Int32.fromLarge o Word32.toLargeIntX, - acc)) - | CG_ce(ClosExp.SWITCH_S sw,env,sp,cc,acc) = die "SWITCH_S is unfolded in ClosExp" - | CG_ce(ClosExp.SWITCH_C (ClosExp.SWITCH(ce,sels,default)),env,sp,cc,acc) = - let (* NOTE: selectors in sels are tagged in ClosExp but the operand is tagged here! *) - val con_kind = - (case sels of - [] => ClosExp.ENUM 1 (*necessary to compile non-optimized programs (OptLambda off) *) - | ((con,con_kind),_)::rest => con_kind) - val sels' = map (fn ((con,con_kind),sel_ce) => - case con_kind of - ClosExp.ENUM i => (Int32.fromInt i,sel_ce) - | ClosExp.UNBOXED i => (Int32.fromInt i,sel_ce) - | ClosExp.BOXED i => (Int32.fromInt i,sel_ce)) sels - in - CG_ce(ce,env,sp,cc, - (case con_kind of - ClosExp.ENUM _ => (fn C => C) - | ClosExp.UNBOXED _ => (fn C => UbTagCon :: C) - | ClosExp.BOXED _ => fn C => select(0,C)) - (binary_search(sels', - default, - fn (lab,i,C) => IfNotEqJmpRelImmed(lab,i) :: C, - fn (lab,i,C) => IfLessThanJmpRelImmed(lab,i) :: C, - fn (lab,i,C) => IfGreaterThanJmpRelImmed(lab,i) :: C, - fn (ce,C) => CG_ce(ce,env,sp,cc,C), - BI.defaultIntPrecision(), - fn i => i, - acc))) - end - | CG_ce(ClosExp.SWITCH_E sw,env,sp,cc,acc) = die "SWITCH_E is unfolded in ClosExp" - | CG_ce(ClosExp.CON0{con,con_kind,aux_regions,alloc},env,sp,cc,acc) = - let - fun reset_regions C = - foldr (fn (alloc,C) => maybe_reset_aux_region(alloc,env,sp,cc,C)) C aux_regions - in - case con_kind of - ClosExp.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 - in - immedInt (Int32.fromInt tag, acc) - end - | ClosExp.UNBOXED i => - let val tag = 4*i+3 - in reset_regions(immedInt (Int32.fromInt tag, acc)) - end - | ClosExp.BOXED i => - let val tag = Word32.toInt(BI.tag_con0(false,i)) - in reset_regions(ImmedIntPush (Int32.fromInt tag) :: alloc_block(alloc,1,env,sp+1,cc,acc)) - end - end - | CG_ce(ClosExp.CON1{con,con_kind,alloc,arg},env,sp,cc,acc) = - (case con_kind of - ClosExp.UNBOXED 0 => CG_ce(arg,env,sp,cc,acc) - | ClosExp.UNBOXED i => - (case i of - 1 => CG_ce(arg,env,sp,cc,SetBit31 :: acc) - | 2 => CG_ce(arg,env,sp,cc,SetBit30 :: acc) - | _ => die "CG_ce: UNBOXED CON1 with i > 2") - | ClosExp.BOXED i => - let - val tag = Word32.toInt(BI.tag_con1(false,i)) - in - ImmedIntPush (Int32.fromInt tag) :: - CG_ce(arg,env,sp+1,cc, (*mael fix: sp -> sp+1 *) - push (alloc_block(alloc,2,env,sp+2,cc,acc))) - end - | _ => die "CG_ce: CON1.con not unary in env.") - | CG_ce(ClosExp.DECON{con,con_kind,con_exp},env,sp,cc,acc) = - (case con_kind of - ClosExp.UNBOXED 0 => CG_ce(con_exp,env,sp,cc,acc) - | ClosExp.UNBOXED _ => CG_ce(con_exp,env,sp,cc,ClearBit30And31 :: acc) - | ClosExp.BOXED _ => CG_ce(con_exp,env,sp,cc, select(1,acc)) - | _ => die "CG_ce: DECON used with con_kind ENUM") - | CG_ce(ClosExp.DEREF ce,env,sp,cc,acc) = CG_ce(ce,env,sp,cc, select(0,acc)) - | CG_ce(ClosExp.REF(sma,ce),env,sp,cc,acc) = - CG_ce(ce,env,sp,cc, - push (alloc_block(sma,1,env,sp+1,cc,acc))) - | CG_ce(ClosExp.ASSIGN(sma,ce1,ce2),env,sp,cc,acc) = - CG_ce(ce1,env,sp,cc, - push (CG_ce(ce2,env,sp+1,cc,Store(0) :: acc))) - | CG_ce(ClosExp.DROP ce,env,sp,cc,acc) = CG_ce(ce,env,sp,cc,acc) (* dropping type *) - | CG_ce(ClosExp.RESET_REGIONS{force=false,regions_for_resetting},env,sp,cc,acc) = - foldr (fn (alloc,C) => maybe_reset_aux_region(alloc,env,sp,cc,C)) acc regions_for_resetting - | CG_ce(ClosExp.RESET_REGIONS{force=true,regions_for_resetting},env,sp,cc,acc) = - foldr (fn (alloc,C) => force_reset_aux_region(alloc,env,sp,cc,C)) acc regions_for_resetting - | CG_ce(ClosExp.CCALL{name,rhos_for_result,args},env,sp,cc,acc) = - let - fun not_impl n = die ("Prim(" ^ n ^ ") is not yet implemented!") - - (* Note that the prim names are defined in BackendInfo! *) - fun prim_name_to_KAM name = - case name - of "__equal_int32ub" => PrimEquali - | "__equal_int32b" => not_impl name - | "__equal_int31" => PrimEquali - | "__equal_word31" => PrimEquali - | "__equal_word32ub" => PrimEquali - | "__equal_word32b" => not_impl name - - | "__plus_int32ub" => PrimAddi - | "__plus_int32b" => not_impl name - | "__plus_int31" => PrimAddi31 - | "__plus_word31" => PrimAddw31 - | "__plus_word32ub" => PrimAddw - | "__plus_word32b" => not_impl name - | "__plus_real" => PrimAddf - - | "__minus_int32ub" => PrimSubi - | "__minus_int32b" => not_impl name - | "__minus_int31" => PrimSubi31 - | "__minus_word31" => PrimSubw31 - | "__minus_word32ub" => PrimSubw - | "__minus_word32b" => not_impl name - | "__minus_real" => PrimSubf - - | "__mul_int32ub" => PrimMuli - | "__mul_int32b" => not_impl name - | "__mul_int31" => PrimMuli31 - | "__mul_word31" => PrimMulw31 - | "__mul_word32ub" => PrimMulw - | "__mul_word32b" => not_impl name - | "__mul_real" => PrimMulf - - | "__div_real" => PrimDivf - - | "__neg_int32ub" => PrimNegi - | "__neg_int32b" => not_impl name - | "__neg_int31" => PrimNegi31 - | "__neg_real" => PrimNegf - - | "__abs_int32ub" => PrimAbsi - | "__abs_int32b" => not_impl name - | "__abs_int31" => PrimAbsi31 - | "__abs_real" => PrimAbsf - - | "__less_int32ub" => PrimLessThan - | "__less_int32b" => not_impl name - | "__less_int31" => PrimLessThan - | "__less_word31" => PrimLessThanUnsigned - | "__less_word32ub" => PrimLessThanUnsigned - | "__less_word32b" => not_impl name - | "__less_real" => PrimLessThanFloat - - | "__lesseq_int32ub" => PrimLessEqual - | "__lesseq_int32b" => not_impl name - | "__lesseq_int31" => PrimLessEqual - | "__lesseq_word31" => PrimLessEqualUnsigned - | "__lesseq_word32ub" => PrimLessEqualUnsigned - | "__lesseq_word32b" => not_impl name - | "__lesseq_real" => PrimLessEqualFloat - - | "__greater_int32ub" => PrimGreaterThan - | "__greater_int32b" => not_impl name - | "__greater_int31" => PrimGreaterThan - | "__greater_word31" => PrimGreaterThanUnsigned - | "__greater_word32ub" => PrimGreaterThanUnsigned - | "__greater_word32b" => not_impl name - | "__greater_real" => PrimGreaterThanFloat - - | "__greatereq_int32ub" => PrimGreaterEqual - | "__greatereq_int32b" => not_impl name - | "__greatereq_int31" => PrimGreaterEqual - | "__greatereq_word31" => PrimGreaterEqualUnsigned - | "__greatereq_word32ub" => PrimGreaterEqualUnsigned - | "__greatereq_word32b" => not_impl name - | "__greatereq_real" => PrimGreaterEqualFloat - - | "__andb_word31" => PrimAndw - | "__andb_word32ub" => PrimAndw - | "__andb_word32b" => not_impl name - - | "__orb_word31" => PrimOrw - | "__orb_word32ub" => PrimOrw - | "__orb_word32b" => not_impl name - - | "__xorb_word31" => PrimXorw31 - | "__xorb_word32ub" => PrimXorw - | "__xorb_word32b" => not_impl name - - | "__shift_left_word31" => PrimShiftLeftw31 - | "__shift_left_word32ub" => PrimShiftLeftw - | "__shift_left_word32b" => not_impl name - - | "__shift_right_signed_word31" => PrimShiftRightSignedw31 - | "__shift_right_signed_word32ub" => PrimShiftRightSignedw - | "__shift_right_signed_word32b" => not_impl name - - | "__shift_right_unsigned_word31" => PrimShiftRightUnsignedw31 - | "__shift_right_unsigned_word32ub" => PrimShiftRightUnsignedw - | "__shift_right_unsigned_word32b" => not_impl name - - | "__int31_to_int32b" => not_impl name - | "__int31_to_int32ub" => Primi31Toi - | "__int32b_to_int31" => not_impl name - | "__int32ub_to_int31" => PrimiToi31 - - | "__word31_to_word32b" => not_impl name - | "__word31_to_word32ub" => Primw31Tow - | "__word32b_to_word31" => not_impl name - | "__word32ub_to_word31" => PrimwTow31 - - | "__word31_to_word32ub_X" => Primw31TowX - | "__word31_to_word32b_X" => not_impl name - - | "__word32b_to_int32b" => not_impl name - | "__word32b_to_int32b_X" => not_impl name - | "__int32b_to_word32b" => not_impl name - | "__word32ub_to_int32ub" => PrimwToi - | "__word32b_to_int31" => not_impl name - | "__int32b_to_word31" => not_impl name - | "__word32b_to_int31_X" => not_impl name - - | "__fresh_exname" => PrimFreshExname - - | "__bytetable_sub" => PrimByteTableSub - | "__bytetable_update" => PrimByteTableUpdate - | "__bytetable_size" => PrimTableSize - - | "word_sub0" => PrimWordTableSub - | "word_update0" => PrimWordTableUpdate - | "table_size" => PrimTableSize - - | "__is_null" => PrimIsNull - - | "terminateML" => Halt - - | "__serverGetCtx" => GetContext - - | _ => die ("PRIM(" ^ name ^ ") not implemented") - in - if BI.is_prim name orelse name = "terminateML" then - (* rhos_for_result comes after args so that the accumulator holds the *) - (* pointer to allocated memory. *) - comp_ces(args @ rhos_for_result,env,sp,cc, - prim_name_to_KAM name :: acc) - else - let - (* rhos_for_result comes before args, because that is what the C *) - (* functions expects. *) - datatype StaDyn = Dyn | Sta - val (i,k) = case name of ":" => (0,Dyn) - | _ => (name_to_built_in_C_function_index name,Sta) - val all_args = case k - of Dyn => (let val (a1,ar) = Option.valOf (List.getItem args) - in rhos_for_result @ ar @ [a1] - end handle Option.Option => - die ("You must give the function to call as the first"^ - "arguemnt to :")) - | Sta => rhos_for_result @ args - in - if i >= 0 then - comp_ces(all_args,env,sp,cc, - (case name - of ":" => DCcall(1, (List.length all_args)-1) - | _ => Ccall(i, List.length all_args)) :: acc) - else die ("Couldn't generate code for a C-call to " ^ name ^ - "; you probably need to insert the function name in the " ^ - "file BuiltInCFunctions.spec or BuiltInCFunctionsNsSml.spec") - end - end - | CG_ce(ClosExp.CCALL_AUTO{name,args,res}, env,sp,cc,acc) = - let - datatype StaDyn = Dyn | Sta - val (i,k) = case name of ":" => (0,Dyn) - | _ => (name_to_built_in_C_function_index name,Sta) - val args = - case k - of Dyn => - let val (a1,ar) = Option.valOf (List.getItem args) handle Option.Option => - die ("You must give the function to call as the first"^ - "arguemnt to :") - in ar @ [a1] - end - | Sta => args - in - if i >= 0 then - (comp_ces_ccall_auto(args,env,sp,cc, - (case k of Sta => Ccall(i,List.length args) - | Dyn => DCcall(2, List.length args - 1)) :: - cconvert_res res acc)) - else die ("Couldn't generate code for a C-autocall to " ^ name ^ - "; you probably need to insert the function name in the " ^ - "file BuiltInCFunctions.spec or BuiltInCFunctionsNsSml.spec") - end - | CG_ce(ClosExp.EXPORT {name, clos_lab, arg = (aty, ft1, ft2)},env,sp,cc,acc) = - let - val _ = chat "_export not supported, ignoring..." - in - acc - end - | CG_ce(ClosExp.FRAME{declared_lvars,declared_excons},env,sp,cc,acc) = - comment ("FRAME - this is a nop", acc) - - and force_reset_aux_region(sma,env,sp,cc,acc) = - let - fun comp_ce(ce,acc) = CG_ce(ce,env,sp,cc,acc) - in - case sma - of ClosExp.ATBOT_LI(ce,pp) => comp_ce(ce, ResetRegion :: acc) - | ClosExp.SAT_FI(ce,pp) => comp_ce(ce, ResetRegion :: acc) - | ClosExp.SAT_FF(ce,pp) => comp_ce(ce, ResetRegionIfInf :: acc) - | _ => acc - end - - and maybe_reset_aux_region(sma,env,sp,cc,acc) = - let - fun comp_ce(ce,acc) = CG_ce(ce,env,sp,cc,acc) - in - case sma - of ClosExp.ATBOT_LI(ce,pp) => comp_ce(ce, ResetRegion :: acc) - | ClosExp.SAT_FI(ce,pp) => comp_ce(ce, MaybeResetRegion :: acc) - | ClosExp.SAT_FF(ce,pp) => comp_ce(ce, MaybeResetRegion :: acc) - | _ => acc - end - - and set_sm(sma,env,sp,cc,acc) = - let - fun comp_ce(ce,acc) = CG_ce(ce,env,sp,cc,acc) - in - case sma of - ClosExp.ATTOP_LI(ce,pp) => comp_ce(ce,acc) - | ClosExp.ATTOP_LF(ce,pp) => comp_ce(ce,acc) - | ClosExp.ATTOP_FF(ce,pp) => comp_ce(ce,ClearAtbotBit :: acc) - | ClosExp.ATTOP_FI(ce,pp) => comp_ce(ce,ClearAtbotBit :: acc) - | ClosExp.SAT_FI(ce,pp) => comp_ce(ce,acc) - | ClosExp.SAT_FF(ce,pp) => comp_ce(ce,acc) - | ClosExp.ATBOT_LI(ce,pp) => comp_ce(ce,SetAtbotBit :: acc) - | ClosExp.ATBOT_LF(ce,pp) => comp_ce(ce,acc) - | ClosExp.IGNORE => die "CodeGenKAM.set_sm: sma = Ignore" - end - - and alloc_block(sma,n,env,sp,cc,acc) = - let - fun comp_ce(ce,acc) = CG_ce(ce,env,sp,cc,acc) - in - case sma of - ClosExp.ATTOP_LI(ce,pp) => comp_ce(ce,BlockAlloc(n) :: acc) - | ClosExp.ATTOP_LF(ce,pp) => comp_ce(ce,Block(n) :: acc) - | ClosExp.ATTOP_FF(ce,pp) => comp_ce(ce,BlockAllocIfInf(n) :: acc) - | ClosExp.ATTOP_FI(ce,pp) => comp_ce(ce,BlockAlloc(n) :: acc) - | ClosExp.SAT_FI(ce,pp) => comp_ce(ce,BlockAllocSatInf(n) :: acc) - | ClosExp.SAT_FF(ce,pp) => comp_ce(ce,BlockAllocSatIfInf(n) :: acc) - | ClosExp.ATBOT_LI(ce,pp) => comp_ce(ce,BlockAllocAtbot(n) :: acc) - | ClosExp.ATBOT_LF(ce,pp) => comp_ce(ce,Block(n) :: acc) - | ClosExp.IGNORE => acc (*die "CodeGenKAM.alloc_block: sma = Ignore" 05/10-2000, Niels *) - end - - and alloc(sma,n,env,sp,cc,acc) = - let - fun comp_ce(ce,acc) = CG_ce(ce,env,sp,cc,acc) - in - case sma of - ClosExp.ATTOP_LI(ce,pp) => comp_ce(ce,Alloc(n) :: acc) - | ClosExp.ATTOP_LF(ce,pp) => comp_ce(ce,acc) - | ClosExp.ATTOP_FF(ce,pp) => comp_ce(ce,AllocIfInf(n) :: acc) - | ClosExp.ATTOP_FI(ce,pp) => comp_ce(ce,Alloc(n) :: acc) - | ClosExp.SAT_FI(ce,pp) => comp_ce(ce,AllocSatInf(n) :: acc) - | ClosExp.SAT_FF(ce,pp) => comp_ce(ce,AllocSatIfInf(n) :: acc) - | ClosExp.ATBOT_LI(ce,pp) => comp_ce(ce,AllocAtbot(n) :: acc) - | ClosExp.ATBOT_LF(ce,pp) => comp_ce(ce,acc) - | ClosExp.IGNORE => die "CodeGenKAM.alloc: sma = Ignore" - end - - and comp_ces_to_block ([],n,env,sp,cc,alloc,acc) = alloc_block(alloc,n,env,sp,cc,acc) - | comp_ces_to_block (ce::ces,n,env,sp,cc,alloc,acc) = - CG_ce(ce,env,sp,cc, push (comp_ces_to_block(ces,n+1,env,sp+1,cc,alloc,acc))) - - and comp_ces ([],env,sp,cc,acc) = acc - | comp_ces ([ce],env,sp,cc,acc) = CG_ce(ce,env,sp,cc,acc) - | comp_ces (ce::ces,env,sp,cc,acc) = - CG_ce(ce,env,sp,cc, push (comp_ces(ces,env,sp+1,cc,acc))) - - and comp_ces_ccall_auto ([],env,sp,cc,acc) = acc - | comp_ces_ccall_auto ([(ce,ft)],env,sp,cc,acc) = CG_ce(ce,env,sp,cc, cconvert_arg ft acc) - | comp_ces_ccall_auto ((ce,ft)::ces,env,sp,cc,acc) = - CG_ce(ce,env,sp,cc, - cconvert_arg ft (push (comp_ces_ccall_auto(ces,env,sp+1,cc,acc)))) - - local - fun mk_fun f_fun (lab,cc,ce) = - (* Region arguments start at offset 0 *) - (* cc.res contains one pseudo lvar for each value returned, see LiftTrip in ClosExp *) - (* I don't know what a ``pseudo lvar'' is?? ME 2000-11-04 *) - let - val decomp_cc = CallConv.decompose_cc cc - fun add_lvar (lv,(offset,env)) = (offset+1,declareLvar(lv,STACK(offset),env)) - fun add_clos_opt (NONE,env) = env - | add_clos_opt (SOME clos_lv, env) = declareLvar(clos_lv,ENV_REG,env) -(* - val _ = print "Regvars formals:\n" - val _ = app (fn lv => print (Lvars.pr_lvar lv ^ ", ")) (#reg_args(decomp_cc)) - val _ = print "\n" -*) - val (offset,env) = List.foldl add_lvar (0,initialEnv) (#reg_args(decomp_cc)) - val (offset,env) = List.foldl add_lvar (offset,env) (#args(decomp_cc)) - val env = add_clos_opt(#clos(decomp_cc),env) - - val returns = Int.max(1, List.length (#res(decomp_cc))) (* the Return instruction assumes - * that there is at least one result - * to return *) - in - f_fun(lab,CG_ce(ce,env,offset,cc,[Return(offset,returns)])) - end - in - fun CG_top_decl(ClosExp.FUN(lab,cc,ce)) = mk_fun FUN (lab,cc,ce) - | CG_top_decl(ClosExp.FN(lab,cc,ce)) = mk_fun FN (lab,cc,ce) - end - in - fun CG_clos_prg funcs = - List.foldr (fn (func,acc) => CG_top_decl func :: acc) [] funcs - end - - fun pp_labels s ls = - let fun loop nil = () - | loop (l::ls) = (print (Labels.pr_label l); print ","; loop ls) - in print (s ^ " = ["); loop ls; print "]\n" - end - - (******************************) - (* Code Generation -- KAM *) - (******************************) - fun CG {main_lab_opt:label option, - code=clos_prg:ClosPrg, - imports=(imports_code:label list, imports_data:label list), - exports=(exports_code:label list, exports_data:label list)} = - let - val _ = chat "[CodeGeneration for the KAM..." - - val exports_code = case main_lab_opt - of SOME l => l :: exports_code - | NONE => exports_code -(*mael - val _ = pp_labels "data labels" exports_data - val _ = pp_labels "code labels" exports_code -*) - val _ = setExportLabs exports_data - val asm_prg = {top_decls=CG_clos_prg clos_prg, - main_lab_opt=main_lab_opt, - imports_code=imports_code, - imports_data=imports_data, - exports_code=exports_code, - exports_data=exports_data} - val _ = - if Flags.is_on "print_kam_program" then - display("\nReport: AFTER CodeGeneration for the KAM:", - layout_AsmPrg asm_prg) - else - () - val _ = chat "]\n" - in - asm_prg - end -end diff --git a/src/Compiler/Backend/KAM/EMIT_CODE.sml b/src/Compiler/Backend/KAM/EMIT_CODE.sml deleted file mode 100644 index 87b499880..000000000 --- a/src/Compiler/Backend/KAM/EMIT_CODE.sml +++ /dev/null @@ -1,6 +0,0 @@ -signature EMIT_CODE = - sig - type target - - val emit : {target:target, filename:string} -> unit - end \ No newline at end of file diff --git a/src/Compiler/Backend/KAM/EmitCode.sml b/src/Compiler/Backend/KAM/EmitCode.sml deleted file mode 100644 index c9450d695..000000000 --- a/src/Compiler/Backend/KAM/EmitCode.sml +++ /dev/null @@ -1,323 +0,0 @@ -functor EmitCode (structure CG : CODE_GEN_KAM - where type AsmPrg = Kam.AsmPrg - structure BI : BACKEND_INFO) : EMIT_CODE = - struct - structure Labels = AddressLabels - structure BC = BuffCode - structure Opcodes = OpcodesKAM - structure Kam = Kam - structure RLL = ResolveLocalLabels - - fun msg s = TextIO.output(TextIO.stdOut, s) - fun chat(s: string) = if !Flags.chat then msg (s) else () - fun die s = Crash.impossible ("EmitCode." ^ s) - - fun mapi f i nil = nil - | mapi f i (x::xs) = f (x,i) :: mapi f (i+1) xs - - type target = CG.AsmPrg - type label = Labels.label - - local - open BC - val out_opcode = out_long_i - val out_int = out_long_i - val out_word32 = out_long_w32 - val out_byte = out_i - open Opcodes - open Kam - in - fun emit_kam_inst inst = - case inst of - Alloc(n) => (out_opcode ALLOC_N; out_int n) - | AllocIfInf(n) => (out_opcode ALLOC_IF_INF_N; out_int n) - | AllocSatInf(n) => (out_opcode ALLOC_SAT_INF_N; out_int n) - | AllocSatIfInf(n) => (out_opcode ALLOC_SAT_IF_INF_N; out_int n) - | AllocAtbot(n) => (out_opcode ALLOC_ATBOT_N; out_int n) - - | BlockAlloc 2 => (out_opcode BLOCK_ALLOC_2) - | BlockAlloc(n) => (out_opcode BLOCK_ALLOC_N; out_int n) - | BlockAllocIfInf(n) => (out_opcode BLOCK_ALLOC_IF_INF_N; out_int n) - | BlockAllocSatInf(n) => (out_opcode BLOCK_ALLOC_SAT_INF_N; out_int n) - | Block(n) => (out_opcode BLOCK_N; out_int n) - | BlockAllocSatIfInf(n) => (out_opcode BLOCK_ALLOC_SAT_IF_INF_N; out_int n) - | BlockAllocAtbot(n) => (out_opcode BLOCK_ALLOC_ATBOT_N; out_int n) - - | ClearAtbotBit => out_opcode CLEAR_ATBOT_BIT - | SetAtbotBit => out_opcode SET_ATBOT_BIT - - | SetBit30 => die ("inst " ^ (pr_inst inst) ^ " not emitted") - | SetBit31 => die ("inst " ^ (pr_inst inst) ^ " not emitted") - | ClearBit30And31 => die ("inst " ^ (pr_inst inst) ^ " not emitted") - | UbTagCon => out_opcode UB_TAG_CON - - | SelectStack(~1,s) => (out_opcode SELECT_STACK_M1) - | SelectStack(~2,s) => (out_opcode SELECT_STACK_M2) - | SelectStack(~3,s) => (out_opcode SELECT_STACK_M3) - | SelectStack(~4,s) => (out_opcode SELECT_STACK_M4) - | SelectStack(off,s) => (out_opcode SELECT_STACK_N; out_int off) - - | SelectEnv(off,s) => (out_opcode SELECT_ENV_N; out_int off) - | Select 0 => (out_opcode SELECT_0) - | Select 1 => (out_opcode SELECT_1) - | Select 2 => (out_opcode SELECT_2) - | Select 3 => (out_opcode SELECT_3) - | Select(off) => (out_opcode SELECT_N; out_int off) - | Store 0 => (out_opcode STORE_0) - | Store 1 => (out_opcode STORE_1) - | Store 2 => (out_opcode STORE_2) - | Store 3 => (out_opcode STORE_3) - | Store(off) => (out_opcode STORE_N; out_int off) - - | StackAddrInfBit(off,s) => (out_opcode STACK_ADDR_INF_BIT; out_int off) - | StackAddr(off,s) => (out_opcode STACK_ADDR; out_int off) - | EnvToAcc => out_opcode ENV_TO_ACC - | Halt => out_opcode HALT - - | ImmedInt(0) => (out_opcode IMMED_INT0) - | ImmedInt(1) => (out_opcode IMMED_INT1) - | ImmedInt(2) => (out_opcode IMMED_INT2) - | ImmedInt(3) => (out_opcode IMMED_INT3) - | ImmedInt(i) => (out_opcode IMMED_INT; out_long_i32 i) - - | ImmedString(str) => - let - val str_size = String.size str - fun gen_alignment 0 = () - | gen_alignment n = (out_byte 0; gen_alignment (n-1)) - val align = if Int.mod(str_size+1, 4) = 0 then 0 else (4-Int.mod(str_size+1, 4)) - in - (out_opcode IMMED_STRING; - out_word32 (BI.tag_string(true,str_size)); -(* - out_int str_size; - out_int 0; (* NULL pointer to next fragment. *) -*) - List.app (fn c => out_byte (Char.ord c)) (String.explode str); (* The actual string *) - out_byte 0; - gen_alignment align) (* obtain word alignment! *) - end - | ImmedReal(s) => - let val r = case Real.fromString s - of SOME r => r - | NONE => die "ImmedReal - string is not a real!" - in (out_opcode IMMED_REAL; out_real r) - end - | Push => (out_opcode PUSH) - | PushLbl(lab) => (out_opcode PUSH_LBL; RLL.out_label lab) - | Pop 1 => (out_opcode POP_1) - | Pop 2 => (out_opcode POP_2) - | Pop(n) => (out_opcode POP_N; out_int n) - - | ApplyFnCall(n) => (out_opcode APPLY_FN_CALL; out_int n) - | ApplyFnJmp(n1,n2) => (out_opcode APPLY_FN_JMP; out_int n1; out_int n2) - | ApplyFunCall(lab,1) => (out_opcode APPLY_FUN_CALL1; RLL.out_label lab) - | ApplyFunCall(lab,2) => (out_opcode APPLY_FUN_CALL2; RLL.out_label lab) - | ApplyFunCall(lab,3) => (out_opcode APPLY_FUN_CALL3; RLL.out_label lab) - - | ApplyFunCall(lab,n) => (out_opcode APPLY_FUN_CALL; RLL.out_label lab; out_int n) - | ApplyFunJmp(lab,n1,n2) => (out_opcode APPLY_FUN_JMP; RLL.out_label lab; out_int n1; out_int n2) - - | Return(1,1) => (out_opcode RETURN_1_1) - | Return(n1,1) => (out_opcode RETURN_N_1; out_int n1) - | Return(n1,n2) => (out_opcode RETURN; out_int n1; out_int n2) - - | Ccall(idx,0) => (out_opcode C_CALL0; out_int (idx+1)) - | Ccall(idx,1) => (out_opcode C_CALL1; out_int (idx+1)) - | Ccall(idx,2) => (out_opcode C_CALL2; out_int (idx+1)) - | Ccall(idx,3) => (out_opcode C_CALL3; out_int (idx+1)) - | Ccall(idx,4) => (out_opcode C_CALL4; out_int (idx+1)) - | Ccall(idx,5) => (out_opcode C_CALL5; out_int (idx+1)) - | Ccall(idx,6) => (out_opcode C_CALL6; out_int (idx+1)) - | Ccall(idx,7) => (out_opcode C_CALL7; out_int (idx+1)) - | Ccall(idx,n) => die ("inst " ^ (pr_inst inst) ^ " not emitted (n=" ^ Int.toString n ^ ")") - | DCcall(kind,n) => (out_opcode CHECK_LINKAGE; out_int kind; emit_kam_inst (Ccall(~1,n))) - - | Label(lab) => RLL.define_label lab - | JmpRel(lab) => (out_opcode JMP_REL; RLL.out_label lab) - - | IfNotEqJmpRelImmed(lab,3) => (out_opcode IF_NOT_EQ_JMP_REL_IMMED3; RLL.out_label lab) - | IfNotEqJmpRelImmed(lab,i) => (out_opcode IF_NOT_EQ_JMP_REL_IMMED; RLL.out_label lab; out_long_i32 i) - | IfLessThanJmpRelImmed(lab,i) => (out_opcode IF_LESS_THAN_JMP_REL_IMMED; RLL.out_label lab; out_long_i32 i) - | IfGreaterThanJmpRelImmed(lab,i) => (out_opcode IF_GREATER_THAN_JMP_REL_IMMED; RLL.out_label lab; out_long_i32 i) - | DotLabel(lab) => RLL.out_label lab - | JmpVector(lab,first_sel,len) => (out_opcode JMP_VECTOR; RLL.out_label lab; - out_long_i32 first_sel; out_long_i32 len) - - | Raise => out_opcode RAISE - | PushExnPtr => out_opcode PUSH_EXN_PTR - | PopExnPtr => out_opcode POP_EXN_PTR - - | LetregionFin(n) => (out_opcode LETREGION_FIN; out_int n) - | LetregionInf => (out_opcode LETREGION_INF) - | EndregionInf => (out_opcode ENDREGION_INF) - | ResetRegion => (out_opcode RESET_REGION) - | MaybeResetRegion => (out_opcode MAYBE_RESET_REGION) - | ResetRegionIfInf => die ("inst " ^ (pr_inst inst) ^ " not emitted") - - | FetchData(lab) => (out_opcode FETCH_DATA; RLL.out_label lab) (* fetch from data segment *) - | StoreData(lab) => (out_opcode STORE_DATA; RLL.out_label lab) (* store in data segment *) - - | Comment(s) => () - | Nop => () - - (* The following instructions are purely for optimization *) - - | StackOffset i => (out_opcode STACK_OFFSET; out_int i) - | PopPush i => (out_opcode POP_PUSH; out_int i) - | ImmedIntPush 0 => (out_opcode IMMED_INT_PUSH0) - | ImmedIntPush 1 => (out_opcode IMMED_INT_PUSH1) - | ImmedIntPush 2 => (out_opcode IMMED_INT_PUSH2) - | ImmedIntPush 3 => (out_opcode IMMED_INT_PUSH3) - | ImmedIntPush i => (out_opcode IMMED_INT_PUSH; out_long_i32 i) - - | SelectPush 0 => (out_opcode SELECT_PUSH0) - | SelectPush 1 => (out_opcode SELECT_PUSH1) - | SelectPush 2 => (out_opcode SELECT_PUSH2) - | SelectPush 3 => (out_opcode SELECT_PUSH3) - | SelectPush i => (out_opcode SELECT_PUSH; out_int i) - - | SelectEnvPush i => (out_opcode SELECT_ENV_PUSH; out_int i) - | SelectEnvClearAtbotBitPush i => (out_opcode SELECT_ENV_CLEAR_ATBOT_BIT_PUSH; out_int i) - | StackAddrPush (i,s) => (out_opcode STACK_ADDR_PUSH; out_int i) - | StackAddrInfBitAtbotBitPush i => (out_opcode STACK_ADDR_INF_BIT_ATBOT_BIT_PUSH; out_int i) - | SelectStackPush i => (out_opcode SELECT_STACK_PUSH; out_int i) - | EnvPush => (out_opcode ENV_PUSH) - - (* primitives *) - - | PrimEquali => out_opcode PRIM_EQUAL_I - | PrimSubi1 => out_opcode PRIM_SUB_I1 - | PrimSubi2 => out_opcode PRIM_SUB_I2 - | PrimSubi => out_opcode PRIM_SUB_I - | PrimAddi1 => out_opcode PRIM_ADD_I1 - | PrimAddi2 => out_opcode PRIM_ADD_I2 - | PrimAddi => out_opcode PRIM_ADD_I - | PrimMuli => out_opcode PRIM_MUL_I - | PrimNegi => out_opcode PRIM_NEG_I - | PrimAbsi => out_opcode PRIM_ABS_I - - | PrimAddf => out_opcode PRIM_ADD_F - | PrimSubf => out_opcode PRIM_SUB_F - | PrimMulf => out_opcode PRIM_MUL_F - | PrimDivf => out_opcode PRIM_DIV_F - | PrimNegf => out_opcode PRIM_NEG_F - | PrimAbsf => out_opcode PRIM_ABS_F - - | PrimLessThanFloat => (out_opcode PRIM_LESS_THAN_F) - | PrimLessEqualFloat => (out_opcode PRIM_LESS_EQUAL_F) - | PrimGreaterThanFloat => (out_opcode PRIM_GREATER_THAN_F) - | PrimGreaterEqualFloat => (out_opcode PRIM_GREATER_EQUAL_F) - - | PrimLessThan => (out_opcode PRIM_LESS_THAN) - | PrimLessEqual => (out_opcode PRIM_LESS_EQUAL) - | PrimGreaterThan => (out_opcode PRIM_GREATER_THAN) - | PrimGreaterEqual => (out_opcode PRIM_GREATER_EQUAL) - - | PrimLessThanUnsigned => (out_opcode PRIM_LESS_THAN_UNSIGNED) - | PrimGreaterThanUnsigned => (out_opcode PRIM_GREATER_THAN_UNSIGNED) - | PrimLessEqualUnsigned => (out_opcode PRIM_LESS_EQUAL_UNSIGNED) - | PrimGreaterEqualUnsigned => (out_opcode PRIM_GREATER_EQUAL_UNSIGNED) - - | PrimAndw => out_opcode PRIM_AND_W - | PrimOrw => out_opcode PRIM_OR_W - | PrimXorw => out_opcode PRIM_XOR_W - | PrimShiftLeftw => out_opcode PRIM_SHIFT_LEFT_W - | PrimShiftRightSignedw => out_opcode PRIM_SHIFT_RIGHT_SIGNED_W - | PrimShiftRightUnsignedw => out_opcode PRIM_SHIFT_RIGHT_UNSIGNED_W - | PrimAddw => out_opcode PRIM_ADD_W - | PrimSubw => out_opcode PRIM_SUB_W - | PrimMulw => out_opcode PRIM_MUL_W - - | PrimSubi31 => out_opcode PRIM_SUB_I31 - | PrimAddi31 => out_opcode PRIM_ADD_I31 - | PrimMuli31 => out_opcode PRIM_MUL_I31 - | PrimNegi31 => out_opcode PRIM_NEG_I31 - | PrimAbsi31 => out_opcode PRIM_ABS_I31 - | PrimXorw31 => out_opcode PRIM_XOR_W31 - | PrimShiftLeftw31 => out_opcode PRIM_SHIFT_LEFT_W31 - | PrimShiftRightSignedw31 => out_opcode PRIM_SHIFT_RIGHT_SIGNED_W31 - | PrimShiftRightUnsignedw31 => out_opcode PRIM_SHIFT_RIGHT_UNSIGNED_W31 - | PrimAddw31 => out_opcode PRIM_ADD_W31 - | PrimSubw31 => out_opcode PRIM_SUB_W31 - | PrimMulw31 => out_opcode PRIM_MUL_W31 - - | Primi31Toi => out_opcode PRIM_I31_TO_I - | PrimiToi31 => out_opcode PRIM_I_TO_I31 - | Primw31Tow => out_opcode PRIM_W31_TO_W - | PrimwTow31 => out_opcode PRIM_W_TO_W31 - | Primw31TowX => out_opcode PRIM_W31_TO_W_X - | PrimwToi => out_opcode PRIM_W_TO_I - - | PrimFreshExname => out_opcode PRIM_FRESH_EXNAME - - | PrimByteTableSub => out_opcode PRIM_BYTETABLE_SUB - | PrimByteTableUpdate => out_opcode PRIM_BYTETABLE_UPDATE - | PrimWordTableSub => out_opcode PRIM_WORDTABLE_SUB - | PrimWordTableUpdate => out_opcode PRIM_WORDTABLE_UPDATE - | PrimTableSize => out_opcode PRIM_TABLE_SIZE - | PrimIsNull => out_opcode PRIM_IS_NULL - - | GetContext => out_opcode GET_CONTEXT - - end - - fun emit_kam_insts insts = List.app emit_kam_inst insts - - fun emit_top_decl top_decl = - let - fun emit_decl (lab,kam_insts) = (RLL.define_label lab; - emit_kam_insts kam_insts) - in - case top_decl of - Kam.FUN(lab,kam_insts) => emit_decl(lab,kam_insts) - | Kam.FN(lab,kam_insts) => emit_decl(lab,kam_insts) - end - - fun emit {target as {top_decls: Kam.TopDecl list, - main_lab_opt, - imports_code: label list, - imports_data: label list, - exports_code: label list, - exports_data: label list}, filename:string} : unit = - let val _ = chat ("[Emitting KAM code in file " ^ filename ^ "...") - val _ = (BC.init_out_code(); - RLL.reset_label_table(); - List.app emit_top_decl top_decls) - - (* to find out where in the code there are references to external - * labels, we look in the environment maintained by RLL, which - * maps labels to either 1) a known position in the bytecode or 2) a list - * of those places that need be updated once the label position is known. *) - - val map_import_code = map (fn (i,l) => (i, Labels.key l)) (RLL.imports imports_code) - val map_import_data = map (fn (i,l) => (i, Labels.key l)) (RLL.imports imports_data) - val map_export_code = map (fn (l,i) => (Labels.key l, i)) (RLL.exports exports_code) - val map_export_data = map (fn (i,l) => (Labels.key l, i)) (RLL.imports exports_data) - - (* Here is the story about data-segment exports: each unit can allocate data in the - * data segment. In the non-loaded bytecode the instruction `StoreData lab' stores the - * accumulator in the data slot determined by the label lab. The map_export_data-part - * of the bytecode file, determines the bytecode-addresses of the label-arguments to - * each of the StoreData instructions. - * - * At load time, each of the labels are associated with - * new slots relative to the data-segment pointer, then the - * StoreData instructions are modified to take offsets - * from the data-segment pointer as arguments, and finally the - * labels are associated with these offsets in the hash table that - * maps labels to offsets. - *) - - in - (BC.dump_buffer {filename=filename, - main_lab_opt=Option.map Labels.key main_lab_opt, - map_import_code=map_import_code, - map_import_data=map_import_data, - map_export_code=map_export_code, - map_export_data=map_export_data}; - print ("[wrote KAM code file:\t" ^ filename ^ "]\n"); - chat "]\n") handle IO.Io {name,...} => Crash.impossible ("EmitCode.emit:\nI cannot open \"" - ^ filename ^ "\":\n" ^ name) - end - end diff --git a/src/Compiler/Backend/KAM/ExecutionKAM.sml b/src/Compiler/Backend/KAM/ExecutionKAM.sml deleted file mode 100644 index 6e1ab1183..000000000 --- a/src/Compiler/Backend/KAM/ExecutionKAM.sml +++ /dev/null @@ -1,135 +0,0 @@ - -structure ExecutionKAM : EXECUTION = - struct - structure TopdecGrammar = PostElabTopdecGrammar - structure Labels = AddressLabels - structure PP = PrettyPrint - - structure BackendInfo = - BackendInfo(val down_growing_stack : bool = false) (* false for KAM *) - - structure ClosConvEnv = ClosConvEnv(BackendInfo) - - structure CallConv = CallConv(BackendInfo) - - structure ClosExp = ClosExp(structure ClosConvEnv = ClosConvEnv - structure BI = BackendInfo - structure CallConv = CallConv) - - structure JumpTables = JumpTables(BackendInfo) - - structure CodeGen = CodeGenKAM(structure CallConv = CallConv - structure ClosExp = ClosExp - structure BI = BackendInfo - structure JumpTables = JumpTables) - - structure EmitCode = EmitCode(structure CG = CodeGen - structure BI = BackendInfo) - - structure CompileBasis = CompileBasis(structure CompBasis = CompBasis - structure ClosExp = ClosExp) - - val backend_name = "KAM" - - val be_rigid = false - - 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 = Labels.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 - - (* 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 {main_lab, code, imports, exports, env} = ClosExp.lift(closenv,target) -(* val _ = print "Returning from lift...\n" *) - val asm_prg = - Timing.timing "CG" CodeGen.CG - {main_lab_opt= (* if safe then NONE else*) SOME main_lab, - code=code, - imports=imports, - exports=exports} - - 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,env) - in - CodeRes(ce,CB,asm_prg,linkinfo) - end - end - - val generate_link_code = NONE - - fun emit (arg as {target, filename:string}) : string = - let val filename = filename ^ ".uo" - in EmitCode.emit {target=target, filename=filename}; - filename - end - - fun link_files_with_runtime_system files run = - if !Flags.SMLserver then () - else - let - (* It would be preferable to truly link together the files - * and the runtime system "kam", so as to produce a movable - * executable. mael 2005-04-18 *) - val files = - map (fn f => OS.Path.mkAbsolute{relativeTo=OS.FileSys.getDir(),path=f}) files - val os = TextIO.openOut run - in (* print ("[Creating file " ^ run ^ " begin ...]\n"); *) - TextIO.output(os, "#!/bin/sh\n" ^ !Flags.install_dir ^ "/lib/kam "); - app (fn f => TextIO.output(os, f ^ " ")) files; - TextIO.output(os, "--args $0 $*"); - TextIO.closeOut os; - OS.Process.system ("chmod a+x " ^ run); - print("[Created file " ^ run ^ "]\n") - (* ; app (print o (fn s => " " ^ s ^ "\n")) files *) - end - - val op ## = OS.Path.concat infix ## - - fun mlbdir() = - let val subdir = - if !Flags.SMLserver then "SMLserver" - else "RI" - in "MLB" ## subdir - 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.tup4Gen0(Labels.pu,pu_pair,pu_pair,Pickle.bool)) - end - end diff --git a/src/Compiler/Backend/KAM/KAM.sig b/src/Compiler/Backend/KAM/KAM.sig deleted file mode 100644 index 0117dd07e..000000000 --- a/src/Compiler/Backend/KAM/KAM.sig +++ /dev/null @@ -1,192 +0,0 @@ -(* Specification of the Kit Abstract Machine. *) - -signature KAM = - sig - - type label - val eq_lab : label * label -> bool - - datatype KamInst = - Alloc of int - | AllocIfInf of int - | AllocSatInf of int - | AllocSatIfInf of int - | AllocAtbot of int - - | BlockAlloc of int - | BlockAllocIfInf of int - | BlockAllocSatInf of int - | Block of int - | BlockAllocSatIfInf of int - | BlockAllocAtbot of int - | ClearAtbotBit - | SetAtbotBit - - | SetBit30 (* for unboxed data constructors *) - | SetBit31 (* .. *) - | ClearBit30And31 - | UbTagCon - - | SelectStack of int * string (* string for debug only *) - | SelectEnv of int * string (* string for debug only *) - | Select of int - | Store of int - - | StackAddrInfBit of int * string (* string for debug only *) - | StackAddr of int * string (* string for debug only *) - | EnvToAcc - - | ImmedInt of Int32.int - | ImmedString of string - | ImmedReal of string - - | Push - | PushLbl of label - | Pop of int - - | ApplyFnCall of int - | ApplyFnJmp of int * int - | ApplyFunCall of label * int - | ApplyFunJmp of label * int * int - | Return of int * int - - | Ccall of int * int - | DCcall of int * int - - | Label of label - | JmpRel of label - - | IfNotEqJmpRelImmed of label * Int32.int - | IfLessThanJmpRelImmed of label * Int32.int - | IfGreaterThanJmpRelImmed of label * Int32.int - | DotLabel of label - | JmpVector of label * Int32.int * Int32.int - (*start*) (*length*) - | Raise - | PushExnPtr - | PopExnPtr - - | LetregionFin of int - | LetregionInf - | EndregionInf - | ResetRegion - | MaybeResetRegion - | ResetRegionIfInf - - | FetchData of label - | StoreData of label - - | Halt - | Comment of string - | Nop - - (* The following instructions are purely for optimization *) - - | StackOffset of int - | PopPush of int - | ImmedIntPush of Int32.int - | SelectPush of int - | SelectEnvPush of int - | SelectEnvClearAtbotBitPush of int - | StackAddrPush of int * string (* string is for debugging *) - | StackAddrInfBitAtbotBitPush of int - | SelectStackPush of int - | EnvPush - - | PrimEquali - | PrimSubi1 - | PrimSubi2 - | PrimSubi - | PrimAddi1 - | PrimAddi2 - | PrimAddi - | PrimMuli - | PrimNegi - | PrimAbsi - - | PrimAddf - | PrimSubf - | PrimMulf - | PrimDivf - | PrimNegf - | PrimAbsf - - | PrimLessThanFloat - | PrimLessEqualFloat - | PrimGreaterThanFloat - | PrimGreaterEqualFloat - - | PrimLessThan - | PrimLessEqual - | PrimGreaterThan - | PrimGreaterEqual - - | PrimLessThanUnsigned - | PrimGreaterThanUnsigned - | PrimLessEqualUnsigned - | PrimGreaterEqualUnsigned - - | PrimAndw - | PrimOrw - | PrimXorw - | PrimShiftLeftw - | PrimShiftRightSignedw - | PrimShiftRightUnsignedw - | PrimAddw - | PrimSubw - | PrimMulw - - | PrimSubi31 - | PrimAddi31 - | PrimMuli31 - | PrimNegi31 - | PrimAbsi31 - | PrimXorw31 - | PrimShiftLeftw31 - | PrimShiftRightSignedw31 - | PrimShiftRightUnsignedw31 - | PrimAddw31 - | PrimSubw31 - | PrimMulw31 - - | Primi31Toi - | PrimiToi31 - | Primw31Tow - | PrimwTow31 - | Primw31TowX - | PrimwToi - - | PrimFreshExname - - | PrimByteTableSub - | PrimByteTableUpdate - | PrimWordTableSub - | PrimWordTableUpdate - | PrimTableSize - - | PrimIsNull - - | GetContext - - datatype TopDecl = - FUN of label * KamInst list - | FN of label * KamInst list - - type AsmPrg = {top_decls: TopDecl list, - main_lab_opt: label option, - imports_code: label list, (* code imports *) - imports_data: label list, (* data imports *) - exports_code: label list, (* code exports *) - exports_data: label list} (* data exports *) - - (******************) - (* PrettyPrinting *) - (******************) - type StringTree - val layout_AsmPrg : AsmPrg -> StringTree - - (* To Emit Code *) - val pr_inst : KamInst -> string - val pp_lab : label -> string - end - diff --git a/src/Compiler/Backend/KAM/Kam.sml b/src/Compiler/Backend/KAM/Kam.sml deleted file mode 100644 index ee628ba48..000000000 --- a/src/Compiler/Backend/KAM/Kam.sml +++ /dev/null @@ -1,438 +0,0 @@ -(* Specification of the Kit Abstract Machine (Byte code machine). *) - -structure Kam : KAM = - struct - structure Labels = AddressLabels - structure PP = PrettyPrint - - (***********) - (* Logging *) - (***********) - fun die s = Crash.impossible ("KAM." ^ s) - - (*----------------------------------------------------------*) - (* Code *) - (*----------------------------------------------------------*) - - type label = Labels.label - fun eq_lab(l1,l2) = Labels.eq(l1,l2) - - datatype KamInst = - Alloc of int - | AllocIfInf of int - | AllocSatInf of int - | AllocSatIfInf of int - | AllocAtbot of int - - | BlockAlloc of int - | BlockAllocIfInf of int - | BlockAllocSatInf of int - | Block of int - | BlockAllocSatIfInf of int - | BlockAllocAtbot of int - | ClearAtbotBit - | SetAtbotBit - - | SetBit30 - | SetBit31 - | ClearBit30And31 - | UbTagCon - - | SelectStack of int * string (* string for debug only *) - | SelectEnv of int * string (* string for debug only *) - | Select of int - | Store of int - - | StackAddrInfBit of int * string (* string for debug only *) - | StackAddr of int * string (* string for debug only *) - | EnvToAcc - - | ImmedInt of Int32.int - | ImmedString of string - | ImmedReal of string - - | Push - | PushLbl of label - | Pop of int - - | ApplyFnCall of int - | ApplyFnJmp of int * int - | ApplyFunCall of label * int - | ApplyFunJmp of label * int * int - | Return of int * int - - | Ccall of int * int - | DCcall of int * int - - | Label of label - | JmpRel of label - - | IfNotEqJmpRelImmed of label * Int32.int - | IfLessThanJmpRelImmed of label * Int32.int - | IfGreaterThanJmpRelImmed of label * Int32.int - | DotLabel of label - | JmpVector of label * Int32.int * Int32.int - - | Raise - | PushExnPtr - | PopExnPtr - - | LetregionFin of int - | LetregionInf - | EndregionInf - | ResetRegion - | MaybeResetRegion - | ResetRegionIfInf - - | FetchData of label - | StoreData of label - - | Halt - | Comment of string - | Nop - - (* The following instructions are purely for optimization *) - - | StackOffset of int - | PopPush of int - | ImmedIntPush of Int32.int - | SelectPush of int - | SelectEnvPush of int - | SelectEnvClearAtbotBitPush of int - | StackAddrPush of int * string (* string is for debugging *) - | StackAddrInfBitAtbotBitPush of int - | SelectStackPush of int - | EnvPush - - (* primitives *) - - | PrimEquali - | PrimSubi1 - | PrimSubi2 - | PrimSubi - | PrimAddi1 - | PrimAddi2 - | PrimAddi - | PrimMuli - | PrimNegi - | PrimAbsi - - | PrimAddf - | PrimSubf - | PrimMulf - | PrimDivf - | PrimNegf - | PrimAbsf - - | PrimLessThanFloat - | PrimLessEqualFloat - | PrimGreaterThanFloat - | PrimGreaterEqualFloat - - | PrimLessThan - | PrimLessEqual - | PrimGreaterThan - | PrimGreaterEqual - - | PrimLessThanUnsigned - | PrimGreaterThanUnsigned - | PrimLessEqualUnsigned - | PrimGreaterEqualUnsigned - - | PrimAndw - | PrimOrw - | PrimXorw - | PrimShiftLeftw - | PrimShiftRightSignedw - | PrimShiftRightUnsignedw - - | PrimAddw - | PrimSubw - | PrimMulw - - | PrimSubi31 - | PrimAddi31 - | PrimMuli31 - | PrimNegi31 - | PrimAbsi31 - | PrimXorw31 - | PrimShiftLeftw31 - | PrimShiftRightSignedw31 - | PrimShiftRightUnsignedw31 - | PrimAddw31 - | PrimSubw31 - | PrimMulw31 - - | Primi31Toi - | PrimiToi31 - | Primw31Tow - | PrimwTow31 - | Primw31TowX - | PrimwToi - - | PrimFreshExname - - | PrimByteTableSub - | PrimByteTableUpdate - | PrimWordTableSub - | PrimWordTableUpdate - | PrimTableSize - - | PrimIsNull - - | GetContext - - datatype TopDecl = - FUN of label * KamInst list - | FN of label * KamInst list - - type AsmPrg = {top_decls: TopDecl list, - main_lab_opt: label option, - imports_code: label list, - imports_data: label list, - exports_code: label list, - exports_data: label list} - - (*----------------------------------------------------------*) - (* Pretty printing *) - (*----------------------------------------------------------*) - - local - val output_stream : TextIO.outstream ref = ref TextIO.stdOut - fun out str = TextIO.output(!output_stream,str) - in - fun reset_output_stream () = output_stream := TextIO.stdOut - fun set_out_stream stream = output_stream := stream - fun out_list str_list = out (concat str_list) - end - - fun pp_i i = Int.toString i - - local - fun remove_ctrl s = "Lab" ^ String.implode (List.filter Char.isAlphaNum (String.explode s)) - fun remove_ctrl' s = String.implode (List.filter Char.isPrint (String.explode s)) - in - fun pp_lab l = Labels.pr_label l - fun pp_lab' (l,acc) = Labels.pr_label l :: acc - end - - val indent = "\t" - - fun pp_inst (inst,acc) : string list = - case inst of - Alloc(n) => "Alloc(" :: (pp_i n) :: ")" :: acc - | AllocIfInf(n) => "AllocIfInf(" :: (pp_i n) :: ")" :: acc - | AllocSatInf(n) => "AllocSatInf(" :: (pp_i n) :: ")" :: acc - | AllocSatIfInf(n) => "AllocSatIfInf(" :: (pp_i n) :: ")" :: acc - | AllocAtbot(n) => "AllocAtbot(" :: (pp_i n) :: ")" :: acc - - | BlockAlloc(n) => "BlockAlloc(" :: (pp_i n) :: ")" :: acc - | BlockAllocIfInf(n) => "BlockAllocIfInf(" :: (pp_i n) :: ")" :: acc - | BlockAllocSatInf(n) => "BlockAllocSatInf(" :: (pp_i n) :: ")" :: acc - | Block(n) => "Block(" :: (pp_i n) :: ")" :: acc - | BlockAllocSatIfInf(n) => "BlockAllocSatIfInf(" :: (pp_i n) :: ")" :: acc - | BlockAllocAtbot(n) => "BlockAllocAtbot(" :: (pp_i n) :: ")" :: acc - - | ClearAtbotBit => "ClearAtbotBit" :: acc - | SetAtbotBit => "SetAtbotBit" :: acc - - | SetBit30 => "SetBit30" :: acc - | SetBit31 => "SetBit31" :: acc - | ClearBit30And31 => "ClearBit30And31" :: acc - | UbTagCon => "UbTagCon" :: acc - - | SelectStack(off,s) => "SelectStack(" :: (pp_i off) :: "," :: s :: ")" :: acc - | SelectEnv(off,s) => "SelectEnv(" :: (pp_i off) :: "," :: s :: ")" :: acc - | Select(off) => "Select(" :: (pp_i off) :: ")" :: acc - | Store(off) => "Store(" :: (pp_i off) :: ")" :: acc - - | StackAddrInfBit(off,s) => "StackAddrInfBit(" :: (pp_i off) :: "," :: s :: ")" :: acc - | StackAddr(off,s) => "StackAddr(" :: (pp_i off) :: "," :: s :: ")" :: acc - | EnvToAcc => "EnvToAcc" :: acc - - | ImmedInt(i) => "ImmedInt(" :: Int32.toString i :: ")" :: acc - | ImmedString(s) => "ImmedString(\"" :: String.toString s :: "\")" :: acc - | ImmedReal(r) => "ImmedReal(" :: r :: ")" :: acc - - | Push => "Push" :: acc - | PushLbl(lab) => "PushLbl(" :: (pp_lab lab) :: ")" :: acc - | Pop(n) => "Pop(" :: (pp_i n) :: ")" :: acc - - | ApplyFnCall(n) => "ApplyFnCall(" :: (pp_i n) :: ")" :: acc - | ApplyFnJmp(n1,n2) => "ApplyFnJmp(" :: (pp_i n1) :: "," :: (pp_i n2) :: ")" :: acc - | ApplyFunCall(lab,n) => "ApplyFunCall(" :: (pp_lab lab) :: "," :: (pp_i n) :: ")" :: acc - | ApplyFunJmp(lab,n1,n2) => "ApplyFunJmp(" :: (pp_lab lab) :: "," :: (pp_i n1) :: "," :: (pp_i n2) :: ")" :: acc - | Return(n1,n2) => "Return(" :: (pp_i n1) :: "," :: (pp_i n2) :: ")" :: acc - - | Ccall(idx,arity) => "Ccall(" :: (pp_i idx) :: "," :: (pp_i arity) ::")" :: acc - | DCcall(kind,idx) => "CheckLinkage(" :: (pp_i kind) :: ")" - :: "Ccall(" :: (pp_i idx) :: "," :: (pp_i 0) :: ")" :: acc - - | Label(lab) => "Label(" :: (pp_lab lab) :: ")" :: acc - | JmpRel(lab) => "JmpRel(" :: (pp_lab lab) :: ")" :: acc - - | IfNotEqJmpRelImmed(lab,i) => "IfNotEqJmpRelImmed(" :: (pp_lab lab) :: "," :: Int32.toString i :: ")" :: acc - | IfLessThanJmpRelImmed(lab,i) => "IfLessThanJmpRelImmed(" :: (pp_lab lab) :: "," :: Int32.toString i ::")" :: acc - | IfGreaterThanJmpRelImmed(lab,i) => "IfGreaterThanJmpRelImmed(" :: (pp_lab lab) :: "," :: Int32.toString i :: ")" :: acc - | DotLabel(lab) => "DotLabel(" :: (pp_lab lab) :: ")" :: acc - | JmpVector(lab,first_sel,length) => "JmpVector(" :: (pp_lab lab) :: "," :: (Int32.toString first_sel) :: "," :: (Int32.toString length) :: ")" :: acc - - | Raise => "Raise" :: acc - | PushExnPtr => "PushExnPtr" :: acc - | PopExnPtr => "PopExnPtr" :: acc - - | LetregionFin(n) => "LetregionFin(" :: (pp_i n) :: ")" :: acc - | LetregionInf => "LetregionInf" :: acc - | EndregionInf => "EndregionInf" :: acc - | ResetRegion => "ResetRegion" :: acc - | MaybeResetRegion => "MaybeResetRegion" :: acc - | ResetRegionIfInf => "ResetRegionIfInf" :: acc - - | FetchData(lab) => "FetchData(" :: (pp_lab lab) :: ")" :: acc - | StoreData(lab) => "StoreData(" :: (pp_lab lab) :: ")" :: acc - - | Halt => "Halt" :: acc - | Comment(s) => "Comment[" :: s :: "]" :: acc - | Nop => "Nop" :: acc - - (* The following instructions are purely for optimization *) - - | StackOffset i => "StackOffset(" :: Int.toString i :: ")" :: acc - | PopPush i => "PopPush(" :: Int.toString i :: ")" :: acc - | ImmedIntPush i => "ImmedIntPush(" :: Int32.toString i :: ")" :: acc - | SelectPush i => "SelectPush(" :: Int.toString i :: ")" :: acc - | SelectEnvPush i => "SelectEnvPush(" :: Int.toString i :: ")" :: acc - | SelectEnvClearAtbotBitPush i => "SelectEnvClearAtbotBitPush(" :: Int.toString i :: ")" :: acc - | StackAddrPush (i,s) => "StackAddrPush(" :: Int.toString i :: "," :: s :: ")" :: acc (* string is for debugging *) - | StackAddrInfBitAtbotBitPush i => "StackAddrInfBitAtbotBitPush(" :: Int.toString i :: ")" :: acc - | SelectStackPush i => "SelectStackPush(" :: Int.toString i :: ")" :: acc - | EnvPush => "EnvPush" :: acc - - (* primitives *) - - | PrimEquali => "PrimEquali" :: acc - | PrimSubi1 => "PrimSubi1" :: acc - | PrimSubi2 => "PrimSubi2" :: acc - | PrimSubi => "PrimSubi" :: acc - | PrimAddi1 => "PrimAddi1" :: acc - | PrimAddi2 => "PrimAddi2" :: acc - | PrimAddi => "PrimAddi" :: acc - | PrimMuli => "PrimMuli" :: acc - | PrimNegi => "PrimNegi" :: acc - | PrimAbsi => "PrimAbsi" :: acc - - | PrimAddf => "PrimAddf" :: acc - | PrimSubf => "PrimSubf" :: acc - | PrimMulf => "PrimMulf" :: acc - | PrimDivf => "PrimDivf" :: acc - | PrimNegf => "PrimNegf" :: acc - | PrimAbsf => "PrimAbsf" :: acc - - | PrimLessThanFloat => "PrimLessThanFloat" :: acc - | PrimLessEqualFloat => "PrimLessEqualFloat" :: acc - | PrimGreaterThanFloat => "PrimGreaterThanFloat" :: acc - | PrimGreaterEqualFloat => "PrimGreaterEqualFloat" :: acc - - | PrimLessThan => "PrimLessThan" :: acc - | PrimLessEqual => "PrimLessEqual" :: acc - | PrimGreaterThan => "PrimGreaterThan" :: acc - | PrimGreaterEqual => "PrimGreaterEqual" :: acc - - | PrimLessThanUnsigned => "PrimLessThanUnsigned" :: acc - | PrimGreaterThanUnsigned => "PrimGreaterThanUnsigned" :: acc - | PrimLessEqualUnsigned => "PrimLessEqualUnsigned" :: acc - | PrimGreaterEqualUnsigned => "PrimGreaterEqualUnsigned" :: acc - - | PrimAndw => "PrimAndw" :: acc - | PrimOrw => "PrimOrw" :: acc - | PrimXorw => "PrimXorw" :: acc - | PrimShiftLeftw => "PrimShiftLeftw" :: acc - | PrimShiftRightSignedw => "PrimShiftRightSignedw" :: acc - | PrimShiftRightUnsignedw => "PrimShiftRightUnsignedw" :: acc - - | PrimAddw => "PrimAddw" :: acc - | PrimSubw => "PrimSubw" :: acc - | PrimMulw => "PrimMulw" :: acc - - | PrimSubi31 => "PrimSubi31" :: acc - | PrimAddi31 => "PrimAddi31" :: acc - | PrimMuli31 => "PrimMuli31" :: acc - | PrimNegi31 => "PrimNegi31" :: acc - | PrimAbsi31 => "PrimAbsi31" :: acc - | PrimXorw31 => "PrimXorw31" :: acc - | PrimShiftLeftw31 => "PrimShiftLeftw31" :: acc - | PrimShiftRightSignedw31 => "PrimShiftRightSignedw31" :: acc - | PrimShiftRightUnsignedw31 => "PrimShiftRightUnsignedw31" :: acc - | PrimAddw31 => "PrimAddw31" :: acc - | PrimSubw31 => "PrimSubw31" :: acc - | PrimMulw31 => "PrimMulw31" :: acc - - | Primi31Toi => "Primi31Toi" :: acc - | PrimiToi31 => "PrimiToi31" :: acc - | Primw31Tow => "Primw31Tow" :: acc - | PrimwTow31 => "PrimwTow31" :: acc - | Primw31TowX => "Primw31TowX" :: acc - | PrimwToi => "PrimwToi" :: acc - - | PrimFreshExname => "PrimFreshExname" :: acc - - | PrimByteTableSub => "PrimByteTableSub" :: acc - | PrimByteTableUpdate => "PrimByteTableUpdate" :: acc - | PrimWordTableSub => "PrimWordTableSub" :: acc - | PrimWordTableUpdate => "PrimWordTableUpdate" :: acc - | PrimTableSize => "PrimTableSize" :: acc - | PrimIsNull => "PrimIsNull" :: acc - - | GetContext => "GetContext" :: acc - - fun pr_inst i = concat(pp_inst(i,[])) - - type StringTree = PP.StringTree - fun layout_AsmPrg({top_decls, - main_lab_opt, - imports_code, - imports_data, - exports_code, - exports_data}) = - let - open PP - fun layout_kam_inst i = LEAF(concat(pp_inst(i,[]))) - fun layout_top_decl(FUN(lab,kam_insts)) = - NODE{start = "FUN " ^ Labels.pr_label lab ^ " is {", - finish = "}", - indent = 2, - childsep = RIGHT ";", - children = map layout_kam_inst kam_insts} - | layout_top_decl (FN(lab,kam_insts)) = - NODE{start = "FN " ^ Labels.pr_label lab ^ " is {", - finish = "}", - indent = 2, - childsep = RIGHT ";", - children = map layout_kam_inst kam_insts} - val body_node = NODE{start="", - finish="", - indent=0, - childsep=RIGHT " ", - children=map layout_top_decl top_decls} - fun labels s labs = NODE{start=s ^ " = [",finish="]",indent=2,childsep=RIGHT",", - children=map (LEAF o Labels.pr_label) labs} - val header_node = NODE {start="HEADER is {", - finish="}", childsep=RIGHT "; ", indent=2, - children=[LEAF ("Main label option = " ^ - (case main_lab_opt - of SOME lab => "SOME " ^ Labels.pr_label lab - | NONE => "NONE")), - labels "Imports code" imports_code, - labels "Imports data" imports_data, - labels "Exports code" exports_code, - labels "Exports data" exports_data]} - in - NODE{start="KAM program begin", - finish="KAM program end", - indent=2, - childsep=NOSEP, - children = [header_node,body_node]} - end - end - - diff --git a/src/Compiler/Backend/KAM/KamInsts.spec b/src/Compiler/Backend/KAM/KamInsts.spec deleted file mode 100644 index 47655d7e8..000000000 --- a/src/Compiler/Backend/KAM/KamInsts.spec +++ /dev/null @@ -1,172 +0,0 @@ -ALLOC_N 1 -ALLOC_IF_INF_N 1 -ALLOC_SAT_INF_N 1 -ALLOC_SAT_IF_INF_N 1 -ALLOC_ATBOT_N 1 -BLOCK_ALLOC_2 0 -BLOCK_ALLOC_N 1 -BLOCK_ALLOC_IF_INF_N 1 -BLOCK_ALLOC_SAT_INF_N 1 -BLOCK_N 1 -BLOCK_ALLOC_SAT_IF_INF_N 1 -BLOCK_ALLOC_ATBOT_N 1 -CLEAR_ATBOT_BIT 0 -SET_ATBOT_BIT 0 -SET_BIT_30 0 -SET_BIT_31 0 -CLEAR_BIT_30_AND_31 0 -UB_TAG_CON 0 -SELECT_STACK_M1 0 -SELECT_STACK_M2 0 -SELECT_STACK_M3 0 -SELECT_STACK_M4 0 -SELECT_STACK_N 1 -SELECT_ENV_N 1 -SELECT_0 0 -SELECT_1 0 -SELECT_2 0 -SELECT_3 0 -SELECT_N 1 -STORE_0 0 -STORE_1 0 -STORE_2 0 -STORE_3 0 -STORE_N 1 -STACK_ADDR_INF_BIT 1 -STACK_ADDR 1 -ENV_TO_ACC 0 -IMMED_INT0 0 -IMMED_INT1 0 -IMMED_INT2 0 -IMMED_INT3 0 -IMMED_INT 1 -IMMED_STRING ~1 -IMMED_REAL 2 -PUSH 0 -PUSH_LBL 1 -POP_1 0 -POP_2 0 -POP_N 1 -APPLY_FN_CALL 1 -APPLY_FN_JMP 2 -APPLY_FUN_CALL1 1 -APPLY_FUN_CALL2 1 -APPLY_FUN_CALL3 1 -APPLY_FUN_CALL 2 -APPLY_FUN_JMP 3 -RETURN_1_1 0 -RETURN_N_1 1 -RETURN 2 -C_CALL0 1 -C_CALL1 1 -C_CALL2 1 -C_CALL3 1 -C_CALL4 1 -C_CALL5 1 -C_CALL6 1 -C_CALL7 1 -LABEL ~4 -JMP_REL 1 -IF_NOT_EQ_JMP_REL_IMMED3 1 -IF_NOT_EQ_JMP_REL_IMMED 2 -IF_LESS_THAN_JMP_REL_IMMED 2 -IF_GREATER_THAN_JMP_REL_IMMED 2 -DOT_LABEL ~3 -JMP_VECTOR ~2 -RAISE 0 -PUSH_EXN_PTR 0 -POP_EXN_PTR 0 -GLOBAL_EXN_HANDLER_REPORT 0 -LETREGION_FIN 1 -LETREGION_INF 0 -ENDREGION_INF 0 -RESET_REGION 0 -MAYBE_RESET_REGION 0 -RESET_REGION_IF_INF 0 -FETCH_DATA 1 -STORE_DATA 1 -HALT 0 -STACK_OFFSET 1 -POP_PUSH 1 -IMMED_INT_PUSH0 0 -IMMED_INT_PUSH1 0 -IMMED_INT_PUSH2 0 -IMMED_INT_PUSH3 0 -IMMED_INT_PUSH 1 -SELECT_PUSH0 0 -SELECT_PUSH1 0 -SELECT_PUSH2 0 -SELECT_PUSH3 0 -SELECT_PUSH 1 -SELECT_ENV_PUSH 1 -SELECT_ENV_CLEAR_ATBOT_BIT_PUSH 1 -STACK_ADDR_PUSH 1 -STACK_ADDR_INF_BIT_ATBOT_BIT_PUSH 1 -SELECT_STACK_PUSH 1 -ENV_PUSH 0 -PRIM_EQUAL_I 0 -PRIM_SUB_I1 0 -PRIM_SUB_I2 0 -PRIM_SUB_I 0 -PRIM_ADD_I1 0 -PRIM_ADD_I2 0 -PRIM_ADD_I 0 -PRIM_MUL_I 0 -PRIM_NEG_I 0 -PRIM_ABS_I 0 -PRIM_ADD_F 0 -PRIM_SUB_F 0 -PRIM_MUL_F 0 -PRIM_DIV_F 0 -PRIM_NEG_F 0 -PRIM_ABS_F 0 -PRIM_LESS_THAN_F 0 -PRIM_LESS_EQUAL_F 0 -PRIM_GREATER_THAN_F 0 -PRIM_GREATER_EQUAL_F 0 -PRIM_LESS_THAN 0 -PRIM_LESS_EQUAL 0 -PRIM_GREATER_THAN 0 -PRIM_GREATER_EQUAL 0 -PRIM_LESS_THAN_UNSIGNED 0 -PRIM_GREATER_THAN_UNSIGNED 0 -PRIM_LESS_EQUAL_UNSIGNED 0 -PRIM_GREATER_EQUAL_UNSIGNED 0 -PRIM_AND_W 0 -PRIM_OR_W 0 -PRIM_XOR_W 0 -PRIM_SHIFT_LEFT_W 0 -PRIM_SHIFT_RIGHT_SIGNED_W 0 -PRIM_SHIFT_RIGHT_UNSIGNED_W 0 -PRIM_ADD_W 0 -PRIM_SUB_W 0 -PRIM_MUL_W 0 -PRIM_SUB_I31 0 -PRIM_ADD_I31 0 -PRIM_MUL_I31 0 -PRIM_NEG_I31 0 -PRIM_ABS_I31 0 -PRIM_XOR_W31 0 -PRIM_SHIFT_LEFT_W31 0 -PRIM_SHIFT_RIGHT_SIGNED_W31 0 -PRIM_SHIFT_RIGHT_UNSIGNED_W31 0 -PRIM_ADD_W31 0 -PRIM_SUB_W31 0 -PRIM_MUL_W31 0 -PRIM_I31_TO_I 0 -PRIM_I_TO_I31 0 -PRIM_W31_TO_W 0 -PRIM_W_TO_W31 0 -PRIM_W31_TO_W_X 0 -PRIM_W_TO_I 0 -PRIM_FRESH_EXNAME 0 -PRIM_BYTETABLE_SUB 0 -PRIM_BYTETABLE_UPDATE 0 -PRIM_WORDTABLE_SUB 0 -PRIM_WORDTABLE_UPDATE 0 -PRIM_TABLE_SIZE 0 - -PRIM_IS_NULL 0 -GET_CONTEXT 0 - -CHECK_LINKAGE 1 diff --git a/src/Compiler/Backend/KAM/RESOLVE_LOCAL_LABELS.sml b/src/Compiler/Backend/KAM/RESOLVE_LOCAL_LABELS.sml deleted file mode 100644 index 4c1283251..000000000 --- a/src/Compiler/Backend/KAM/RESOLVE_LOCAL_LABELS.sml +++ /dev/null @@ -1,17 +0,0 @@ -(* Handlings of local labels and backpatching *) -(* Taken from the Moscow ML compiler *) - -signature RESOLVE_LOCAL_LABELS = - sig - type label - - val reset_label_table : unit -> unit - val define_label : label -> unit - val out_label_with_orig : int -> label -> unit - val out_label : label -> unit - - val imports : label list -> (int * label) list (* the ints are relative addresses to - * code positions that refer to the labels *) - val exports : label list -> (label * int) list (* returns relative addresses for the labels *) - end - diff --git a/src/Compiler/Backend/KAM/ResolveLocalLabels.sml b/src/Compiler/Backend/KAM/ResolveLocalLabels.sml deleted file mode 100644 index 8e917d0b7..000000000 --- a/src/Compiler/Backend/KAM/ResolveLocalLabels.sml +++ /dev/null @@ -1,86 +0,0 @@ -(* Handlings of local labels and backpatching *) -(* Taken from the Moscow ML compiler *) - -structure ResolveLocalLabels : RESOLVE_LOCAL_LABELS = - struct - structure BC = BuffCode - structure Labels = AddressLabels - structure M = IntStringFinMap - - fun die s = Crash.impossible ("ResolveLocalLabels." ^ s) - - type label = Labels.label - datatype label_definition = - Label_defined of int - | Label_undefined of (int * int) list (* aren't the two integers the same always? ME 2000-10-24 *) - - val label_table : label_definition M.map ref = ref M.empty - - fun reset_label_table () = label_table := M.empty - - fun define_label lbl = - let - val lbl_k = Labels.key lbl - fun define_label_in_map L = - let - val curr_pos = !BC.out_position - in - label_table := M.add (lbl_k, Label_defined curr_pos, !label_table); - case L of - [] => () - | _ => (* Backpatching the list L of pending labels: *) - (List.app (fn (pos,orig) => - (BC.out_position := pos; - BC.out_long_i (curr_pos - orig))) - L; - BC.out_position := curr_pos) - end - in - case M.lookup (!label_table) lbl_k - of NONE => define_label_in_map [] - | SOME (Label_defined _) => die ("define_label : label " ^ (Labels.pr_label lbl) ^ " already defined.") - | SOME (Label_undefined L) => define_label_in_map L - end - - fun out_label_with_orig orig lbl = - let - val lbl_k = Labels.key lbl - fun out_label L = - (label_table := M.add (lbl_k, Label_undefined ((!BC.out_position, orig) :: L), !label_table); - BC.out_long_i (#1 lbl_k)) (* instead of 0 - we put the label key as a place holder; used for - * data-labels in the KAM machine; mael 2004-03-17: How is this used?? For - * now, we just take the int-part of the name, but that probably won't work - * with the mlb-compilation technique, where the ints are not unique. *) - in - case M.lookup (!label_table) lbl_k - of NONE => out_label [] - | SOME (Label_defined def) => BC.out_long_i (def - orig) - | SOME (Label_undefined L) => out_label L - end - - fun out_label l = out_label_with_orig (!BC.out_position) l (* for relative jumps *) - - fun imports (labels: label list): (int * label) list = (* the ints are relative addresses to - * code positions that refers to the - * labels *) - let - fun each (l,acc) = - case M.lookup (!label_table) (Labels.key l) - of SOME (Label_undefined L) => - foldl (fn ((a,b),acc) => if a <> b then die "imports - no, the two integers are not always identical!" - else (a, l) :: acc) acc L - | SOME _ => die "imports - Label_undefined expected" - | NONE => die "imports - NONE" - in foldl each nil labels - end - - fun exports (labels: label list) : (label * int) list = (* returns relative addresses for the labels *) - let - fun each l = - case M.lookup (!label_table) (Labels.key l) - of SOME (Label_defined i) => (l,i) - | SOME _ => die "exports - Label_defined expected" - | NONE => die "exports - NONE" - in map each labels - end - end diff --git a/src/Compiler/Backend/PaML/BackendInfoPAML.sml b/src/Compiler/Backend/PaML/BackendInfoPAML.sml deleted file mode 100644 index bde98692f..000000000 --- a/src/Compiler/Backend/PaML/BackendInfoPAML.sml +++ /dev/null @@ -1,202 +0,0 @@ -functor BackendInfoPAML(structure Labels : ADDRESS_LABELS - structure Lvars : LVARS - structure Lvarset: LVARSET - sharing type Lvarset.lvar = Lvars.lvar - structure InstsPAML : INSTS_PAML - sharing type InstsPAML.lvar = Lvars.lvar - structure PP : PRETTYPRINT - structure Flags : FLAGS - structure Report : REPORT - sharing type Report.Report = Flags.Report - structure Crash : CRASH) : BACKEND_INFO = - struct - - structure I = InstsPAML - - fun die s = Crash.impossible ("BackendInfoPAML." ^ s) - - type label = Labels.label - type lvar = Lvars.lvar - type reg = I.reg - type lvarset = Lvarset.lvarset - type offset = int - - val init_clos_offset = 1 (* First offset in FN closure is 1 and code pointer is at offset 0 *) - val init_sclos_offset = 0 (* First offset in shared closure is 0 *) - val init_regvec_offset = 0 (* First offset in region vector is 0 *) - - (* From here downto Physical Registers is a direct copy of the - * code in HpPaRisc/BackendInfo.sml; 17/01-2000, Niels *) - - (******************************) - (* Runtime System Information *) - (******************************) - val pOff = 0 (* Offset for previous region pointer (p) in a region descriptor. *) - val aOff = 1 (* Offset for allocation pointer (a) in a region descriptor. *) - val bOff = 2 (* Offset for border pointer (b) in a region descriptor. *) - val fpOff = 3 (* Offset for first region page pointer (fp) in a region descriptor. *) - - val regionPageTotalSize = 63 (*ALLOCATABLE_WORDS_IN_REGION_PAGE*) + 1 (*HEADER_WORDS_IN_REGION_PAGE*) - val regionPageHeaderSize = 1 (*HEADER_WORDS_IN_REGION_PAGE*) - - (***********) - (* Tagging *) - (***********) - - fun pr_tag_w tag = "0X" ^ (Word32.fmt StringCvt.HEX tag) - (* For now, some tags are in integers but it should be eliminated; max size is then 2047 only 09/01/1999, Niels *) - fun pr_tag_i tag = "0X" ^ (Int.fmt StringCvt.HEX tag) - - fun gen_record_tag(s:int,off:int,i:bool,t:int) = - let - fun pw(s,w) = print (s ^ " is " ^ (Word32.fmt StringCvt.BIN w) ^ "\n") - val w0 = Word32.fromInt 0 - val size = Word32.fromInt s - val offset = Word32.fromInt off - val immovable = if i = true then Word32.fromInt 1 else Word32.fromInt 0 - val tag = Word32.fromInt t - fun or_bits(w1,w2) = Word32.orb(w1,w2) - fun shift_left(num_bits,w) = Word32.<<(w,Word.fromInt num_bits) - val w_size = shift_left(19,size) - val w_offset = or_bits(w_size,shift_left(6,offset)) - val w_immovable = or_bits(w_offset,shift_left(5,immovable)) - val w_tag = or_bits(w_immovable,tag) - in - w_tag - end - - fun gen_string_tag(s:int,i:bool,t:int) = - let - fun pw(s,w) = print (s ^ " is " ^ (Word32.fmt StringCvt.BIN w) ^ "\n") - val w0 = Word32.fromInt 0 - val size = Word32.fromInt s - val immovable = if i = true then Word32.fromInt 1 else Word32.fromInt 0 - val tag = Word32.fromInt t - fun or_bits(w1,w2) = Word32.orb(w1,w2) - fun shift_left(num_bits,w) = Word32.<<(w,Word.fromInt num_bits) - val w_size = shift_left(6,size) - val w_immovable = or_bits(w_size,shift_left(5,immovable)) - val w_tag = or_bits(w_immovable,tag) - in - w_tag - end - - val ml_true = 3 (* The representation of true *) - val ml_false = 1 (* The representation of false *) - val ml_unit = 1 (* The representation of unit *) - - fun tag_real(i:bool) = gen_record_tag(3,3,i,6) - fun tag_string(i:bool,size) = gen_string_tag(size,i,1) - fun tag_record(i:bool,size) = gen_record_tag(size,0,i,6) - fun tag_con0(i:bool,c_tag) = gen_string_tag(c_tag,i,2) - fun tag_con1(i:bool,c_tag) = gen_string_tag(c_tag,i,3) - fun tag_ref(i:bool) = gen_string_tag(0,i,5) - fun tag_clos(i:bool,size,n_skip) = gen_record_tag(size,n_skip,i,6) - fun tag_sclos(i:bool,size,n_skip) = gen_record_tag(size,n_skip,i,6) - fun tag_regvec(i:bool,size) = gen_record_tag(size,size,i,6) - fun tag_table(i:bool,size) = gen_string_tag(size,i,7) - fun tag_exname(i:bool) = gen_record_tag(2,2,i,6) - fun tag_excon0(i:bool) = gen_record_tag(1,0,i,6) - fun tag_excon1(i:bool) = gen_record_tag(2,0,i,6) - val tag_ignore = Word32.fromInt 0 - - val inf_bit = 1 (* We add 1 to an address to set the infinite bit. *) - val atbot_bit = 2 (* We add 2 to an address to set the atbot bit. *) - - val tag_values = Flags.lookup_flag_entry "tag_values" - val tag_integers = Flags.lookup_flag_entry "tag_integers" - - fun size_of_real () = if !tag_values then 4 else 2 - fun size_of_ref () = if !tag_values then 2 else 1 - fun size_of_record l = if !tag_values then List.length l + 1 else List.length l - fun size_of_reg_desc() = 4 - fun size_of_handle() = 4 - - val exn_DIV_lab = Labels.new_named("exnDIV_lab") (* Global exceptions are globally allocated. *) - val exn_MATCH_lab = Labels.new_named("exnMATCH_lab") - val exn_BIND_lab = Labels.new_named("exnBIND_lab") - val exn_OVERFLOW_lab = Labels.new_named("exn_OVERFLOW_lab") - val exn_INTERRUPT_lab = Labels.new_named("exn_INTERRUPT_lab") - val exn_MEMORY_lab = Labels.new_named("exp_MEMORY_lab") - - val toplevel_region_withtype_top_lab = Labels.new_named("reg_top") - val toplevel_region_withtype_bot_lab = Labels.new_named("reg_bot") - val toplevel_region_withtype_string_lab = Labels.new_named("reg_string") - val toplevel_region_withtype_real_lab = Labels.new_named("reg_real") - - (* Physical Registers *) - val all_regs = I.all_regs_as_lvs - fun is_reg lv = I.is_reg lv - fun lv_to_reg lv = I.lv_to_reg lv - val args_phreg = I.reg_args_as_lvs - val res_phreg = I.reg_res_as_lvs - val args_phreg_ccall = I.reg_args_ccall_as_lvs - val res_phreg_ccall = I.reg_res_ccall_as_lvs - val callee_save_phregs = I.callee_save_regs_mlkit_as_lvs - val callee_save_phregset = Lvarset.lvarsetof callee_save_phregs - fun is_callee_save phreg = Lvarset.member(phreg,callee_save_phregset) - val caller_save_phregs = I.caller_save_regs_mlkit_as_lvs - val caller_save_phregset = Lvarset.lvarsetof caller_save_phregs - fun is_caller_save phreg = Lvarset.member(phreg,caller_save_phregset) - fun pr_reg phreg = I.pr_reg phreg - fun reg_eq(reg1,reg2) = reg1 = reg2 - - val callee_save_ccall_phregs = I.callee_save_regs_ccall_as_lvs - val callee_save_ccall_phregset = Lvarset.lvarsetof callee_save_ccall_phregs - fun is_callee_save_ccall phreg = Lvarset.member(phreg,callee_save_ccall_phregset) - - val caller_save_ccall_phregs = I.caller_save_regs_ccall_as_lvs - val caller_save_ccall_phregset = Lvarset.lvarsetof caller_save_ccall_phregs - fun is_caller_save_ccall phreg = Lvarset.member(phreg,caller_save_ccall_phregset) - - (* The rest of the code is copied from HpPaRisc/BackendInfo.sml; 17/01-2000, Niels *) - - val init_frame_offset = 0 - - (* Jump Tables *) - val minCodeInBinSearch = 5 - val maxDiff = 10 - val minJumpTabSize = 5 - - (* Names For Primitive Functions *) - val EQUAL_INT = "__equal_int" - val MINUS_INT = "__minus_int" - val PLUS_INT = "__plus_int" - val MUL_INT = "__mul_int" - val NEG_INT = "__neg_int" - val ABS_INT = "__abs_int" - val LESS_INT = "__less_int" - val LESSEQ_INT = "__lesseq_int" - val GREATER_INT = "__greater_int" - val GREATEREQ_INT = "__greatereq_int" - val FRESH_EXN_NAME = "__fresh_exname" - val PLUS_FLOAT = "__plus_float" - val MINUS_FLOAT = "__minus_float" - val MUL_FLOAT = "__mul_float" - val DIV_FLOAT = "__div_float" - val NEG_FLOAT = "__neg_float" - val ABS_FLOAT = "__abs_float" - val LESS_FLOAT = "__less_float" - val LESSEQ_FLOAT = "__lesseq_float" - val GREATER_FLOAT = "__greater_float" - val GREATEREQ_FLOAT = "__greatereq_float" - - val prims = ["__equal_int", "__minus_int", "__plus_int", (* "__mul_int", *) (* treat millicode calls as C calls (e.g., mul) *) - "__neg_int", "__abs_int", "__less_int", "__lesseq_int", (* ; for def-use.. *) - "__greater_int", "__greatereq_int", "__fresh_exname", - "__plus_float", "__minus_float", "__mul_float", "__div_float", - "__neg_float", "__abs_float", "__less_float", "__lesseq_float", - "__greater_float", "__greatereq_float", "less_word__", "greater_word__", - "lesseq_word__", "greatereq_word__", "plus_word8__", "minus_word8__", - (*"mul_word8__",*) "and__", "or__", "xor__", "shift_left__", "shift_right_signed__", - "shift_right_unsigned__", "plus_word__", "minus_word__" (*, "mul_word__"*)] - - fun member n [] = false - | member n (n'::ns) = n=n' orelse member n ns - - fun is_prim name = member name prims - - val down_growing_stack : bool = true (* true for PAML code generation *) - val double_alignment_required : bool = false (* false for PAML code generation *) - - end diff --git a/src/Compiler/Backend/PaML/INSTS_PAML.sml b/src/Compiler/Backend/PaML/INSTS_PAML.sml deleted file mode 100644 index fcff3df33..000000000 --- a/src/Compiler/Backend/PaML/INSTS_PAML.sml +++ /dev/null @@ -1,132 +0,0 @@ -signature INSTS_PAML = - sig - - datatype reg = eax | ebx | ecx | edx | esi | edi | ebp | esp - | ah (* for float conditionals *) - | cl (* for shift operations *) - - val tmp_reg0 : reg (*=ecx*) - val tmp_reg1 : reg (*=ebp*) - - 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 *) - - val pr_ea : ea -> string - val eq_ea : ea * ea -> bool - - datatype inst = (* general instructions *) - movl of ea * ea - | pushl of ea - | leal of ea * ea - | popl of ea - | addl of ea * ea - | subl of ea * ea - | negl of ea - | imull of ea * ea - | notl of ea - | orl of ea * ea - | xorl of ea * ea - | andl of ea * ea - | andb 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 *) - - | fstpl of ea (* store float and pop float stack *) - | fldl 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 *) - | ret - | leave - - | dot_align of int (* pseudo instructions *) - | dot_globl of lab - | dot_text - | dot_data - | dot_byte of string - | dot_long 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_reg : reg -> string - val pr_lab : lab -> string - - (*-----------------------------------------------------------*) - (* Converting Between General Registers and Precolored Lvars *) - (* As Used In The Phases Preceeding Code Generation *) - (*-----------------------------------------------------------*) - type lvar - val is_reg : lvar -> bool - val lv_to_reg : lvar -> reg - val all_regs_as_lvs : lvar list - val reg_args_as_lvs : lvar list - val reg_res_as_lvs : lvar list - val reg_args_ccall_as_lvs : lvar list - val reg_res_ccall_as_lvs : lvar list - val callee_save_regs_mlkit_as_lvs : lvar list - val caller_save_regs_mlkit_as_lvs : lvar list - val callee_save_regs_ccall_as_lvs : lvar list - val caller_save_regs_ccall_as_lvs : lvar list - - type StringTree - val layout : AsmPrg -> StringTree - - end \ No newline at end of file diff --git a/src/Compiler/Backend/PaML/InstsPAML.sml b/src/Compiler/Backend/PaML/InstsPAML.sml deleted file mode 100644 index 988e5524e..000000000 --- a/src/Compiler/Backend/PaML/InstsPAML.sml +++ /dev/null @@ -1,296 +0,0 @@ -functor InstsX86(structure Labels : ADDRESS_LABELS - structure Lvars : LVARS - structure Crash : CRASH - structure PP : PRETTYPRINT) : INSTS_X86 = - struct - - fun die s = Crash.impossible("X86Inst." ^ s) - - datatype reg = eax | ebx | ecx | edx | esi | edi | ebp | esp - | ah | cl - - 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 *) - - 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 _ = false - - datatype inst = (* general instructions *) - movl of ea * ea - | leal of ea * ea - | pushl of ea - | popl of ea - | addl of ea * ea - | subl of ea * ea - | negl of ea - | imull of ea * ea - | notl of ea - | orl of ea * ea - | xorl of ea * ea - | andl of ea * ea - | andb of ea * ea - | sarl of ea * ea - | shrl of ea * ea (* unsigned *) - | sall of ea * ea - | cmpl of ea * ea - | btl of ea * ea - | btrl of ea * ea (* bit test and reset; sets carry flag *) - - | fstpl of ea (* store float and pop float stack *) - | fldl 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 *) - | ret - | leave - - | dot_align of int (* pseudo instructions *) - | dot_globl of lab - | dot_text - | dot_data - | dot_byte of string - | dot_long 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 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 ah = "%ah" - | pr_reg cl = "%cl" - - fun remove_ctrl s = "Lab" ^ String.implode (List.filter Char.isAlphaNum (String.explode s)) - - fun pr_lab (DatLab l) = remove_ctrl(Labels.pr_label l) - | pr_lab (LocalLab l) = "." ^ remove_ctrl(Labels.pr_label l) - | pr_lab (NameLab s) = s - | pr_lab (MLFunLab l) = "fun_" ^ 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 - | pr_ea (LA l) = "$" ^ 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 ^ ")" - - fun emit_insts (os, insts: inst list): unit = - let fun emit s = TextIO.output(os, s) - fun emit_bin (s, (ea1, ea2)) = (emit "\t"; emit s; emit " "; - emit(pr_ea ea1); emit ","; - emit(pr_ea ea2); emit "\n") - fun emit_unary(s, ea) = (emit "\t"; emit s; emit " "; emit(pr_ea ea); emit "\n") - fun emit_nullary s = (emit "\t"; emit s; emit "\n") - fun emit_jump(s,l) = (emit "\t"; emit s; emit " "; emit(pr_lab l); emit "\n") - fun emit_inst i = - case i - of movl a => emit_bin ("movl", a) - | leal a => emit_bin ("leal", a) - | pushl ea => emit_unary ("pushl", ea) - | popl ea => emit_unary ("popl", ea) - | addl a => emit_bin("addl", a) - | subl a => emit_bin("subl", a) - | negl ea => emit_unary("negl", 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) - | andb a => emit_bin("andb", 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) - - | fstpl ea => emit_unary("fstpl", ea) - | fldl ea => emit_unary("fldl", 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 "\n") - | 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) - | ret => emit "\tret\n" - | leave => emit "\tleave\n" - - | dot_align i => (emit "\t.align "; emit(Int.toString i); emit "\n") - | dot_globl l => (emit ".globl "; emit(pr_lab l); emit "\n") - | dot_text => emit ".text\n" - | dot_data => emit ".data\n" - | dot_byte s => (emit "\t.byte "; emit s; emit "\n") - | dot_long s => (emit "\t.long "; emit s; emit "\n") - | dot_double s => (emit "\t.double "; emit s; emit "\n") - | dot_string s => (emit "\t.string \""; emit s; emit "\"\n") - | dot_size (l, i) => (emit "\t.size "; emit(pr_lab l); emit ","; - emit(Int.toString i); emit "\n") - | lab l => (emit(pr_lab l); emit":\n") - | comment s => (emit " # "; emit s; emit " \n") - 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) - - (*-----------------------------------------------------------*) - (* Converting Between General Registers and Precolored Lvars *) - (* As Used In The Phases Preceeding Code Generation *) - (*-----------------------------------------------------------*) - type lvar = Lvars.lvar - local - structure LvarFinMap = Lvars.Map - - val regs = [eax,ebx,ecx,edx,esi,edi,ebp,esp] - val reg_lvs as [eax_lv,ebx_lv,ecx_lv,edx_lv,esi_lv,edi_lv,ebp_lv,esp_lv] = - map (fn r => Lvars.new_named_lvar (pr_reg r)) regs - val map_lvs_to_reg = LvarFinMap.fromList(ListPair.zip(reg_lvs,regs)) - in - val all_regs_as_lvs = 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 eax => eax_lv | ebx => ebx_lv | ecx => ecx_lv | edx => edx_lv - | esi => esi_lv | edi => edi_lv | ebp => ebp_lv | esp => esp_lv - | ah => die "reg_to_lv: ah not available for register allocation" - | cl => die "reg_to_lv: cl not available for register allocation" - - val reg_args = [eax,ebx,edi] - val reg_args_as_lvs = map reg_to_lv reg_args - val reg_res = [edi,ebx,eax] - val reg_res_as_lvs = map reg_to_lv reg_res - - val reg_args_ccall = [] - val reg_args_ccall_as_lvs = map reg_to_lv reg_args_ccall - val reg_res_ccall = [eax] - val reg_res_ccall_as_lvs = map reg_to_lv reg_res_ccall - - val callee_save_regs_mlkit = [] - val callee_save_regs_mlkit_as_lvs = map reg_to_lv callee_save_regs_mlkit - - val caller_save_regs_mlkit = [eax,ebx,edi,edx,esi] - val caller_save_regs_mlkit_as_lvs = map reg_to_lv caller_save_regs_mlkit - - val callee_save_regs_ccall = [] - val callee_save_regs_ccall_as_lvs = map reg_to_lv callee_save_regs_ccall - - (* tmp_reg0 and tmp_reg1 should not be in this list as they are never live across a C call *) - val caller_save_regs_ccall = [eax,ebx,edi,edx,esi] - val caller_save_regs_ccall_as_lvs = map reg_to_lv caller_save_regs_ccall - end - - val tmp_reg0 = ecx - val tmp_reg1 = ebp - - fun emit ({top_decls: top_decl list, - init_code: inst list, - static_data: inst list}, filename) = - let val os : TextIO.outstream = TextIO.openOut filename - 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 - type StringTree = PP.StringTree - fun layout _ = PP.LEAF "not implemented" - end diff --git a/src/Compiler/Backend/PrimName.sml b/src/Compiler/Backend/PrimName.sml index 5d5948a2f..e28c7eb83 100644 --- a/src/Compiler/Backend/PrimName.sml +++ b/src/Compiler/Backend/PrimName.sml @@ -141,7 +141,7 @@ datatype prim = Word32ub_to_int64ub_X | Word32ub_to_word64ub_X | - Exn_ptr | Fresh_exname | + Exn_ptr | Fresh_exname | Get_ctx | Bytetable_sub | Bytetable_size | Bytetable_update | Word_sub0 | Word_update0 | Table_size | @@ -309,7 +309,7 @@ local ("__word32ub_to_int64ub_X", Word32ub_to_int64ub_X), ("__word32ub_to_word64ub_X", Word32ub_to_word64ub_X), - ("__exn_ptr", Exn_ptr), ("__fresh_exname", Fresh_exname), + ("__exn_ptr", Exn_ptr), ("__fresh_exname", Fresh_exname), ("__get_ctx", Get_ctx), ("__bytetable_sub", Bytetable_sub), ("__bytetable_size", Bytetable_size), ("__bytetable_update", Bytetable_update), ("word_sub0", Word_sub0), ("word_update0", Word_update0), ("table_size", Table_size), ("__is_null", Is_null), @@ -680,6 +680,7 @@ fun pp_prim (p:prim) : string = | Exn_ptr => "Exn_ptr" | Fresh_exname => "Fresh_exname" + | Get_ctx => "Get_ctx" | Bytetable_sub => "Bytetable_sub" | Bytetable_size => "Bytetable_size" | Bytetable_update => "Bytetable_update" diff --git a/src/Compiler/Backend/X64/CodeGenUtilX64.sml b/src/Compiler/Backend/X64/CodeGenUtilX64.sml index f0ede08d3..a61253276 100644 --- a/src/Compiler/Backend/X64/CodeGenUtilX64.sml +++ b/src/Compiler/Backend/X64/CodeGenUtilX64.sml @@ -102,7 +102,7 @@ struct (********************************) (* Global Labels *) - val exn_ptr_lab = NameLab "exn_ptr" +(* 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 *) diff --git a/src/Compiler/Backend/X64/CodeGenX64.sml b/src/Compiler/Backend/X64/CodeGenX64.sml index 975578182..6fcaa0c02 100644 --- a/src/Compiler/Backend/X64/CodeGenX64.sml +++ b/src/Compiler/Backend/X64/CodeGenX64.sml @@ -32,6 +32,8 @@ struct fun die s = Crash.impossible ("CodeGenX64." ^ s) + val ctx_exnptr_offs = "8" + local (*******************) (* Code Generation *) @@ -528,7 +530,7 @@ struct end else C - fun alloc_region_prim(((place,phsize),offset),C) = + fun alloc_region_prim (((place,phsize),offset),C) = if region_profiling() then case phsize of LineStmt.WORDS 0 => C (* zero-sized finite region *) @@ -561,7 +563,8 @@ struct in base_plus_offset(rsp,WORDS(size_ff-offset-1),tmp_reg1, compile_c_call_prim(name, - [SS.PHREG_ATY tmp_reg1, + [SS.PHREG_ATY I.r14, (* evaluation context *) + SS.PHREG_ATY tmp_reg1, key place], NONE, size_ff,tmp_reg0(*not used*),C)) end @@ -582,7 +585,7 @@ struct 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, + compile_c_call_prim(name,[SS.PHREG_ATY I.r14, SS.PHREG_ATY tmp_reg1],NONE, size_ff,tmp_reg0(*not used*),C)) end fun dealloc_region_prim (((place,phsize),offset),C) = @@ -593,12 +596,12 @@ struct 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) + compile_c_call_prim("deallocateRegion",[SS.PHREG_ATY I.r14],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) + compile_c_call_prim("deallocateRegion",[SS.PHREG_ATY I.r14],NONE,size_ff,tmp_reg0(*not used*),C) in foldr alloc_region_prim (CG_lss(body,size_ff,size_ccf, @@ -613,7 +616,7 @@ struct (* 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 + 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)) @@ -626,11 +629,14 @@ struct 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) :: +(* I.movq(L exn_ptr_lab, R tmp_reg1) :: *) + I.movq(D(ctx_exnptr_offs,r14), 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)))) +(* I.movq(R tmp_reg1, L exn_ptr_lab) :: *) + I.movq(R tmp_reg1, D(ctx_exnptr_offs,r14)) :: + C)))) fun store_sp C = comment ("STORE SP: sp[offset+3] = sp", store_indexed(rsp,WORDS(size_ff-offset-1+3), R rsp,C)) @@ -639,7 +645,8 @@ struct fun restore_exn_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.movq(R tmp_reg1, L exn_ptr_lab) :: *) + I.movq(R tmp_reg1, D(ctx_exnptr_offs,r14)) :: 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) @@ -662,8 +669,8 @@ struct 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) + move_aty_into_reg(arg_aty,rsi,size_ff, (* arg1: context, arg2: exception value *) (* function never returns *) + maybe_align 0 (fn C => I.movq(R r14, R rdi) :: 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 @@ -864,6 +871,8 @@ struct move_reg_into_aty(tmp_reg0,d,size_ff, I.addq(I "1", R tmp_reg0) :: I.movq(R tmp_reg0, L exn_counter_lab) :: C) + | Get_ctx => + move_reg_into_aty(r14,d,size_ff,C) | _ => die ("unsupported prim with 0 args: " ^ PrimName.pp_prim name)) | [x] => let val arg = (x,d,size_ff,C) @@ -1193,7 +1202,8 @@ struct (*I.dot_globl call_closure_lab, (* The C function entry *) *) I.lab call_closure_lab] @ (map (fn r => I.push (R r)) callee_save_regs_ccall) - @ [I.movq(R rdi,R tmp_reg0)] + @ [I.subq(I "8", R rsp), (* align stack *) + I.movq(R rdi,R tmp_reg0)] (* now initialize thread local data to point to the threadinfo struct *) @ compile_c_call_prim("thread_init", [SS.PHREG_ATY tmp_reg0], SOME (SS.PHREG_ATY tmp_reg0), size_ff (* not used *), tmp_reg1, [I.movq(R tmp_reg0, R rdi), (* restore argument, which is passed through thread_init *) @@ -1209,7 +1219,7 @@ struct I.push(I"0") (* push dummy - for 16-byte alignment *) ] @ compile_c_call_prim("pthread_exit", [SS.PHREG_ATY tmp_reg0], NONE, size_ff (* not used *), tmp_reg1, - [I.pop(R rax), (* pop dummy - for 16-byte alignment *) + [I.addq(I "16", R rsp), (* adjust stack - for 16-byte alignment *) I.movq(I "0", R rax)] (* move result to %rax *) @ (map (fn r => I.pop (R r)) (List.rev callee_save_regs_ccall)) @ [I.ret]))) @@ -1225,31 +1235,33 @@ struct fun comp_c_call(all_args,res,C) = compile_c_call_prim(name, all_args, res, size_ff, tmp_reg1, C) 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.") - | _ => () + 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 *) + (* 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")) + let val all_args = + case name of + ":" => (case args of + a1::ar => a1 ::(rhos_for_result@ar) + | _ => die ("Dynamic liking requires a string as first argument.")) + | _ => (rhos_for_result@args) + in case res of + [] => comp_c_call(all_args, NONE, C) + | [res_aty] => comp_c_call(all_args, SOME res_aty, C) + | _ => die "CCall with more than one result variable" + end) end | LS.CCALL_AUTO{name, args, res} => @@ -1285,7 +1297,8 @@ struct I.dot_globl lab, (* The C function entry *) I.lab lab] @ (map (fn r => I.push (R r)) callee_save_regs_ccall) (* 5 regs *) - @ [I.movq (L clos_lab, R rax), (* load closure into ML arg 1 *) + @ [I.subq(I "8", R rsp), (* push dummy (align stack) *) + 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 (alignment) *) @@ -1293,7 +1306,7 @@ struct 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 (alignment) *) + I.addq(I "16", R rsp)] (* pop dummy x2 (align stack) *) @ (map (fn r => I.pop (R r)) (List.rev callee_save_regs_ccall)) @ [I.ret]) @@ -1489,7 +1502,8 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) 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, + compile_c_call_prim("uncaught_exception",[SS.PHREG_ATY r14, (* evaluation context *) + SS.PHREG_ATY arg_reg,SS.PHREG_ATY tmp_reg1, SS.PHREG_ATY tmp_reg0],NONE,0,tmp_reg1,C)))) end @@ -1505,7 +1519,7 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) end else C - fun raise_insts C = (* expects exception value in register rdi!! *) + fun raise_insts C = (* expects ctx in rdi and exception value in register rsi!! *) 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) @@ -1513,15 +1527,19 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) in I.dot_globl(NameLab "raise_exn") :: I.lab (NameLab "raise_exn") :: - I.movq (R rdi, R r15) :: (* move argument to callee-save register *) + I.movq (R rdi, R r14) :: (* reinstall context pointer *) + I.movq (R rsi, 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, +(* I.movq(L exn_ptr_lab, R tmp_reg1) :: *) + I.movq(D(ctx_exnptr_offs,r14), R tmp_reg1) :: + compile_c_call_prim("deallocateRegionsUntil",[SS.PHREG_ATY I.r14,SS.PHREG_ATY tmp_reg1],NONE,0,tmp_reg1, comment ("RESTORE EXN PTR", - I.movq(L exn_ptr_lab, R tmp_reg1) :: +(* I.movq(L exn_ptr_lab, R tmp_reg1) :: *) + I.movq(D(ctx_exnptr_offs,r14), R tmp_reg1) :: I.movq(D("16",tmp_reg1), R tmp_reg0) :: (* was:8 *) - I.movq(R tmp_reg0, L exn_ptr_lab) :: +(* I.movq(R tmp_reg0, L exn_ptr_lab) :: *) + I.movq(R tmp_reg0, D(ctx_exnptr_offs,r14)) :: comment ("INSTALL HANDLER EXN-ARGUMENT", I.movq(R r15, R arg_reg) :: @@ -1611,10 +1629,12 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) 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) + I.dot_quad "0" :: +*) + nil) val _ = add_static_data static_data (* args can only be tmp_reg0 and tmp_reg1; no arguments @@ -1673,7 +1693,7 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) fun proftick C = if region_profiling() then - ccall_stub("__proftick", "profileTick", [tmp_reg1], false, C) + ccall_stub("__proftick", "profileTick", [r14,tmp_reg1], false, C) (* first argument is the evaluation context *) else C fun overflow_stub C = @@ -1687,7 +1707,8 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) 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.movq(R r14, R rdi) :: (* arg1: context *) + I.movq(L(DatLab dl),R rsi):: (* arg2: exception value *) I.call(NameLab "raise_exn")::C') C stublab) end @@ -1710,8 +1731,8 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) (copy(rsp,r15, (* Save rsp in r15 (callee-save ccall register *) I.push(I "1") :: (* at this point we don't know whether the stack *) I.andq(I "0xFFFFFFFFFFFFFFF0", R rsp) :: (* is aligned, so we force align it here... *) - compile_c_call_prim("gc",[SS.PHREG_ATY tmp_reg0,SS.PHREG_ATY tmp_reg1],NONE,size_ff,rax, - copy(r15,rsp, (* Reposition stack *) + compile_c_call_prim("gc",[SS.PHREG_ATY r14,SS.PHREG_ATY tmp_reg0,SS.PHREG_ATY tmp_reg1],NONE,size_ff,rax, + copy(r15,rsp, (* Reposition stack; r14 is the context (first arg to gc) *) 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))))))))) @@ -1768,7 +1789,7 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_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 + if region_profiling() then I.movq(I (i2s region_id), R rdx) :: 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 *) @@ -1812,7 +1833,8 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) *) in I.subq(I(i2s sz_regdesc_bytes), R rsp) :: (* MAEL: maybe align *) - I.movq(R rsp, R rdi) :: + I.movq(R r14, R rdi) :: + I.movq(R rsp, R rsi) :: maybe_pass_region_id (region_id, I.call(NameLab name) :: C) @@ -1835,10 +1857,12 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) 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(L exn_ptr_lab, R tmp_reg1) :: *) + I.movq(D(ctx_exnptr_offs,r14), 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) :: +(* I.movq(R rsp, L exn_ptr_lab) :: *) + I.movq(R rsp, D(ctx_exnptr_offs,r14)) :: I.subq(I "8", R rsp) :: (* align *) C)) end @@ -1866,6 +1890,10 @@ val _ = List.app (fn lab => print ("\n" ^ (I.pr_lab lab))) (List.rev dat_labs) I.dot_globl (NameLab "code") :: I.lab (NameLab "code") :: I.push(I "1") :: (* 16-align stack *) + + (* Install argument context in context register *) + I.movq(R rdi, R r14) :: + (* Compute range of data space *) generate_data_begin_end(progunit_labs, diff --git a/src/Compiler/Backend/X64/InstsX64.sml b/src/Compiler/Backend/X64/InstsX64.sml index 8f2344f62..145dea14c 100644 --- a/src/Compiler/Backend/X64/InstsX64.sml +++ b/src/Compiler/Backend/X64/InstsX64.sml @@ -512,7 +512,7 @@ structure InstsX64: INSTS_X64 = 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_regs_ccall = [rbx,rbp,r12,r13,(*r14,*)r15] (* save r14 for context pointer; r15 used by raise_inst *) 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 diff --git a/src/Compiler/Backend/X86/.cvsignore b/src/Compiler/Backend/X86/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Compiler/Backend/X86/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Compiler/Backend/X86/CodeGenX86.sml b/src/Compiler/Backend/X86/CodeGenX86.sml deleted file mode 100644 index 7f16d4168..000000000 --- a/src/Compiler/Backend/X86/CodeGenX86.sml +++ /dev/null @@ -1,3361 +0,0 @@ - (* Generate Target Code *) - -functor CodeGenX86(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 = InstsX86.reg - where type label = AddressLabels.label) - : CODE_GEN = -struct - structure PP = PrettyPrint - structure Labels = AddressLabels - structure I = InstsX86 - 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 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 ("CodeGenX86." ^ 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_x86_asmcode", short=NONE, item=ref false, - menu=["Debug", "comments in x86 assembler code"], neg=false, - desc="Insert comments in x86 assembler code."} - - val jump_tables = true - val comments_in_asmcode = Flags.lookup_flag_entry "comments_in_x86_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_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 eax => 0 | ebx => 1 | ecx => 2 | edx => 3 - | esi => 4 | edi => 5 | ebp => 6 | esp => 7 - | ah => die "lv_to_reg_no: ah" - | al => die "lv_to_reg_no: al" - | cl => die "lv_to_reg_no: cl" - - (* 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 (4*w) - | offset_bytes (BYTES b) = i2s b - - fun copy(r1, r2, C) = if r1 = r2 then C - else I.movl(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.movl(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.movl(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.leal(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.movl(I (wordToStr w), D(offset_bytes offset,r)) :: C - - fun move_immed(0,R d,C) = I.xorl(R d, R d) :: C - | move_immed(x,d:ea,C) = I.movl(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.xorl(ea, ea) :: C - else I.movl(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 4, - I.lab num_lab, - I.dot_long(BI.pr_tag_w(BI.tag_word_boxed(true))), - I.dot_long x] - in I.movl(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(esp,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(esp,BYTES(size_ff*4-offset*4-4+BI.inf_bit),dst_reg,C) - | SS.REG_F_ATY offset => - base_plus_offset(esp,WORDS(size_ff-offset-1),dst_reg,C) - | SS.STACK_ATY offset => - load_indexed(R dst_reg,esp,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(esp,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.movl(LA lab, R d) :: C - | SS.STACK_ATY offset => store_indexed(esp, 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.movl(L lab, R d) :: C - | SS.STACK_ATY offset => - I.movl(L lab, R t) :: - store_indexed(esp, 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.movl(R s, L lab) :: C - | SS.INTEGER_ATY i => move_num_generic (#precision i, fmtInt i, L lab, C) - | SS.WORD_ATY w => move_num_generic (#precision w, fmtWord w, L lab, C) - | SS.UNIT_ATY => move_unit(L lab, C) -(* | SS.STACK_ATY offset => load_indexed(L lab, esp, WORDS(size_ff-offset-1), C) *) - | _ => move_aty_into_reg(src_aty,tmp1,size_ff, - I.movl(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 4 :: - I.lab string_lab :: - I.dot_long(BI.pr_tag_w(BI.tag_string(true,size(str)))) :: -(* - I.dot_long(Int.toString(size(str))) :: - I.dot_long "0" :: (* NULL pointer to next fragment. *) -*) - bytes) - in string_lab - end - - (* Generate a Data label *) - fun gen_data_lab lab = add_static_data [I.dot_data, - I.dot_align 4, - I.lab (DatLab lab), - I.dot_long (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) - in - case aty of - SS.PHREG_ATY s => I.movl(R s,ea()) :: C - | SS.INTEGER_ATY i => move_num_generic (#precision i, fmtInt i, ea(), C) - | SS.WORD_ATY w => move_num_generic (#precision w, fmtWord w, ea(), C) - | SS.UNIT_ATY => move_unit(ea(),C) - | _ => move_aty_into_reg(aty,t,size_ff, - store_indexed(b,n,R t,C)) - 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., esp-=4; esp[0] = aty (different than on hp) *) - (* size_ff is for esp before esp is moved. *) - fun push_aty(aty,t:reg,size_ff,C) = - let - fun default() = move_aty_into_reg(aty,t,size_ff, - I.pushl(R t) :: C) - in case aty - of SS.PHREG_ATY aty_reg => I.pushl(R aty_reg) :: C - | SS.INTEGER_ATY i => - if boxedNum (#precision i) then default() - else I.pushl(I (fmtInt i)) :: C - | SS.WORD_ATY w => - if boxedNum (#precision w) then default() - else I.pushl(I (fmtWord w)) :: C - | _ => default() - end - - (* pop(aty), i.e., aty=esp[0]; esp+=4 *) - (* size_ff is for sp after pop *) - fun pop_aty(SS.PHREG_ATY aty_reg,t:reg,size_ff,C) = I.popl(R aty_reg) :: C - | pop_aty(aty,t:reg,size_ff,C) = (I.popl(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.addl(R r, R t) :: C - | _ => move_aty_into_reg(arg,tmp,size_ff, I.addl(R tmp, R t) :: C) - - (* Push float on float stack *) - fun push_float_aty(float_aty, t, size_ff) = - let val disp = if BI.tag_values() then (*"8"*) "4" - else "0" - in fn C => case float_aty - of SS.PHREG_ATY x => I.fldl(D(disp, x)) :: C - | _ => move_aty_into_reg(float_aty,t,size_ff, - I.fldl(D(disp, t)) :: C) - end - - (* Pop float from float stack *) - fun pop_store_float_reg(base_reg,t:reg,C) = - if BI.tag_values() then - store_immed(BI.tag_real false, base_reg, WORDS 0, - I.fstpl (D( (*"8"*) "4",base_reg)) :: C) (* mael 2003-05-08 *) - else - I.fstpl (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 () = - if nargs < 1 then - die "callc_static_or_dynamic: Dynamic liking 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.movl (L fp, R eax) :: - I.cmpl (I "0",R eax) :: - I.je nfcall :: - I.lab fcall :: - I.addl (I "4",R esp) :: - I.call' (R eax) :: - I.jmp (L finish) :: - I.lab nfcall :: - I.subl (I "4", R esp) :: - I.movl (LA fp, R edx) :: - I.movl (R edx, D("0",esp)) :: - I.call fnlab :: - I.addl (I "4", R esp) :: - I.movl (L fp, R eax) :: - I.cmpl (I "0", R eax) :: - I.jne fcall:: - I.addl (I "4", R esp):: - I.call (NameLab "__raise_match"):: - I.jmp (L finish):: - I.dot_data:: - I.dot_align 4:: - I.dot_size (fp, 4):: - I.lab fp :: - I.dot_long "0" :: - I.dot_text :: - I.lab finish :: C - end - | _ => I.call(NameLab name) :: C - in - - (* push_args: general function for pushing arguments. - * size_ff increases when new arguments are pushed on the - * stack; the arguments are placed on the stack in reverse - * order. *) - - val align16 = true - - fun push_args push_arg size_ff tmp (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.addl(I (i2s (4* (case name of ":" => n-1 | _ => n))), R esp) :: C - - 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.leal(D(i2s(4*nargs), esp), R tmp) :: (* tmp = esp + 4n; memoize esp as it should be restored after call *) - I.subl(I(i2s(4*(nargs+5))), R esp) :: (* esp = esp - 16 - 4 - 4n ; alignment *) - I.andl(I "0xFFFFFFF0", R esp) :: (* esp = esp & 0xFFFFFFF0; alignment *) - I.addl(I(i2s(4*(nargs+1))), R esp) :: (* make room for args to be pushed, so that once the args are pushed, the stack is aligned *) - I.pushl(R tmp) :: - iterl (fn (i,C) => - I.movl(D(i2s(~4*i), tmp), R tmp1) :: (* notice: for x86, esp points to the last slot used *) - I.pushl(R tmp1) :: C - ) - C nargs - end - - fun needs_align n = - I.sysname() = "Darwin" - - fun restore_stack_alignment (nargs, C) = - let val tmp = tmp_reg0 - in I.movl(D(i2s(4*nargs), esp), R tmp) :: (* notice: for x86, esp points to the last slot used *) - I.movl(R tmp, R esp) :: - C - end - - fun callc push_arg size_ff dynlinklab tmp name args C = - let val nargs = List.length args - in push_args push_arg size_ff tmp - (args, - if needs_align name then - align (nargs, - callc_static_or_dynamic (name, nargs, NameLab dynlinklab, - restore_stack_alignment (nargs, C))) - else - callc_static_or_dynamic (name, nargs, NameLab dynlinklab, - pop_args name nargs C) - ) - end - - fun compile_c_call_prim (name:string, args:SS.Aty list, opt_ret:SS.Aty option, size_ff:int, tmp:reg, C) = - let - (* val _ = print ("CodeGen: Compiling C Call - " ^ name ^ "\n") *) - fun push_arg(aty,size_ff,C) = push_aty(aty,tmp,size_ff,C) - (* With dynamic linking there must be at least one argument (the name to be bound). - * This name is poped off the stack before the function is called, therefore this - * is okay.. *) - fun store_ret(SOME d,C) = move_reg_into_aty(eax,d,size_ff,C) - | store_ret(NONE,C) = C - in callc push_arg size_ff "localResolveLibFnManual" tmp name args ( - 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. *) - fun compile_c_call_auto (name,args,opt_res,size_ff,tmp,C) = - let - fun push_bool (aty,size_ff,C) = - move_aty_into_reg(aty,tmp,size_ff, - I.shrl(I "1", R tmp) :: - I.pushl(R tmp) :: C) - - fun push_int (aty,size_ff,C) = - if BI.tag_values() then - move_aty_into_reg(aty,tmp,size_ff, - I.shrl(I "1", R tmp) :: - I.pushl(R tmp) :: C) - else push_aty(aty,tmp,size_ff,C) - - fun push_foreignptr (aty,size_ff,C) = - if BI.tag_values() then - case aty of - SS.PHREG_ATY r => (I.leal(D("-1", r), R tmp) :: - I.pushl(R tmp) :: C) - | _ => move_aty_into_reg(aty,tmp,size_ff, - I.leal(D("-1", tmp), R tmp) :: - I.pushl(R tmp) :: C) - else push_aty(aty,tmp,size_ff,C) - - fun push_chararray (aty,size_ff,C) = - case aty of - SS.PHREG_ATY r => (I.leal(D("4", r), R tmp) :: - I.pushl(R tmp) :: C) - | _ => move_aty_into_reg(aty,tmp,size_ff, - I.leal(D("4", tmp), R tmp) :: - I.pushl(R tmp) :: C) - - fun push_arg ((aty,ft:LS.foreign_type),size_ff,C) = - let val push_fun = case ft - of LS.Bool => push_bool - | LS.Int => push_int - | LS.ForeignPtr => push_foreignptr - | LS.CharArray => push_chararray - | LS.Unit => die "CCALL_AUTO.Unit type in argument not supported" - in push_fun(aty,size_ff,C) - end - - fun tag_bool_result (reg,C) = I.leal(DD("1", reg, reg, ""), R reg) :: C - - fun maybe_tag_int_result (reg,C) = - if BI.tag_values() then I.leal(DD("1", reg, reg, ""), R reg) :: C - else C - - fun maybe_tag_foreignptr_result (reg,C) = - if BI.tag_values() then I.leal(D("1", reg), R reg) :: 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 (eax, move_reg_into_aty(eax,aty,size_ff,C)) - in callc push_arg size_ff "localResolveLibFnAuto" tmp name args ( - 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_long ("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.movl(D("0",tmp_reg1),R tmp_reg1) :: (* tmp_reg1 = gc_flag *) -*) - I.cmpl(I "1", L time_to_gc_lab) :: - I.jne l :: - I.movl(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.pushl(I (i2s size_ccf)) :: - I.pushl(I (i2s size_rcf)) :: - I.pushl(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.pushl(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.movl(I (i2s pp), D("0",tmp_reg1)) :: (* first word is pp *) - I.movl(I (i2s n0), D("4",tmp_reg1)) :: (* second word is object size *) - I.leal(D (i2s (4*BI.objectDescSizeP), tmp_reg1), R tmp_reg1) :: C (* make tmp_reg1 point at object *) - else C - in - copy(t,tmp_reg1, - I.pushl(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 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.movl(I (i2s pp), D("0",tmp_reg1)) :: (* first word is pp *) - I.movl(I (i2s n0), D("4",tmp_reg1)) :: (* second word is object size *) - I.leal(D (i2s (4*(BI.objectDescSizeP-1)), tmp_reg1), R t) :: C (* make tmp_reg1 point at - * word before object *) - else - I.leal(D("-4",tmp_reg1), R t) :: C (* make tmp_reg1 point at - * word before object *) - in - copy(t,tmp_reg1, - I.pushl(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.orl(I "2", R dst_reg) :: C - - fun clear_atbot_bit(dst_reg:reg,C) = - I.btrl (I "1", R dst_reg) :: C - - fun set_inf_bit(dst_reg:reg,C) = - I.orl(I "1", R dst_reg) :: C - - fun set_inf_bit_and_atbot_bit(dst_reg:reg,C) = - I.orl(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(esp,BYTES(size_ff*4-offset*4-4(*+BI.inf_bit*)),dst_reg, - set_inf_bit(dst_reg,C)) - | SS.REG_F_ATY offset => base_plus_offset(esp,WORDS(size_ff-offset-1),dst_reg,C) - | SS.STACK_ATY offset => load_indexed(R dst_reg,esp,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.movl(I(i2s pp), D("-8", obj_ptr)) :: C - 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.btl(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.btl(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.btl (I "0", R dst_reg) :: (* inf bit set? *) - I.jnc finite_lab :: - I.btl (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.btl(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.btl(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.btl (I "0", R dst_reg) :: (* inf bit set? *) - I.jnc cont_lab :: - I.btl (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(esp,BYTES(size_ff*4-offset_reg_i*4-4(*+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(esp,BYTES(size_ff*4-offset_reg_i*4-4(*+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.btl(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.btl(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.btl (I "0", R t) :: (* Is region infinite? *) - I.jnc default_lab :: - I.btl (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.cmpl(I (intToStr i),opr) :: I.jne lab :: C - fun if_less_than_go_lab (lab,i,C) = I.cmpl(I (intToStr i),opr) :: I.jl lab :: C - fun if_greater_than_go_lab (lab,i,C) = I.cmpl(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.movl(opr, R tmp_reg0) :: - I.sall(I "2", R tmp_reg0) :: - I.jmp(D(intToStr(~4*sel) ^ "+" ^ I.pr_lab lab, tmp_reg0)) :: - rem_dead_code C), - fn (lab,C) => I.dot_long (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("4", 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.movl(D("4",y_reg), R tmp_reg1) :: - I.movl(D("4",x_reg), R tmp_reg0) :: - I.cmpl(R tmp_reg1, R tmp_reg0) :: C - else I.cmpl(R y_reg, R x_reg) :: C - in - x_C( - y_C( - compare ( - jump true_lab :: - I.movl(I (i2s BI.ml_false), R d_reg) :: - I.jmp(L cont_lab) :: - I.lab true_lab :: - I.movl(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 y_reg, R 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.movl(D("4", y_reg), R tmp_reg1) :: - I.movl(D("4", x_reg), R tmp_reg0) :: - I.cmpl(R tmp_reg1, R 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.addl(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 tmp_reg1, R 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 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 tmp_reg1) :: (* t1 = untag y *) - copy(x_reg, tmp_reg0, I.sarl(I "1", R tmp_reg0) :: (* t0 = untag x *) - I.addl(R tmp_reg0, R tmp_reg1) :: (* t1 = t1 + t0 *) - copy(tmp_reg1, d_reg, -(* - I.sall(I "1", R d_reg) :: (* d = tag d *) - I.addl(I "1", R d_reg) :: -*) I.leal(DD("1", d_reg, d_reg, ""), R d_reg) :: - I.sarl(I "1", R d_reg) :: (* d = untag d *) - I.cmpl(R d_reg, R tmp_reg1) :: - I.jne (NameLab "__raise_overflow") :: -(* - I.sall(I "1", R d_reg) :: (* d = tag d *) - I.addl(I "1", R d_reg) :: -*) I.leal(DD("1", d_reg, d_reg, ""), R d_reg) :: - C')))))) - else - (x_C(y_C( - copy(y_reg, tmp_reg1, - copy(x_reg, d_reg, - I.addl(R tmp_reg1, R 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 d_reg) :: - I.subl(I "1", R tmp_reg1) :: - I.imull(R tmp_reg1, R d_reg) :: - check_ovf ( - I.addl(I "1", R d_reg) :: - check_ovf C') - else - I.imull(R tmp_reg1, R 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 d_reg) :: jump_overflow C else C - in x_C(copy(x_reg, d_reg, - I.negl (R 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 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 d_reg) :: jump_overflow C else C - in - x_C(copy(x_reg,d_reg, - I.cmpl(I "0", R d_reg) :: - I.jge cont_lab :: - I.negl (R 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 tmp_reg0) :: - I.jge cont_lab :: - I.negl (R 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.btl(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 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 d_reg) :: - jump_overflow ( - I.addl(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.btl(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 d_reg) :: - jump_overflow ( - I.addl(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.sall(I "1", R d_reg) :: - I.addl(I "1", R d_reg) :: -*) I.leal(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 = push_float_aty(x, tmp_reg0, size_ff) - val y_C = push_float_aty(y, tmp_reg0, size_ff) - 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 :: - b_C(pop_store_float_reg(b_reg,tmp_reg1, - copy(b_reg,d_reg, C'))))) - end - - fun addf_kill_tmp01 a = bin_float_op_kill_tmp01 I.faddp a - fun subf_kill_tmp01 a = bin_float_op_kill_tmp01 I.fsubp a - fun mulf_kill_tmp01 a = bin_float_op_kill_tmp01 I.fmulp a - fun divf_kill_tmp01 a = bin_float_op_kill_tmp01 I.fdivp a - - fun unary_float_op_kill_tmp01 finst (b,x,d,size_ff,C) = - let val x_C = push_float_aty(x, tmp_reg0, size_ff) - 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(finst :: - b_C(pop_store_float_reg(b_reg,tmp_reg1, - copy(b_reg,d_reg, C')))) - end - - fun negf_kill_tmp01 a = unary_float_op_kill_tmp01 I.fchs a - fun absf_kill_tmp01 a = unary_float_op_kill_tmp01 I.fabs a - - datatype cond = LESSTHAN | LESSEQUAL | GREATERTHAN | GREATEREQUAL - - fun cmpf_kill_tmp01 (cond,x,y,d,size_ff,C) = - let val x_C = push_float_aty(x, tmp_reg0, size_ff) - val y_C = push_float_aty(y, tmp_reg0, 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" - val (mlTrue, mlFalse, cond_code, jump, push_args) = (* from gcc experiments *) - case cond - of LESSTHAN => (BI.ml_true, BI.ml_false, "69", I.je, x_C o y_C) - | LESSEQUAL => (BI.ml_true, BI.ml_false, "5", I.je, x_C o y_C) - | GREATERTHAN => (BI.ml_false, BI.ml_true, "69", I.jne, y_C o x_C) - | GREATEREQUAL => (BI.ml_false, BI.ml_true, "5", I.jne, y_C o x_C) - in - push_args(I.fcompp :: - I.movl(R eax, R tmp_reg1) :: (* save eax *) - I.fnstsw :: - I.andb(I cond_code, R ah) :: - I.movl(R tmp_reg1, R eax) :: (* restore eax *) - jump true_lab :: - I.movl(I (i2s mlFalse), R d_reg) :: - I.jmp(L cont_lab) :: - I.lab true_lab :: - I.movl(I (i2s mlTrue), 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 tmp_reg1, R 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.orl(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 tmp_reg1, R 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 tmp_reg0, R 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 subl *) - - 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 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.btl(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,tmp_reg0,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, - y_C( - copy(y_reg,ecx, (* tmp_reg0 = ecx, see InstsX86.sml *) - I.sarl (I "1", R ecx) :: (* untag y: y >> 1 *) - inst(R cl, R tmp_reg1) :: - 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 enablen; 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 enablen; 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 enablen; 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 = %ecx*) - let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) - val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg0,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.sarl (I "1", R ecx) :: C (* y >> 1 *) - else C - in - if tag then (* 1 + ((x - 1) << (y >> 1)) *) - x_C(y_C( - copy(y_reg, ecx, - copy(x_reg, d_reg, - I.decl (R d_reg) :: (* x - 1 *) - untag_y ( (* y >> 1 *) - I.sall (R cl, R d_reg) :: (* << *) - I.incl (R d_reg) :: C'))))) (* 1 + *) - else - x_C(y_C( - copy(y_reg, ecx, - copy(x_reg, d_reg, - I.sall(R cl, R d_reg) :: C')))) - end - - fun shift_right_signed_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = (*tmp_reg0 = %ecx*) - let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) - val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg0,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.sarl (I "1", R ecx) :: C (* y >> 1 *) - else C - in - if tag then (* 1 | ((x) >> (y >> 1)) *) - x_C(y_C( - copy(y_reg, ecx, - copy(x_reg, d_reg, - untag_y ( (* y >> 1 *) - I.sarl (R cl,R d_reg) :: (* x >> *) - I.orl (I "1", R d_reg) :: C'))))) (* 1 | *) - else - x_C(y_C( - copy(y_reg, ecx, - copy(x_reg, d_reg, - I.sarl(R cl, R d_reg) :: C')))) - end - - fun shift_right_unsigned_word_kill_tmp01 {tag} (x,y,d,size_ff,C) = (*tmp_reg0 = %ecx*) - let val (x_reg,x_C) = resolve_arg_aty(x,tmp_reg1,size_ff) - val (y_reg,y_C) = resolve_arg_aty(y,tmp_reg0,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.sarl (I "1", R ecx) :: C (* y >> 1 *) - else C - in - if tag then (* 1 | ((unsigned long)(x) >> (y >> 1)) *) - x_C(y_C( - copy(y_reg, ecx, - copy(x_reg, d_reg, - untag_y ( (* y >> 1 *) - I.shrl (R cl,R d_reg) :: (* (unsigned long)x >> *) - I.orl (I "1", R d_reg) :: C'))))) (* 1 | *) - else - x_C(y_C( - copy(y_reg, ecx, - copy(x_reg, d_reg, - I.shrl(R cl, R 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, ecx, (* tmp_reg0 = %ecx *) - I.sarl (I "1", R ecx) :: (* i >> 1 *) - I.movzbl(DD("4",t_reg,ecx,"1"), R d_reg) :: -(* - I.sall(I "1", R d_reg) :: (* d = tag d *) - I.addl(I "1", R d_reg) :: -*) I.leal(DD("1", d_reg, d_reg, ""), R d_reg) :: - C'))) - else - t_C(i_C( - I.movzbl(DD("4",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.sarl (I "1", R tmp_reg1) :: (* untag i: tmp_reg1 >> 1 *) - I.addl(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) - move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 (%ecx) = x *) - I.sarl (I "1", R tmp_reg0) :: (* untag x: tmp_reg0 >> 1 *) - I.movb(R cl, D("4", tmp_reg1)) :: (* *(tmp_reg1+4) = %cl *) - 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 cl, DD("4", t_reg, i_reg, "1")) :: (*tmp_reg0=%ecx*) - 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.addl(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) - move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 (%ecx) = x *) - I.movb(R cl, D("4", tmp_reg1)) :: (* *(tmp_reg1+4) = %cl *) - 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.movl(D("0",t_reg), R d_reg) :: - I.sarl (I "6", R d_reg) :: (* d >> 6: remove tag (Tagging.h) *) -(* - I.sall(I "1", R d_reg) :: (* d = tag d *) - I.addl(I "1", R d_reg) :: -*) I.leal(DD("1", d_reg, d_reg, ""), R d_reg) :: - C') - else - t_C( - I.movl(D("0",t_reg), R d_reg) :: - I.sarl (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.sarl*) I.sarl (I "1", R tmp_reg0) :: (* i >> 1 *) - I.movl(DD("4",t_reg,tmp_reg0,"4"), 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.movl(DD("4",t_reg,i_reg,"4"), 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.sarl (I "1", R tmp_reg0) :: - I.movl(R x_reg, DD("4", t_reg, tmp_reg0, "4")) :: - 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.sarl (I "1", R tmp_reg1) :: (* untag i: tmp_reg1 >> 1 *) - I.sall(I "2", R tmp_reg1) :: (* i << 2 *) - move_aty_into_reg(t,tmp_reg0,size_ff, (* tmp_reg0 = t *) - I.addl(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) - move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 = x *) - I.movl(R tmp_reg0, D("4", tmp_reg1)) :: (* *(tmp_reg1+4) = 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.movl(R x_reg, DD("4", t_reg, i_reg, "4")) :: C) - | SOME _ => die "word_update0_2" - | NONE => - move_aty_into_reg(i,tmp_reg1,size_ff, (* tmp_reg1 = i *) - I.imull(I "4", R tmp_reg1) :: (* i << 2 *) - move_aty_into_reg(t,tmp_reg0,size_ff, (* tmp_reg0 = t *) - I.addl(R tmp_reg0, R tmp_reg1) :: (* tmp_reg1 += tmp_reg0 *) - move_aty_into_reg(x,tmp_reg0,size_ff, (* tmp_reg0 = x *) - I.movl(R tmp_reg0, D("4", tmp_reg1)) :: (* *(tmp_reg1+4) = 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.dot_align 8, *) - I.lab float_lab, - I.dot_long(BI.pr_tag_w(BI.tag_real(true))), - (* I.dot_long "0", (* dummy *) *) - I.dot_double str] - else - add_static_data [I.dot_data, - (* I.dot_align 8, *) - 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.movl(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.orl(I "1", R reg_for_result) :: C') - | 2 => move_aty_into_reg(arg,reg_for_result,size_ff, - I.orl(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.movl(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.movl(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.movl(I "3", R tmp_reg0) :: - I.notl(R tmp_reg0) :: - I.andl(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.movl(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))) - | LS.FLUSH(aty,offset) => comment_fn (fn () => "FLUSH: " ^ pr_ls ls, - store_aty_in_reg_record(aty,tmp_reg1,esp,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,esp,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 "4" 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.movl(D(offset_codeptr,opr_reg), R tmp_reg1) :: (* Fetch code label from closure *) - base_plus_offset(esp,WORDS(size_ff+size_ccf),esp, (* 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.movl(D(offset_codeptr,tmp_reg1), R tmp_reg1) :: (* Fetch code label from closure *) - base_plus_offset(esp,WORDS(size_ff+size_ccf),esp, (* 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 "4" else "0" - val (spilled_args,spilled_res,return_lab_offset) = - 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.movl(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, (* esp is now pointing after the call *) - I.movl(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(esp,WORDS(~size_rcf),esp, (* Move esp after rcf *) - I.pushl(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, esp, WORDS (n-1), - store_indexed(esp, 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(esp,WORDS(size_ff+size_ccf),esp, - 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,return_lab_offset) = - 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(esp,WORDS(~size_rcf),esp, (* Move esp after rcf *) - I.pushl(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, esp, 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(esp,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(esp,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(esp,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 expPtr. *) - (* 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,esp,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.movl(LA handl_return_lab, R tmp_reg1) :: - store_indexed(esp,WORDS(size_ff-offset-1), R tmp_reg1,C)) - fun store_exn_ptr C = - comment ("STORE EXN PTR: sp[offset+2] = exnPtr", - I.movl(L exn_ptr_lab, R tmp_reg1) :: - store_indexed(esp,WORDS(size_ff-offset-1+2), R tmp_reg1, - comment ("CALC NEW expPtr: expPtr = sp-size_ff+offset+size_of_handle", - base_plus_offset(esp,WORDS(size_ff-offset-1(*-BI.size_of_handle()*)),tmp_reg1, (*hmmm *) - I.movl(R tmp_reg1, L exn_ptr_lab) :: C)))) - fun store_sp C = - comment ("STORE SP: sp[offset+3] = sp", - store_indexed(esp,WORDS(size_ff-offset-1+3), R esp,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,esp,WORDS(size_ff-offset-1+2), - I.movl(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} => - push_aty(arg_aty,tmp_reg0,size_ff, - I.call (NameLab "raise_exn") :: rem_dead_code C) (* function never returns *) - | 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 CodeGenX86! *) - 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.andl(I "3", R tmp_reg1) :: - I.cmpl(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.movl(L exn_counter_lab, R tmp_reg0) :: - move_reg_into_aty(tmp_reg0,aty,size_ff, - I.addl(I "1", R tmp_reg0) :: - I.movl(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 _ = - 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 "4" 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 4, - 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_long (i2s BI.ml_unit), - I.dot_text, - I.dot_globl lab, (* The C function entry *) - I.lab lab, - I.pushl (R ebp), (* save %ebp *) - I.movl(R esp, R ebp)] (* load argument into %ebx *) - @ (map (fn r => I.pushl (R r)) [ebx,edi,esi]) - @ [I.movl(D("8",ebp),R ebx), - I.movl(L clos_lab, R eax), (* load closure into %eax*) - - I.movl(D(offset_codeptr,eax), R ebp), (* extract code pointer into %ebp *) - I.pushl (LA return_lab), (* push return address *) - I.jmp (R ebp), (* call ML function *) - I.lab return_lab, - I.movl(R edi, R eax)] (* result is in %edi *) - @ (map (fn r => I.popl (R r)) [esi,edi,ebx]) (* I found a calling C convention at * - * http://www.agner.org/assem/calling_conventions.pdf *) - @ [I.popl(R ebp), (* restore %ebp *) - I.ret]) - - fun push_callersave_regs C = - foldl (fn (r, C) => I.pushl(R r) :: C) C caller_save_regs_ccall - fun pop_callersave_regs C = - foldr (fn (r, C) => I.popl(R r) :: C) C caller_save_regs_ccall - - in comment_fn (fn () => "EXPORT: " ^ pr_ls ls, - store_in_label(aty,clos_lab,tmp_reg1,size_ff, - I.movl (LA lab, R tmp_reg0) :: - I.movl (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.cmpl(R esp, L stack_min) :: - I.jl labCont :: - I.movl(R esp, 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.movl(L maxStackLab, R tmp_reg0) :: (* The stack grows downwards!! *) - I.cmpl(R esp, R tmp_reg0) :: - I.jl labCont :: (* if ( esp < *maxStack ) { *) - I.movl(R esp, L maxStackLab) :: (* *maxStack = esp ; *) - I.movl(L (NameLab "regionDescUseProfInf"), R tmp_reg0) :: (* maxProfStack = *) - I.addl(L (NameLab "regionDescUseProfFin"), R tmp_reg0) :: (* regionDescUseProfInf *) - I.addl(L (NameLab "allocProfNowFin"), R tmp_reg0) :: (* + regionDescUseProfFin *) - I.movl(R tmp_reg0, L (NameLab "maxProfStack")) :: (* + allocProfNowFin ; *) - I.lab labCont :: (* } *) - I.movl(L timeToProfLab, R tmp_reg0) :: (* if ( timeToProfile ) *) - I.cmpl(I "0", R tmp_reg0) :: (* call __proftick(esp); *) - I.je labCont2 :: - I.movl (R esp, R tmp_reg1) :: (* proftick assumes argument in tmp_reg1 *) - I.pushl (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(esp,WORDS(size_ff+size_ccf),esp, - I.popl (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(esp,WORDS(~size_ff),esp, - 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_x86_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 "[X86 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 x86_prg = {top_decls = foldr (fn (func,acc) => CG_top_decl func :: acc) [] ss_prg, - init_code = init_x86_code(), - static_data = static_data main_lab} - val _ = chat "]\n" - in - x86_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, 4) :: C - in - I.dot_globl (DatLab l) :: - I.dot_data :: - I.dot_align 4 :: - maybe_dotsize (I.lab (DatLab l) :: - I.dot_long "0" :: 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.movl (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 - foldr (fn (l,acc) => I.pushl(LA l) :: acc) - (I.pushl (I (i2s (List.length labs))) :: - I.movl(R esp, L data_lab_ptr_lab) :: C) labs - else C - - - fun raise_insts C = (* expects exception value on stack!! *) - 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 "4" else "0" - in - I.dot_globl(NameLab "raise_exn") :: - I.lab (NameLab "raise_exn") :: - - comment ("DEALLOCATE REGIONS UNTIL", - I.movl(L exn_ptr_lab, R tmp_reg1) :: - compile_c_call_prim("deallocateRegionsUntil_X86",[SS.PHREG_ATY tmp_reg1],NONE,0,tmp_reg1, - - comment ("RESTORE EXN PTR", - I.movl(L exn_ptr_lab, R tmp_reg1) :: - I.movl(D("8",tmp_reg1), R tmp_reg0) :: - I.movl(R tmp_reg0, L exn_ptr_lab) :: - - comment ("FETCH HANDLER EXN-ARGUMENT", - I.movl(D("4",esp), R arg_reg) :: - - comment ("RESTORE ESP AND PUSH RETURN LAB", - I.movl(D("12", tmp_reg1), R esp) :: (* Restore sp *) - I.pushl(D("0", tmp_reg1)) :: (* Push Return Lab *) - - comment ("JUMP TO HANDLE FUNCTION", - I.movl(D("4", tmp_reg1), R clos_reg) :: (* Fetch Closure into Closure Argument Register *) - I.movl(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 4, - I.dot_globl exn_lab, - I.lab exn_lab, - I.dot_long(BI.pr_tag_w(BI.tag_exname(true))), - I.dot_long "0", (*dummy for pointer to next word*) - I.dot_long(BI.pr_tag_w(BI.tag_excon0(true))), - I.dot_long(i2s n), - I.dot_long "0" (*dummy for pointer to string*), - I.dot_data, - I.dot_align 4, - I.dot_globl exn_flush_lab, - I.lab exn_flush_lab, (* The Primitive Exception is Flushed at this Address *) - I.dot_long "0"] - else - add_static_data [I.dot_data, - I.dot_align 4, - I.dot_globl exn_lab, - I.lab exn_lab, - I.dot_long "0", (*dummy for pointer to next word*) - I.dot_long(i2s n), - I.dot_long "0", (*dummy for pointer to string*) - I.dot_data, - I.dot_align 4, - I.dot_globl exn_flush_lab, - I.lab exn_flush_lab, (* The Primitive Exception is Flushed at this Address *) - I.dot_long "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.movl(R tmp_reg0, R tmp_reg1) :: - I.addl(I "8", R tmp_reg1) :: - I.movl(R tmp_reg1, D("4",tmp_reg0)) :: - load_label_addr(string_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - I.movl(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.movl(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.movl(R tmp_reg0, R tmp_reg1) :: - I.addl(I "4", R tmp_reg1) :: - I.movl(R tmp_reg1,D("0",tmp_reg0)) :: - load_label_addr(string_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, - I.movl(R tmp_reg1,D("8",tmp_reg0)) :: - load_label_addr(exn_flush_lab,SS.PHREG_ATY tmp_reg1,tmp_reg1,0, (* Now flush the exception *) - I.movl(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_long (i2s initial_exnname_counter) :: - - I.dot_globl exn_ptr_lab :: - I.lab exn_ptr_lab :: (* The Global Exception Pointer *) - I.dot_long "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! *) - fun ccall_stub(stubname, cfunction, args, res, C) = (* result in tmp_reg1 if ret=true *) - let - fun push_callersave_regs C = - foldl (fn (r, C) => I.pushl(R r) :: C) C caller_save_regs_ccall - fun pop_callersave_regs C = - foldr (fn (r, C) => I.popl(R r) :: C) C caller_save_regs_ccall - val size_ff = 0 (* dummy *) - val stublab = NameLab stubname - val res = if res 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, eax, - pop_callersave_regs - (I.popl(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.pushl(L(DatLab dl)):: - I.call(NameLab "raise_exn")::C') C stublab) - (* I.dot_globl stublab :: - I.lab stublab :: - I.pushl(L(DatLab BI.exn_OVERFLOW_lab)) :: - I.call(NameLab "raise_exn") :: C*) (*the call never returns *) - 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.pushl(R r) :: C) C all_regs - fun pop_all_regs C = - foldl (fn (r, C) => I.popl(R r) :: C) C all_regs - fun pop_size_ccf_rcf_reg_args C = base_plus_offset(esp,WORDS(3),esp,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 ecx are also preserved *) - (copy(esp,tmp_reg0, - compile_c_call_prim("gc",[SS.PHREG_ATY tmp_reg0,SS.PHREG_ATY tmp_reg1],NONE,size_ff,eax, - 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.cmpl(LA begin_punit_lab, R tmp_reg0) :: - I.jb lbelow :: - I.movl(LA begin_punit_lab, R tmp_reg0) :: - I.lab lbelow :: - I.cmpl(LA end_punit_lab, R tmp_reg1) :: - I.ja labove :: - I.movl(LA end_punit_lab, R tmp_reg1) :: - I.lab labove :: - C - end - in - I.movl (LA data_begin_init_lab, R tmp_reg0) :: - I.movl (LA data_end_init_lab, R tmp_reg1) :: - foldl comp (I.movl (R tmp_reg0, L data_begin_addr) :: - I.movl (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.pushl(LA next_lab) :: - comment ("JUMP TO NEXT PROGRAM UNIT", - I.jmp(L l) :: - I.dot_long "0xFFFFFFFF" :: (* Marks, no more frames on stack. Used to calculate rootset. *) - I.dot_long "0xFFFFFFFF" :: (* An arbitrary offsetToReturn *) - I.dot_long "0xFFFFFFFF" :: (* An arbitrary function number. *) - I.lab next_lab :: C)) - end) C progunit_labs - - fun allocate_global_regions(region_labs,C) = - let - fun maybe_push_region_id (region_id,C) = - if region_profiling() then I.pushl(I (i2s region_id)) :: 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 pop_args C = - if region_profiling() then I.addl(I "8", R esp) :: C (* two arguments to pop *) - else I.addl(I "4", R esp) :: C (* one argument to pop *) -*) - val nargs = if region_profiling() then 2 else 1 - 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.movl(R eax, L (DatLab lab)) :: C - in - I.subl(I(i2s(4*BI.size_of_reg_desc())), R esp) :: - I.movl(R esp, R tmp_reg1) :: - maybe_push_region_id (region_id, - I.pushl(R tmp_reg1) :: - (if needs_align name then - align (nargs, - I.call(NameLab name) :: - restore_stack_alignment (nargs, C)) - else - I.call(NameLab name) :: - pop_args name nargs C)) - end) C region_labs - end - - fun push_top_level_handler C = - let - fun gen_clos C = - if BI.tag_values() then - copy(esp, tmp_reg1, - I.addl(I "-4", R tmp_reg1) :: - I.movl(R tmp_reg1, D("4", esp)) :: C) - else - I.movl(R esp, D("4", esp)) :: C - in - comment ("PUSH TOP-LEVEL HANDLER ON STACK", - I.subl(I "16", R esp) :: - I.movl(LA (NameLab "TopLevelHandlerLab"), D("0", esp)) :: - gen_clos ( - I.movl(L exn_ptr_lab, R tmp_reg1) :: - I.movl(R tmp_reg1, D("8", esp)) :: - I.movl(R esp, D("12", esp)) :: - I.movl(R esp, L exn_ptr_lab) :: C)) - end - - fun init_stack_bot_gc C = - if gc_p() then (* stack_bot_gc[0] = esp *) - let val C = if simple_memprof_p() then I.movl(R esp, L stack_min) :: C - else C - in - I.movl(R esp, L stack_bot_gc_lab) :: C - end - else C - - fun init_prof C = - if region_profiling() then (* stack_bot_gc[0] = esp *) - I.movl(R esp, L (NameLab "stackBot")) :: - I.movl(R esp, L (NameLab "maxStack")) :: - I.movl(R esp, L (NameLab "maxStackP")) :: - C - else C - - fun main_insts C = - (I.dot_text :: - I.dot_align 4 :: - 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,eax, (* instead of res we might use the result from - * the last function call, 2001-01-08, Niels *) - (*I.leave :: *) - 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 4 :: - I.dot_globl data_begin_addr :: - I.lab data_begin_addr :: - I.dot_long "0" :: - I.dot_globl data_end_addr :: - I.lab data_end_addr :: - I.dot_long "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 X86 code file:\t" ^ filename ^ "]\n")) - handle IO.Io {name,...} => Crash.impossible ("CodeGenX86.emit:\nI cannot open \"" - ^ filename ^ "\":\n" ^ name) - -end diff --git a/src/Compiler/Backend/X86/ExecutionX86.sml b/src/Compiler/Backend/X86/ExecutionX86.sml deleted file mode 100644 index ac51f4255..000000000 --- a/src/Compiler/Backend/X86/ExecutionX86.sml +++ /dev/null @@ -1,305 +0,0 @@ - -structure ExecutionX86: EXECUTION = - struct - structure TopdecGrammar = PostElabTopdecGrammar - structure Labels = AddressLabels - structure PP = PrettyPrint - - structure BackendInfo = - BackendInfo(val down_growing_stack : bool = true) (* true for x86 code generation *) - - structure NativeCompile = NativeCompile(structure BackendInfo = BackendInfo - structure RegisterInfo = InstsX86.RI) - - structure CompileBasis = CompileBasis(structure ClosExp = NativeCompile.ClosExp) - - structure JumpTables = JumpTables(BackendInfo) - - structure CodeGen = CodeGenX86(structure BackendInfo = BackendInfo - structure JumpTables = JumpTables - structure CallConv = NativeCompile.CallConv - structure LineStmt = NativeCompile.LineStmt - structure SubstAndSimplify = NativeCompile.SubstAndSimplify) - - fun die s = Crash.impossible("ExecutionX86." ^ s) - - 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" - val gcc = if InstsX86.sysname() = "Darwin" 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 -m32 -no-integrated-as" - val linux_as = "as --32" - val ass = if InstsX86.sysname() = "Darwin" 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."} - - val _ = Flags.add_bool_entry - {long="gdb_support", short=SOME "g", neg=false, - menu=["Debug","gdb support"], item=ref false, - 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 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 = "X86" - - 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 - - (* 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 command : unit = - (OS.Process.system command; ()) -(* handle OS.SysErr(s,_) => die ("\nCommand " ^ command ^ "\nfailed (" ^ s ^ ");") *) - - 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 InstsX86.sysname() = "Darwin" then "as -arch i386" else "as --32" -*) - - fun gas() = if gdb_support() then 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") ^ " -m32 -o " ^ run ^ " " ^ - concat files ^ path_to_runtime() ^ libdirs ^ libConvertList(!libs) - val debug_linking = Flags.lookup_flag_entry "debug_linking" - fun pr_debug_linking s = if !debug_linking then print s else () - in - pr_debug_linking ("[using link command: " ^ shell_cmd ^ "]\n"); - 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/X86/INSTS_X86.sml b/src/Compiler/Backend/X86/INSTS_X86.sml deleted file mode 100644 index 638d6bec6..000000000 --- a/src/Compiler/Backend/X86/INSTS_X86.sml +++ /dev/null @@ -1,150 +0,0 @@ -signature INSTS_X86 = - sig - - type lvar - - datatype reg = eax | ebx | ecx | edx | esi | edi | ebp | esp - | ah (* for float conditionals *) - | al (* for byte operations *) - | cl (* for shift operations *) - - val tmp_reg0 : reg (*=ecx*) - val tmp_reg1 : reg (*=ebp*) - - 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 *) - movl of ea * ea - | movb of ea * ea - | movzbl of ea * ea - | pushl of ea - | leal of ea * ea - | popl of ea - | addl of ea * ea - | 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 - | andb 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 *) - - | fstpl of ea (* store float and pop float stack *) - | fldl 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_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 pr_reg : reg -> string - - (*-----------------------------------------------------------*) - (* Converting Between General Registers and Precolored Lvars *) - (* As Used In The Phases Preceeding Code Generation *) - (*-----------------------------------------------------------*) - type lvar - val is_reg : lvar -> bool - val lv_to_reg : lvar -> reg - val all_regs_as_lvs : lvar list - val reg_args_as_lvs : lvar list - val reg_res_as_lvs : lvar list - val reg_args_ccall_as_lvs : lvar list - val reg_res_ccall_as_lvs : lvar list - val callee_save_regs_mlkit_as_lvs : lvar list - val caller_save_regs_mlkit_as_lvs : lvar list - val callee_save_regs_ccall_as_lvs : lvar list - val caller_save_regs_ccall_as_lvs : lvar list -*) - - val sysname : unit -> string - - type StringTree - val layout : AsmPrg -> StringTree - - end diff --git a/src/Compiler/Backend/X86/InstsX86.sml b/src/Compiler/Backend/X86/InstsX86.sml deleted file mode 100644 index 460c0a1d3..000000000 --- a/src/Compiler/Backend/X86/InstsX86.sml +++ /dev/null @@ -1,364 +0,0 @@ -structure InstsX86: INSTS_X86 = - struct - structure PP = PrettyPrint - structure Labels = AddressLabels - - fun die s = Crash.impossible("X86Inst." ^ 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 = eax | ebx | ecx | edx | esi | edi | ebp | esp - | ah | al | cl - - 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 *) - movl of ea * ea - | movb of ea * ea - | movzbl of ea * ea - | leal of ea * ea - | pushl of ea - | popl of ea - | addl of ea * ea - | 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 - | andb of ea * ea - | sarl of ea * ea - | shrl of ea * ea (* unsigned *) - | sall of ea * ea - | cmpl of ea * ea - | btl of ea * ea - | btrl of ea * ea (* bit test and reset; sets carry flag *) - - | fstpl of ea (* store float and pop float stack *) - | fldl 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_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 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 ah = "%ah" - | pr_reg al = "%al" - | pr_reg cl = "%cl" - - 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) = (* "NLab." ^ *) 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 - | pr_ea (LA l) = "$" ^ 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 movl a => emit_bin ("movl", a) - | movb a => emit_bin ("movb", a) - | movzbl a => emit_bin ("movzbl", a) - | leal a => emit_bin ("leal", a) - | pushl ea => emit_unary ("pushl", ea) - | popl ea => emit_unary ("popl", ea) - | 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) - | andb a => emit_bin("andb", 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) - - | fstpl ea => emit_unary("fstpl", ea) - | fldl ea => emit_unary("fldl", 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_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 = [eax,ebx,ecx,edx,esi,edi,ebp,esp] - val reg_lvs = map (fn r => Lvars.new_named_lvar (pr_reg r)) regs - val (eax_lv,ebx_lv,ecx_lv,edx_lv,esi_lv,edi_lv,ebp_lv,esp_lv) = - case reg_lvs of - [eax_lv,ebx_lv,ecx_lv,edx_lv,esi_lv,edi_lv,ebp_lv,esp_lv] => (eax_lv,ebx_lv,ecx_lv,edx_lv,esi_lv,edi_lv,ebp_lv,esp_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 eax => eax_lv | ebx => ebx_lv | ecx => ecx_lv | edx => edx_lv - | esi => esi_lv | edi => edi_lv | ebp => ebp_lv | esp => esp_lv - | ah => die "reg_to_lv: ah not available for register allocation" - | al => die "reg_to_lv: al not available for register allocation" - | cl => die "reg_to_lv: cl not available for register allocation" - - val reg_args = [eax,ebx,edi] - val args_phreg = map reg_to_lv reg_args - val reg_res = [edi,ebx,eax] - val res_phreg = map reg_to_lv reg_res - - val reg_args_ccall = [] - val reg_res_ccall = [eax] - val args_phreg_ccall = map reg_to_lv reg_args_ccall - val res_phreg_ccall = map reg_to_lv reg_res_ccall - - fun reg_eq(reg1,reg2) = reg1 = reg2 - val callee_save_regs_ccall = [] - val callee_save_regs_ccall_as_lvs = [] - - val callee_save_ccall_phregs = [] - val callee_save_ccall_phregset = Lvarset.lvarsetof [] - fun is_callee_save_ccall phreg = false - - val caller_save_regs_mlkit = [eax,ebx,edi,edx,esi] - 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 = [eax,ebx,edi,edx,esi] - 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 = ecx - val tmp_reg1 = ebp - - type StringTree = PP.StringTree - fun layout _ = PP.LEAF "not implemented" - end diff --git a/src/Compiler/CompBasis.sml b/src/Compiler/CompBasis.sml index 1e6d33a7b..3502f6e83 100644 --- a/src/Compiler/CompBasis.sml +++ b/src/Compiler/CompBasis.sml @@ -163,6 +163,7 @@ structure CompBasis: COMP_BASIS = else cons val tynames = TyName.tyName_LIST :: TyName.tyName_INTINF :: TyName.tyName_BOOL :: + TyName.tyName_FOREIGNPTR :: TyName.tyName_VECTOR :: tynames (* for elim eq *) val tynames = if quotation() then TyName.tyName_FRAG :: tynames else tynames diff --git a/src/Compiler/Lambda/.cvsignore b/src/Compiler/Lambda/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Compiler/Lambda/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Compiler/Regions/.cvsignore b/src/Compiler/Regions/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Compiler/Regions/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Compiler/kitkam.mlb b/src/Compiler/kitkam.mlb deleted file mode 100644 index a8fd57f7b..000000000 --- a/src/Compiler/kitkam.mlb +++ /dev/null @@ -1,5 +0,0 @@ -local - bytecode.mlb -in ../Common/KitKam.sml -end - diff --git a/src/Compiler/native.mlb b/src/Compiler/native.mlb deleted file mode 100644 index 97a9dec60..000000000 --- a/src/Compiler/native.mlb +++ /dev/null @@ -1,44 +0,0 @@ -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/X86/INSTS_X86.sml - ../Kitlib/kitlib.mlb - local open Tools - in - local open CompilerObjects - in Backend/X86/InstsX86.sml - Backend/X86/CodeGenX86.sml - local open Pickle Basics Manager - in Backend/X86/ExecutionX86.sml - end - end - - local open Compiler - in ../Common/KitX86.sml - end - - end -end diff --git a/src/Compiler/smlserver.mlb b/src/Compiler/smlserver.mlb deleted file mode 100644 index 851e4a58c..000000000 --- a/src/Compiler/smlserver.mlb +++ /dev/null @@ -1,6 +0,0 @@ -local - $(SML_LIB)/basis/basis.mlb - bytecode.mlb -in ../Common/KitSmlserver.sml -end - diff --git a/src/Edlib/.cvsignore b/src/Edlib/.cvsignore deleted file mode 100644 index 31cd8ec31..000000000 --- a/src/Edlib/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB a.out \ No newline at end of file diff --git a/src/Makefile.in b/src/Makefile.in index 163dce190..a2ba9b9ec 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -15,16 +15,6 @@ BINDIR=@top_srcdir@/bin include @top_srcdir@/Makefiledefault -GENOPCODES_TARGETS=Runtime/Prims.c Runtime/PrimsNsSml.c \ - Runtime/KamInsts.h Runtime/KamInsts.c Runtime/jumptbl.h \ - Compiler/Backend/KAM/BuiltInCFunctionsKAM.sml \ - Compiler/Backend/KAM/OPCODES_KAM.sml Compiler/Backend/KAM/OpcodesKAM.sml - -GENOPCODES_SOURCES=Compiler/Backend/KAM/BuiltInCFunctions.spec \ - Compiler/Backend/KAM/BuiltInCFunctionsNsSml.spec \ - Compiler/Backend/KAM/BuiltInCFunctionsApSml.spec \ - Compiler/Backend/KAM/KamInsts.spec - # Whether request profiling is enabled REQUEST_PROFILING= #REQUEST_PROFILING=true @@ -58,45 +48,16 @@ smltojs: basics mlbmake mllex-yacc $(MLCOMP) -output smltojs Compiler/smltojs.mlb $(INSTALL) -p smltojs $(BINDIR) -mlkit_kam: mlkit_kam_kit - .PHONY: mllex-yacc mllex-yacc: Parsing/Topdec.lex.sml Parsing/Topdec.grm.sml -.PHONY: mlkit_kam_kit -mlkit_kam_kit: basics tester kitbench mllex-yacc - $(MAKE) -C Runtime kam - $(MLCOMP) -output mlkit_kam Compiler/kitkam.mlb - $(INSTALL) -p mlkit_kam $(BINDIR) - -.PHONY: smlserver -smlserver: smlserver_kit - -.PHONY: smlserver_kit -smlserver_kit: basics mlbmake mllex-yacc - $(MAKE) -C Tools/MspComp - $(MAKE) -C Tools/UlWrapUp - $(MAKE) -C Runtime runtimeSystemKamApSml.o - $(MAKE) -C SMLserver/apache - $(MLCOMP) -output smlserverc Compiler/smlserver.mlb - $(INSTALL) -p smlserverc $(BINDIR) - .PHONY: barry barry: basics mlbmake mllex-yacc $(MLCOMP) -output barry Compiler/barry.mlb $(INSTALL) -p barry $(BINDIR) .PHONY: basics -basics: genopcodes mlkit-mllex mlkit-mlyacc - -.PHONY: genopcodes -genopcodes: $(BINDIR)/kitgen_opcodes - -$(BINDIR)/kitgen_opcodes: $(GENOPCODES_SOURCES) - $(MKDIR) $(BINDIR) - $(MAKE) -C Tools/GenOpcodes BINDIR=../../$(BINDIR) -# kitgen_opcodes assumes it's run from the src-directory - $(BINDIR)/kitgen_opcodes +basics: mlkit-mllex mlkit-mlyacc .PHONY: rp2ps rp2ps: @@ -130,7 +91,7 @@ Parsing/Topdec.grm.sml: Parsing/Topdec.grm .PHONY: clean clean: - $(CLEAN) run $(GENOPCODES_TARGETS) smltojs + $(CLEAN) run smltojs $(MAKE) -C Pickle clean cd Pickle && $(CLEAN) cd Kitlib && $(CLEAN) @@ -145,63 +106,15 @@ clean: cd Tools/Tester && $(MAKE) clean cd Tools/Rp2ps && $(MAKE) clean cd Tools/MlbMake && $(MAKE) clean - cd Tools/GenOpcodes && $(MAKE) clean cd Tools/Benchmark && $(MAKE) clean - $(MAKE) -C Tools/UlWrapUp clean $(MAKE) -C Tools/ml-lex clean $(MAKE) -C Tools/ml-yacc clean cd Compiler && $(CLEAN) cd Compiler/Backend && $(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) cd Compiler/Regions && $(CLEAN) cd Compiler/Lambda && $(CLEAN) - cd SMLserver && $(CLEAN) nssml.so *.o - $(MAKE) -C SMLserver/apache clean rm -f mlkit - - -# ---------------------------------------------------------- -# Support for measuring the code blowup resulting from -# compiling functors in the MLKit; not used by install! -# ---------------------------------------------------------- - -FILE = /home/mael/kit/src/bdys.txt -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)) - -.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 Manager && cat *.sml >> $(LINES)) - wc -l $(LINES) - rm -f $(LINES) diff --git a/src/Manager/.cvsignore b/src/Manager/.cvsignore deleted file mode 100644 index 164ed04a1..000000000 --- a/src/Manager/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB \ No newline at end of file diff --git a/src/Manager/MANAGER_OBJECTS.sml b/src/Manager/MANAGER_OBJECTS.sml index d687c4e81..772218385 100644 --- a/src/Manager/MANAGER_OBJECTS.sml +++ b/src/Manager/MANAGER_OBJECTS.sml @@ -2,9 +2,9 @@ signature MANAGER_OBJECTS = sig include MANAGER_OBJECTS0 - type modcode - type target - type linkinfo + type modcode + type target + type linkinfo val backend_name : string (* native or kam *) @@ -38,30 +38,20 @@ signature MANAGER_OBJECTS = sig val empty : modcode val seq : modcode * modcode -> modcode - val mk_modcode : target * linkinfo * string -> modcode + val mk_modcode : target * linkinfo * string -> modcode (* Use emit or mk_exe to actually emit code. * The string is a program unit name. *) val exist : modcode -> bool - val emit : absprjid * modcode -> modcode - val mk_exe : absprjid * modcode * string list * string -> unit + val emit : absprjid * modcode -> modcode + val mk_exe : absprjid * modcode * string list * string -> unit (* produces executable `string' in target directory the string * list is a list of external object files as generated by a * foreign compiler (e.g., gcc). *) - val mk_exe_all_emitted : modcode * string list * string -> unit + val mk_exe_all_emitted : modcode * string list * string -> unit val size : modcode -> int (* for debugging *) - (* write the file absprjid[.pm -> .ul] *) - val ulfile : absprjid -> string - (* [ulfile absprjid] returns the name of the ul-file corresponding to the - * absprjid. *) val target_files : modcode -> string list - (* [target_files mc] returns the paths to the emitted target_files + (* [target_files mc] returns the paths to the emitted target_files * for mc; dies if not all files are emitted. *) - val makeUlfile : string * modcode * modcode -> unit - (* [makeUlfile (ulfile,mc1,mc2)] stores a file ulfile containing the names - * of uo-files in mc1, followed by the line ``scripts:'', followed - * by the uo-files in mc2 with the prefix consisting of the uo-files - * in mc1 removed. *) - val deleteUlfile : absprjid -> unit val pu : modcode Pickle.pu val dirMod : string -> modcode -> modcode (* [dirMod d mc] replaces paths p in mc with diff --git a/src/Manager/Manager.sml b/src/Manager/Manager.sml index 454251b85..c96e79ad5 100644 --- a/src/Manager/Manager.sml +++ b/src/Manager/Manager.sml @@ -65,23 +65,6 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS \js-client."} ; Flags.is_on0 "export_basis_js") - 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\ - \scripts to be functor SCRIPTLET's, which are\n\ - \automatically instantiated by SMLserver in a\n\ - \type safe way. To construct and link to XHTML\n\ - \forms in a type safe way, SMLserver constructs an\n\ - \abstract interface to the forms from the functor\n\ - \arguments of the scriptlets. This interface is\n\ - \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") - val print_export_bases = (Flags.add_bool_entry {long="print_export_bases", short=SOME "Peb", neg=false, @@ -111,13 +94,6 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS desc="Link-files to be linked together to form an\n\ \executable."} - 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 {long="load_basis_files", short=SOME "load", item=ref nil, menu=["File", "Basis files to load before compilation"], @@ -146,12 +122,6 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun error a = MO.error a val quot = MO.quot - (* SMLserver components *) - - (* Support for parsing scriptlet form argument - i.e., functor - * arguments *) - structure Scriptlet = Scriptlet(val error = error) - (* ----------------------------------------- * Unit names, file names and directories * ----------------------------------------- *) @@ -717,30 +687,6 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS ) handle XX => (log_cleanup(); raise XX) end -(* - fun smlserver_preprocess prj = - if not(extendedtyping()) then prj - else - case Project.getParbody prj of - NONE => prj - | 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} => - {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 - end -*) - fun writeAll (f,s) = let val os = TextIO.openOut f in (TextIO.output(os,s); @@ -774,34 +720,13 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS end structure MlbProject = MlbProject(ManagerObjects.Environment) - structure UlFile = UlFile(MlbProject) - 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 = let val _ = chat "reading link files" val lnkFiles = Flags.get_stringlist_entry "link" val modc = readLinkFiles lnkFiles - in if !Flags.SMLserver then - (case mlbfile_opt of - SOME mlbfile => - let val _ = chat "creating ul file" - val s = mlb_to_ulfile getUoFiles {mlbfile=mlbfile} - val ulfile = !run_file - in writeAll(ulfile,s) - ; print("[wrote file " ^ ulfile ^ "]\n") - end - | NONE => - let val lnkFilesScripts = Flags.get_stringlist_entry "link_scripts" - val modc_scripts = readLinkFiles lnkFilesScripts - in ModCode.makeUlfile (!run_file,modc,ModCode.seq(modc,modc_scripts)) - end) - else - (chat "making executable"; - ModCode.mk_exe_all_emitted(modc, nil, !run_file)) + in chat "making executable"; + ModCode.mk_exe_all_emitted(modc, nil, !run_file) end (* ---------------------------- @@ -934,7 +859,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS fun link0 mlbfile target lnkFiles lnkFilesScripts () = (Flags.lookup_string_entry "output" := target; Flags.lookup_stringlist_entry "link" := lnkFiles; - Flags.lookup_stringlist_entry "link_scripts" := lnkFilesScripts; + (*Flags.lookup_stringlist_entry "link_scripts" := lnkFilesScripts;*) link_lnk_files (SOME mlbfile)) in fun link {verbose} {mlbfile,target,lnkFiles,lnkFilesScripts,flags=""} :unit = @@ -1011,13 +936,7 @@ functor Manager(structure ManagerObjects : MANAGER_OBJECTS in OS.FileSys.remove mlb_file end | MLB s => - let val target = - if !Flags.SMLserver then - let val {dir,file} = OS.Path.splitDirFile s - val op ## = OS.Path.concat infix ## - in dir ## MO.mlbdir() ## (OS.Path.base file ^ ".ul") - end - else Flags.get_string_entry "output" + let val target = Flags.get_string_entry "output" in (MlbMake.build{flags="",mlbfile=s,target=target} handle Fail s => raise Fail s diff --git a/src/Manager/ManagerObjects.sml b/src/Manager/ManagerObjects.sml index a762336ab..1c950c962 100644 --- a/src/Manager/ManagerObjects.sml +++ b/src/Manager/ManagerObjects.sml @@ -1,15 +1,15 @@ -(* COMPILER_ENV is the lambda env mapping structure and value +(* COMPILER_ENV is the lambda env mapping structure and value * identifiers to lambda env's and lvars *) -(* COMPILE_BASIS is the combined basis of all environments in - * the backend *) +(* COMPILE_BASIS is the combined basis of all environments in + * the backend *) functor ManagerObjects( structure Execution : EXECUTION val program_name : unit -> string ) : MANAGER_OBJECTS = struct - local structure MO = + local structure MO = ManagerObjects0(structure Execution = Execution) in open MO end @@ -33,7 +33,7 @@ functor ManagerObjects( fun die s = Crash.impossible("ManagerObjects." ^ s) fun chat s = if !Flags.chat then print (s ^ "\n") else () - val link_time_dead_code_elimination = + val link_time_dead_code_elimination = Flags.add_bool_entry {long="link_time_dead_code_elimination", short=SOME "ltdce", item=ref true, menu=["Control", "link time dead code elimination"], neg=true, desc="Link time dead code elimination."} @@ -43,7 +43,7 @@ functor ManagerObjects( fun pr_debug_linking s = if !debug_linking then print s else () end - (* + (* * Modification times of files *) @@ -78,14 +78,14 @@ functor ManagerObjects( * Creating directories for target code * ----------------------------------------------- *) - fun maybe_create_dir d : unit = + fun maybe_create_dir d : unit = if OS.FileSys.access (d, []) handle _ => error ("I cannot access directory " ^ quot d) then if OS.FileSys.isDir d then () else error ("The file " ^ quot d ^ " is not a directory") - else ((OS.FileSys.mkDir d;()) handle _ => - error ("I cannot create directory " ^ quot d ^ " --- the current directory is " ^ + else ((OS.FileSys.mkDir d;()) handle _ => + error ("I cannot create directory " ^ quot d ^ " --- the current directory is " ^ OS.FileSys.getDir())) - + fun maybe_create_dirs {prepath:string,dirs:string} : unit = let val dirs = String.tokens (fn c => c = #"/") dirs fun loop (p, nil) = () @@ -95,16 +95,16 @@ functor ManagerObjects( in loop(prepath, dirs) end - fun maybe_create_mlbdir {prepath:string} : unit = + fun maybe_create_mlbdir {prepath:string} : unit = maybe_create_dirs {prepath=prepath,dirs=mlbdir()} (* ----------------------------------------------- - * Emit assembler code and assemble it. + * Emit assembler code and assemble it. * ----------------------------------------------- *) fun emit (target,absprjid,filename) = - let fun esc n = + let fun esc n = let fun loop nil acc = implode(rev acc) | loop (#"." :: #"." :: cc) acc = loop cc (#"%"::acc) | loop (#"/" :: cc) acc = loop cc (#"+"::acc) @@ -113,13 +113,13 @@ functor ManagerObjects( end val target_filename = if Flags.is_on "compile_only" then - let val p = OS.Path.base(Flags.get_string_entry "output") + let val p = OS.Path.base(Flags.get_string_entry "output") val filename = OS.Path.file filename in if OS.Path.file p = filename then p else p ^ "." ^ filename end else (* - let + let val target_filename = OS.Path.base(OS.Path.file absprjid) ^ "-" ^ esc filename val target_filename = pmdir() ^ target_filename in OS.Path.mkAbsolute{path=target_filename, relativeTo=OS.FileSys.getDir()} @@ -140,7 +140,7 @@ functor ManagerObjects( (* ------------------------------------------------------------- * Link time dead code elimination; we eliminate all unnecessary * object files from the link sequence before we do the actual - * linking. + * linking. * ------------------------------------------------------------- *) structure labelTable : sig type table @@ -154,14 +154,14 @@ functor ManagerObjects( val table_size_word = Word.fromInt table_size fun hash s = let fun loop (0, acc) = acc - | loop (i, acc) = loop(i-1, Word.+(Word.*(0w19,acc), + | loop (i, acc) = loop(i-1, Word.+(Word.*(0w19,acc), Word.fromInt(Char.ord(String.sub(s,i-1))))) in Word.toInt(Word.mod(loop (String.size s, 0w0), table_size_word)) end fun mk () = Array.array (table_size, nil) fun member (a:string) l = let fun f [] = false - | f (x::xs) = a=x orelse f xs + | f (x::xs) = a=x orelse f xs in f l end fun look (table,lab) = @@ -170,7 +170,7 @@ functor ManagerObjects( val l = Array.sub(table,h) in member s l end - fun insert (table,lab) = + fun insert (table,lab) = let val s = Execution.pr_lab lab val h = hash s val l = Array.sub(table,h) @@ -182,32 +182,32 @@ functor ManagerObjects( fun unsafe(tf,li) = Execution.unsafe_linkinfo li fun exports(tf,li) = Execution.exports_of_linkinfo li fun imports(tf,li) = Execution.imports_of_linkinfo li - fun dead_code_elim tfiles_with_linkinfos = - let + fun dead_code_elim tfiles_with_linkinfos = + let val _ = pr_debug_linking "[Link time dead code elimination begin...]\n" val table = labelTable.mk() val allexports = labelTable.mk() fun require (f_labs,d_labs) : unit = (List.app (fn lab => labelTable.insert(table,lab)) f_labs; List.app (fn lab => labelTable.insert(table,lab)) d_labs) (* 2001-01-09, Niels *) fun add_exports_to_allexports (f_labs,d_labs) = - let fun look l = + let fun look l = if labelTable.look(allexports, l) then die ("Label " ^ Execution.pr_lab l ^ " allready exported") else () in (List.app (fn lab => (look lab ; labelTable.insert(allexports,lab))) f_labs; - List.app (fn lab => (look lab ; labelTable.insert(allexports,lab))) d_labs) + List.app (fn lab => (look lab ; labelTable.insert(allexports,lab))) d_labs) end - - fun required (f_labs,d_labs) : bool = + + fun required (f_labs,d_labs) : bool = foldl (fn (lab,acc) => acc orelse labelTable.look(table,lab)) (foldl (fn (lab,acc) => acc orelse labelTable.look(table,lab)) false f_labs) d_labs (* 2001-01-09, Niels *) fun reduce [] = [] - | reduce (obj::rest) = + | reduce (obj::rest) = let val rest' = reduce rest fun pp_unsafe true = " (unsafe)" | pp_unsafe false = " (safe)" - in if unsafe obj orelse required (exports obj) then + in if unsafe obj orelse required (exports obj) then (pr_debug_linking ("Using " ^ #1 obj ^ pp_unsafe(unsafe obj) ^ "\n") ; require (imports obj) ; add_exports_to_allexports (exports obj) @@ -227,20 +227,20 @@ functor ManagerObjects( | elim_dupl ( f :: fs , acc ) = elim_dupl ( fs, if member f acc then acc else f :: acc ) (* -------------------------------------------------------------- - * link (target_files,linkinfos): Produce a link file "link.s". + * link (target_files,linkinfos): Produce a link file "link.s". * Then link the entire project and produce an executable "run". * -------------------------------------------------------------- *) fun link (tfiles_with_linkinfos, extobjs, run) : unit = - let - val tfiles_with_linkinfos = + let + val tfiles_with_linkinfos = if link_time_dead_code_elimination() then dead_code_elim tfiles_with_linkinfos else tfiles_with_linkinfos val linkinfos = map #2 tfiles_with_linkinfos val target_files = map #1 tfiles_with_linkinfos val labs = map Execution.code_label_of_linkinfo linkinfos - val exports = - List.foldr (fn ((fs,ds),(acc_f,acc_d)) => (fs@acc_f, ds@acc_d)) ([],[]) + val exports = + List.foldr (fn ((fs,ds),(acc_f,acc_d)) => (fs@acc_f, ds@acc_d)) ([],[]) (map Execution.exports_of_linkinfo linkinfos) (* 2001-01-09, Niels *) val extobjs = elim_dupl (extobjs,[]) in case Execution.generate_link_code @@ -250,13 +250,13 @@ functor ManagerObjects( in link_files_with_runtime_system (linkfile_o :: (target_files @ extobjs)) run; delete_file linkfile_o end - | NONE => + | NONE => link_files_with_runtime_system target_files run end end (*structure SystemTools*) - datatype modcode = EMPTY_MODC - | SEQ_MODC of modcode * modcode + datatype modcode = EMPTY_MODC + | SEQ_MODC of modcode * modcode | EMITTED_MODC of filename * linkinfo | NOTEMITTED_MODC of target * linkinfo * filename @@ -269,18 +269,18 @@ functor ManagerObjects( fun exist EMPTY_MODC = true | exist (SEQ_MODC(mc1,mc2)) = exist mc1 andalso exist mc2 | exist (NOTEMITTED_MODC _) = true - | exist (EMITTED_MODC(file,_)) = + | exist (EMITTED_MODC(file,_)) = let val res = OS.FileSys.access (file,[]) handle _ => false in if res then res else (print ("File " ^ file ^ " not present\n"); res) end fun emit(absprjid: absprjid, modc) = - let + let fun em EMPTY_MODC = EMPTY_MODC | em (SEQ_MODC(modc1,modc2)) = SEQ_MODC(em modc1, em modc2) | em (EMITTED_MODC(fp,li)) = EMITTED_MODC(fp,li) - | em (NOTEMITTED_MODC(target,linkinfo,filename)) = + | em (NOTEMITTED_MODC(target,linkinfo,filename)) = EMITTED_MODC(SystemTools.emit(target,ModuleEnvironments.absprjid_to_string absprjid,filename),linkinfo) (*puts ".o" on filename*) in em modc @@ -306,7 +306,7 @@ functor ManagerObjects( | get (NOTEMITTED_MODC(target,li,filename), acc) = die "mk_exe_all_emitted" in SystemTools.link(get(modc,[]), extobjs, run) end - + fun all_emitted modc : bool = case modc of NOTEMITTED_MODC _ => false @@ -317,7 +317,7 @@ functor ManagerObjects( case mc of SEQ_MODC(mc1,mc2) => emitted_files(mc1,emitted_files(mc2,acc)) | EMITTED_MODC(tfile,_) => tfile::acc - | _ => acc + | _ => acc fun delete_files (SEQ_MODC(mc1,mc2)) = (delete_files mc1; delete_files mc2) | delete_files (EMITTED_MODC(fp,_)) = SystemTools.delete_file fp @@ -335,62 +335,21 @@ functor ManagerObjects( in "PM/" ^ base_absprjid ^ ".timestamp" end *) - fun ulfile (absprjid: absprjid) : string = - let val base_absprjid = OS.Path.base(OS.Path.file(ModuleEnvironments.absprjid_to_string absprjid)) - in "PM/" ^ base_absprjid ^ ".ul" - end - - fun deleteUlfile absprjid : unit = - if not(!Flags.SMLserver) then () - else let val f = ulfile absprjid - in OS.FileSys.remove f handle _ => () - end fun list_minus (xs,nil) = xs - | list_minus (x::xs,y::ys) = + | list_minus (x::xs,y::ys) = if x = y then list_minus(xs,ys) else die "list_minus.prefix error1" | list_minus _ = die "list_minus.prefix error2" fun target_files modc : string list = let fun files (mc,acc) = - case mc of + case mc of SEQ_MODC(mc1,mc2) => files(mc1,files(mc2,acc)) | EMITTED_MODC(tfile,_) => tfile::acc | NOTEMITTED_MODC(target,li,filename) => die "target_files: file not emitted" - | _ => acc + | _ => acc in files(modc,nil) - end - - fun makeUlfile (ulfile: string, modc, modc') : unit = - if not(!Flags.SMLserver) then () - else - (* modc is a prefix of modc' *) - let - val _ = - if not (all_emitted modc) orelse not(all_emitted modc') then - die "makeUlfile: not all emitted" - else () -(* val modc = emit (absprjid, modc') *) - val uofiles_local = target_files modc - val uofiles_local_and_scripts = target_files modc' - val uofiles_scripts = list_minus(uofiles_local_and_scripts,uofiles_local) -(* val uofiles_scripts = map OS.Path.file uofiles_scripts *) - val _ = - let val os = TextIO.openOut ulfile - in app (fn f => TextIO.output(os, f ^ "\n")) uofiles_local - ; TextIO.output(os, "scripts:\n") - ; app (fn f => TextIO.output(os, f ^ "\n")) uofiles_scripts - ; TextIO.closeOut os - end -(* - val timeStampFile = timeStampFileName absprjid - val os = TextIO.openOut timeStampFile - val _ = TextIO.output(os, "") - val _ = TextIO.closeOut os; -*) - in - print("[wrote file " ^ ulfile ^ "]\n") end val pu = @@ -399,14 +358,14 @@ functor ManagerObjects( | toInt (EMITTED_MODC _) = 2 | toInt (NOTEMITTED_MODC _) = 3 val fun_EMPTY_MODC = Pickle.con0 EMPTY_MODC - fun fun_SEQ_MODC pu = + fun fun_SEQ_MODC pu = Pickle.con1 SEQ_MODC (fn SEQ_MODC a => a | _ => die "ModCode.pu.SEQ_MODC") (Pickle.pairGen(pu,pu)) - fun fun_EMITTED_MODC _ = + fun fun_EMITTED_MODC _ = Pickle.con1 EMITTED_MODC (fn EMITTED_MODC a => a | _ => die "ModCode.pu.EMITTED_MODC") (Pickle.pairGen(Pickle.string,Execution.pu_linkinfo)) fun error _ = die "ModCode.pu.NOTEMITTED_MODC" - fun fun_NOTEMITTED_MODC _ = + fun fun_NOTEMITTED_MODC _ = Pickle.con1 error error (Pickle.convert (error,error) Pickle.unit) in Pickle.dataGen("ModCode",toInt,[fun_EMPTY_MODC, fun_SEQ_MODC, @@ -423,9 +382,9 @@ functor ManagerObjects( (OS.Path.getParent o OS.Path.getParent) s fun dirMod d m = - dirMod0 (fn fp => + dirMod0 (fn fp => let val p = d ## OS.Path.file fp - val p = + val p = if OS.Path.isAbsolute d then p else subtract_mlbdir(OS.Path.dir fp) ## p in p @@ -433,7 +392,7 @@ functor ManagerObjects( fun absDirMod absd m = dirMod0 (fn fp => absd ## OS.Path.file fp) m - + end end diff --git a/src/Parsing/.cvsignore b/src/Parsing/.cvsignore deleted file mode 100644 index 2fbb21638..000000000 --- a/src/Parsing/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -Topdec.grm.desc CM PM MLB diff --git a/src/Pickle/.cvsignore b/src/Pickle/.cvsignore deleted file mode 100644 index 048d6cb3b..000000000 --- a/src/Pickle/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -CM PM MLB a.out *.log \ No newline at end of file diff --git a/src/Runtime/.cvsignore b/src/Runtime/.cvsignore deleted file mode 100644 index f4f6f1072..000000000 --- a/src/Runtime/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -kam KamInsts.h KamInsts.c jumptbl.h Prims.c PrimsNsSml.c PrimsApSml.c Makefile SysErrTable.h gen_syserror - diff --git a/src/Runtime/Exception.h b/src/Runtime/Exception.h index c5451ec4a..6856622eb 100644 --- a/src/Runtime/Exception.h +++ b/src/Runtime/Exception.h @@ -6,7 +6,7 @@ #define __EXCEPTION_H #include - +#include "Region.h" #include "String.h" typedef void (*SignalHandler)(int); @@ -27,7 +27,7 @@ extern Exception* exn_INTERRUPT; /* Exception for user interrupt (Ctrl extern Exception* exn_SUBSCRIPT; extern Exception* exn_SIZE; -void raise_exn(uintptr_t exn); +void raise_exn(Context ctx, uintptr_t exn); extern size_t failNumber; diff --git a/src/Runtime/GC.c b/src/Runtime/GC.c index e0b1a96b5..0dadfc3e4 100644 --- a/src/Runtime/GC.c +++ b/src/Runtime/GC.c @@ -347,7 +347,7 @@ mk_from_space_gen(Gen *gen) gen->a = alloc_new_block(gen); } -static void mk_from_space() +static void mk_from_space(Context ctx) { Ro *r; @@ -585,7 +585,7 @@ allocated_bytes_in_region_untagged(Ro* r, long obj_sz) // obj_sz is in words } static size_t -allocated_bytes_in_regions(void) +allocated_bytes_in_regions(Context ctx) { size_t n = 0; Ro* r; @@ -615,7 +615,7 @@ allocated_bytes_in_regions(void) } static long -allocated_bytes_in_lobjs(void) +allocated_bytes_in_lobjs(Context ctx) { long n = 0; Ro* r; @@ -661,7 +661,7 @@ allocated_pages_in_region(Region r) } static long -allocated_pages_in_regions(void) +allocated_pages_in_regions(Context ctx) { long n = 0; Ro* r; @@ -702,7 +702,7 @@ chk_no_tospacebits_region(Region r) } static void -chk_no_tospacebits_regions(void) +chk_no_tospacebits_regions(Context ctx) { Ro* r; for ( r = TOP_REGION ; r ; r = r->p ) @@ -1263,7 +1263,7 @@ clear_tospace_bit_and_set_colorPtr_in_gen(Gen *gen) #ifdef CHECK_GC void -check_all_lobjs(void) // used for debugging +check_all_lobjs(Context ctx) // used for debugging { Region r; //printf("[check_all_lobjs begin]\n"); @@ -1302,7 +1302,7 @@ region_utilize(long pages, long bytes) } void -gc(uintptr_t **sp, size_t reg_map) +gc(Context ctx, uintptr_t **sp, size_t reg_map) { long time_gc_one_ms = 0; extern Rp* freelist; @@ -1373,11 +1373,11 @@ gc(uintptr_t **sp, size_t reg_map) num_gc); fflush(stderr); ////fprintf(stderr,"[GC: allocated_bytes_in_regions]\n"); - bytes_from_space = allocated_bytes_in_regions(); + bytes_from_space = allocated_bytes_in_regions(ctx); ////fprintf(stderr,"[GC: allocated_pages_in_regions]\n"); - pages_from_space = allocated_pages_in_regions(); + pages_from_space = allocated_pages_in_regions(ctx); ////fprintf(stderr,"[GC: allocated_bytes_in_lobjs]\n"); - lobjs_beforegc = allocated_bytes_in_lobjs(); + lobjs_beforegc = allocated_bytes_in_lobjs(ctx); alloc_period_save = alloc_period; alloc_period = 0; } @@ -1391,7 +1391,7 @@ gc(uintptr_t **sp, size_t reg_map) #ifdef ENABLE_GEN_GC #ifdef CHECK_GC - chk_no_tospacebits_regions(); + chk_no_tospacebits_regions(ctx); for ( r = TOP_REGION ; r ; r = r->p ) { @@ -1421,7 +1421,7 @@ gc(uintptr_t **sp, size_t reg_map) #endif // ENABLE_GEN_GC ////fprintf(stderr,"[GC: mk_from_space]\n"); - mk_from_space(); + mk_from_space(ctx); #ifdef ENABLE_GEN_GC if ( is_minor_p ) { @@ -1702,7 +1702,7 @@ gc(uintptr_t **sp, size_t reg_map) clear_scan_container(); #ifdef CHECK_GC - check_all_lobjs(); // debugging + check_all_lobjs(ctx); // debugging #endif // CHECK_GC rp_used = rp_total - size_free_list(); @@ -1761,9 +1761,9 @@ gc(uintptr_t **sp, size_t reg_map) size_t bytes_to_space; size_t pages_to_space; //size_t copied_bytes = alloc_period; - bytes_to_space = allocated_bytes_in_regions(); // ok gengc - pages_to_space = allocated_pages_in_regions(); // ok gengc - lobjs_aftergc = allocated_bytes_in_lobjs(); // ok gengc + bytes_to_space = allocated_bytes_in_regions(ctx); // ok gengc + pages_to_space = allocated_pages_in_regions(ctx); // ok gengc + lobjs_aftergc = allocated_bytes_in_lobjs(ctx); // ok gengc alloc_period = alloc_period_save; // ok gengc alloc_total += alloc_period; // ok gengc alloc_total += lobjs_period; // ok gengc @@ -1859,9 +1859,9 @@ gc(uintptr_t **sp, size_t reg_map) doing_gc = 0; // Mutex on the garbage collector if (raised_exn_interupt) - raise_exn((uintptr_t)&exn_INTERRUPT); + raise_exn(ctx,(uintptr_t)&exn_INTERRUPT); if (raised_exn_overflow) - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); return; } diff --git a/src/Runtime/GC.h b/src/Runtime/GC.h index b6ba8f251..02748277c 100644 --- a/src/Runtime/GC.h +++ b/src/Runtime/GC.h @@ -43,7 +43,7 @@ points_into_dataspace (uintptr_t *p) { size_t size_lobj(size_t tag); -void gc(size_t **sp, size_t reg_map); +void gc(Context ctx, size_t **sp, size_t reg_map); #endif /*ENABLE_GC*/ diff --git a/src/Runtime/HeapCache.c b/src/Runtime/HeapCache.c deleted file mode 100644 index 0fc95cddc..000000000 --- a/src/Runtime/HeapCache.c +++ /dev/null @@ -1,390 +0,0 @@ -#include -#include -#include -#include "HeapCache.h" -#include "Region.h" -#include "Runtime.h" -#include "LoadKAM.h" - -/* - * Checkpointing execution of library code - */ - -/* - * Static function declarations - */ - -// [newHeap()] returns an uninitialized heap - with status -// HSTAT_UNINITIALIZED. -static Heap* newHeap(serverstate); - -// [restoreHeap(h)] restores the heap from the heap copy information. -// Changes the heap status to HSTAT_CLEAN. Requires the heap status to -// be HSTAT_DIRTY. -static void restoreHeap(Heap *h, serverstate); - -// [pagesInRegion(r)] returns the number of pages associated with r. -static int pagesInRegion(Ro *r); - -// [copyRegion(r)] copies the content of the region r into a malloced -// data structure containing all pages from the region and region -// descriptor information. -static RegionCopy* copyRegion(Ro *r); - -// [restoreRegion(rc)] restores the region rc->r from the region copy rc -// by copying back the original region page contents into the first -// region pages in the region. The function frees the remaining pages -// of the region. Returns 0 on success and -1 on error. -static int restoreRegion(RegionCopy *rc); - - -static int heapid_counter = 0; - -#include "Locks.h" - -static Heap **heapPool = NULL; // [MAX_HEAP_POOL_SZ]; -static unsigned int maxHeapPoolSz = MAX_HEAP_POOL_SZ; -static int heapPoolIndex = 0; - -// Invariant: if heapPoolIndex == 0 then there are no heaps in the -// heapPool to choose from; otherwise, the heapPool contains a heap -// we can use (index heapPoolIndex). Each heap in the pool has status -// HSTAT_CLEAN. - -// If heapPool == NULL then heapPoolIndex == 0 - -unsigned int -getMaxHeapPoolSz(void) -{ - unsigned int i; - LOCK_LOCK(STACKPOOLMUTEX); - i = maxHeapPoolSz; - LOCK_UNLOCK(STACKPOOLMUTEX); - return i; -} - -void -setMaxHeapPoolSz(unsigned int i) -{ - unsigned int j; - static Heap **tmp; - LOCK_LOCK(STACKPOOLMUTEX); - if (maxHeapPoolSz == i) - { - LOCK_UNLOCK(STACKPOOLMUTEX); - return; - } - if (!heapPool) - { - maxHeapPoolSz = i; - LOCK_UNLOCK(STACKPOOLMUTEX); - return; - } - tmp = calloc(i, sizeof(Heap *)); - if (!tmp) - { - LOCK_UNLOCK(STACKPOOLMUTEX); - // log something - return; - } - for (j = 0; j < maxHeapPoolSz; j++) - { - if (j < i) - { - tmp[j] = heapPool[j]; - } - else - { - if (j < heapPoolIndex) deleteHeap(heapPool[j]); - } - } - heapPoolIndex = heapPoolIndex > i ? i : heapPoolIndex; - free(heapPool); - heapPool = tmp; - LOCK_UNLOCK(STACKPOOLMUTEX); - return; -} - -// [pagesInRegion(r)] returns the number of pages associated with r. -static int pagesInRegion(Ro *r) -{ - Rp *p; - int n = 0; - for ( p = r->g0.fp ; p ; p = p->n ) - n++; - return n; -} - -static RegionCopy* copyRegion(Ro *r) -{ - size_t np, bytes; - uintptr_t *q; - Rp *p; - RegionCopy *rc; - size_t lobjSize = 0; - unsigned int nL = 0; - unsigned int padding = 0; - Lobjs *lobjs = NULL, *lobjs2 = NULL; - - for ( lobjs = r->lobjs ; lobjs ; lobjs = lobjs->next ) - { - lobjSize += sizeof(Lobjs) + lobjs->sizeOfLobj; - nL++; - } - - // printf("entering copyRegion r = %x\n", r); - - np = pagesInRegion(r); - - // printf("%d pages\n", np); - - bytes = sizeof(RegionCopy) + (sizeof(void *)) // for final null-pointer - + np * ((sizeof(void *)) * (ALLOCATABLE_WORDS_IN_REGION_PAGE + 1)); // + 1 is for page pointer - padding = bytes % sizeof(void *) ? sizeof(void *) - (bytes % sizeof(void *)) : 0; - rc = (RegionCopy*)malloc(bytes + padding + lobjSize); - rc->lobjs = r->lobjs ? (Lobjs *) (((char *) rc) + (bytes + padding)) : NULL; - - rc->r = r; // not really necessary - rc->a = r->g0.a; - rc->b = r->g0.b; - - rc->numOfLobjs = nL; - q = rc->pages; - for ( p = r->g0.fp ; p ; p = p->n ) - { - int i = 0; - *q++ = (uintptr_t)p; // set pointer to original page - while ( i < ALLOCATABLE_WORDS_IN_REGION_PAGE ) - *q++ = p->i[i++]; - } - *q = 0; // final null-pointer - - char *tmp = rc->lobjs ? (char *) (rc->lobjs + rc->numOfLobjs) : NULL; - lobjs2 = rc->lobjs; - for ( lobjs = r->lobjs ; lobjs ; lobjs = lobjs->next ) - { - lobjs2->next = (struct lobjs*) tmp; - memcpy(tmp, &(lobjs->value), lobjs->sizeOfLobj); - lobjs2->sizeOfLobj = lobjs->sizeOfLobj; - lobjs2++; - tmp += lobjs->sizeOfLobj; - } - return rc; -} - -static int restoreRegion(RegionCopy *rc) -{ - Rp *p = 0; - Rp *p_next = 0; - int i = 0; - while ( ( p_next = (Rp*)(rc->pages[i++]) ) ) // pointer to original region page is stored in copy! - { - int j = 0; - p = p_next; - while ( j < ALLOCATABLE_WORDS_IN_REGION_PAGE ) - p->i[j++] = rc->pages[i++]; - } - - free_region_pages(p->n,((Rp*)rc->r->g0.b)-1); - - p->n = NULL; // there is at least one page - rc->r->g0.a = rc->a; - rc->r->g0.b = rc->b; - size_t nL; - Lobjs *lobjs, *lobjs2 = NULL; - for (nL = 0, lobjs = rc->r->lobjs; lobjs; lobjs = lobjs->next) nL++; - for (lobjs = rc->r->lobjs; nL > rc->numOfLobjs; nL--) - { - lobjs2 = lobjs; - lobjs = lobjs->next; - } - if (lobjs2) - { - lobjs2->next = NULL; - free_lobjs(rc->r->lobjs); - rc->r->lobjs = lobjs; - } - for(nL = 0; nL < rc->numOfLobjs; nL++, lobjs = lobjs->next) - { - memcpy(&(lobjs->value), (rc->lobjs + nL)->next, (rc->lobjs + nL)->sizeOfLobj); - } - return 0; -} - -static Heap* newHeap(serverstate ss) -{ - Heap* h; - h = (Heap*)malloc(sizeof(Heap)); - if ( h == 0 ) - (*ss->report) (DIE, "newHeap: couldn't allocate room for heap",ss->aux); - h->status = HSTAT_UNINITIALIZED; - h->r0copy = NULL; - h->r2copy = NULL; - h->r3copy = NULL; - h->r4copy = NULL; - h->r5copy = NULL; - h->r6copy = NULL; - h->sp = NULL; - return h; -} - -Heap* getHeap(serverstate ss) -{ - Heap* h; - - LOCK_LOCK(STACKPOOLMUTEX); - if ( heapPoolIndex ) - { - // Sound as heapPoolIndex != 0 --> heapPool != NULL - h = heapPool[--heapPoolIndex]; - LOCK_UNLOCK(STACKPOOLMUTEX); - } - else // allocate new heap - { - int hid = heapid_counter++; - LOCK_UNLOCK(STACKPOOLMUTEX); - h = newHeap(ss); - h->heapid = hid; - } - - return h; -} - -void touchHeap(Heap* h, serverstate ss) -{ - if ( h->status != HSTAT_CLEAN ) - (*ss->report) (DIE, "touchHeap: status <> HSTAT_CLEAN",ss->aux); - h->status = HSTAT_DIRTY; -} - -static void freePages(RegionCopy *rc) -{ - if ( rc ) - { - free_region_pages(rc->r->g0.fp, (Rp*)(rc->r->g0.b) - 1); - free(rc); - } -} - -void deleteHeap(Heap *h) -{ - freePages(h->r0copy); - freePages(h->r2copy); - freePages(h->r3copy); - freePages(h->r4copy); - freePages(h->r5copy); - freePages(h->r6copy); - free(h); -} - -void releaseHeap(Heap *h, serverstate ss) -{ - restoreHeap(h,ss); - LOCK_LOCK(STACKPOOLMUTEX); -// if ( heapPoolIndex < MAX_HEAP_POOL_SZ ) - if ( heapPoolIndex < maxHeapPoolSz ) - { - if (!heapPool) - { - heapPool = (Heap **) calloc(maxHeapPoolSz, sizeof(Heap *)); - if (!heapPool) - { - LOCK_UNLOCK(STACKPOOLMUTEX); - deleteHeap(h); - return; - } - } - heapPool[heapPoolIndex++] = h; - LOCK_UNLOCK(STACKPOOLMUTEX); - } - else - { - LOCK_UNLOCK(STACKPOOLMUTEX); - deleteHeap(h); - } - return; -} - -static void restoreHeap(Heap *h, serverstate ss) -{ - int i; - if ( h->status != HSTAT_DIRTY ) - (*ss->report) (DIE, "restoreHeap: status <> HSTAT_DIRTY",ss->aux); - - if ( restoreRegion(h->r0copy) == -1 ) - (*ss->report) (DIE, "restoreHeap: failed to restore r0",ss->aux); - - if ( restoreRegion(h->r2copy) == -1 ) - (*ss->report) (DIE, "restoreHeap: failed to restore r2",ss->aux); - - if ( restoreRegion(h->r3copy) == -1 ) - (*ss->report) (DIE, "restoreHeap: failed to restore r3",ss->aux); - - if ( restoreRegion(h->r4copy) == -1 ) - (*ss->report) (DIE, "restoreHeap: failed to restore r4",ss->aux); - - if ( restoreRegion(h->r5copy) == -1 ) - (*ss->report) (DIE, "restoreHeap: failed to restore r5",ss->aux); - - if ( restoreRegion(h->r6copy) == -1 ) - (*ss->report) (DIE, "restoreHeap: failed to restore r6",ss->aux); - - for ( i = 0 ; i < LOWSTACK_COPY_SZ ; i++ ) - { - *(h->sp - i - 1) = h->lowStack[i]; - } - - h->status = HSTAT_CLEAN; -} - -void initializeHeap(Heap *h, uintptr_t *sp, uintptr_t *exnPtr, size_t exnCnt, serverstate ss) -{ - int i; - Ro *r0, *r2, *r3, *r4, *r5, *r6; - - if ( h->status != HSTAT_UNINITIALIZED ) - (*ss->report) (DIE, "initializeHeap: status <> HSTAT_UNINITIALIZED",ss->aux); - - r0 = clearStatusBits(*(Ro**)(h->ds)); // r0 is a pointer to a region description on the stack - r2 = r0+1; // r2 is a pointer to the next region description on the stack - r3 = r0+2; - r4 = r0+3; - r5 = r0+4; - r6 = r0+5; - - h->sp = sp; - h->exnPtr = exnPtr; - h->exnCnt = exnCnt; - - // printf("r0 = %x, r2 = %x, r3=%x, h=%x, ds=%x\n", r0,r2,r3,h,h->ds); - - h->r0copy = copyRegion(r0); - h->r2copy = copyRegion(r2); - h->r3copy = copyRegion(r3); - h->r4copy = copyRegion(r4); - h->r5copy = copyRegion(r5); - h->r6copy = copyRegion(r6); - - for ( i = 0 ; i < LOWSTACK_COPY_SZ ; i++ ) - { - h->lowStack[i] = *(sp - i - 1); - } - - h->status = HSTAT_CLEAN; -} - -void -clearHeapCache() -{ - Heap *h; - - LOCK_LOCK(STACKPOOLMUTEX); - while ( heapPoolIndex ) - { - // Sound as heapPoolIndex != 0 --> heapPool != NULL - h = heapPool[--heapPoolIndex]; - deleteHeap(h); - } - LOCK_UNLOCK(STACKPOOLMUTEX); - return; -} diff --git a/src/Runtime/HeapCache.h b/src/Runtime/HeapCache.h deleted file mode 100644 index 1d7e3f56c..000000000 --- a/src/Runtime/HeapCache.h +++ /dev/null @@ -1,92 +0,0 @@ -#ifndef HEAP_CACHE_H -#define HEAP_CACHE_H - -/* - * Checkpointing execution of library code - */ - -#include "Region.h" -#include "Stack.h" -#include "LoadKAM.h" - -// Pages are layed out in continuous memory, where each page -// (ALLOCATABLE_WORDS_IN_REGION_PAGE words) is prefixed with a -// pointer to the origin region page. - -typedef struct regionCopy { - uintptr_t *a; // allocation pointer - uintptr_t *b; // border pointer - Ro *r; // origin region - Lobjs *lobjs; // Large objects - size_t numOfLobjs; - size_t pages[0]; -} RegionCopy; - -#define HSTAT_UNINITIALIZED 0 -#define HSTAT_DIRTY 1 -#define HSTAT_CLEAN 2 - -// In the case that the global exception handler is triggered, the -// bottom of the stack is destroyed by the raise instruction; therefore -// we copy this part of the stack in a separate block in the heap, which -// allows the stack to be reestablished. -#define LOWSTACK_COPY_SZ 6 - -// Initial maximum number of allocated heaps (stacks and initial region pages) -// in the heap pool - important only for the multi-threaded SMLserver. The -// effect of using a heap from the heap pool is that execution of library code -// is cached. To enable execution of library code for every request, set -// MAX_HEAP_POOL_SZ to 0. This limit can be set dynamically by setMaxHeapPoolSz -// and read dynamically by getMaxHeapPoolSz -#define MAX_HEAP_POOL_SZ 6 - -typedef struct heap { - size_t heapid; // unique heap id - int status; // heap status - RegionCopy *r0copy; // rtype top - RegionCopy *r2copy; // rtype pair - RegionCopy *r3copy; // rtype string - RegionCopy *r4copy; // rtype array - RegionCopy *r5copy; // rtype ref - RegionCopy *r6copy; // rtype triple - size_t *sp; // stack pointer - uintptr_t *exnPtr; - size_t exnCnt; - uintptr_t lowStack[LOWSTACK_COPY_SZ]; // copy of global exception handler, etc. - uintptr_t ds[STACK_SIZE_INIT]; // start of data-space - // followed by stack -} Heap; - -// [getHeap()] returns a heap h from the pool of heaps with the status -// set to either HSTAT_UNINITIALIZED or HSTAT_CLEAN. In the latter -// case, the stack pointer h->sp and the dataspace counter &(h->ds) -// can be extracted and used for interpretation; all what remains is -// to interpret the leaf bytecode. In the former case, library code -// need first be executed, after which, the initializeHeap() function -// should be called. -Heap* getHeap(serverstate ss); - -// [touchHeap(h)] changes the status of the heap h to HSTAT_DIRTY. -// Requires the status to be HSTAT_CLEAN. -void touchHeap(Heap *h, serverstate ss); - -// [releaseHeap(h)] restores the heap from the heap copy information -// and gives back the heap h to the pool of heaps. Requires the heap -// status to be HSTAT_DIRTY. -void releaseHeap(Heap *h, serverstate ss); - -// [initializeHeap(h,sp,exnPtr,exnCnt)] This function should be -// called after library code is executed, but before leaf bytecode is -// executed. The function changes the status of the heap to -// HSTAT_CLEAN. It requires the heap status to be HSTAT_UNINITIALIZED. -void initializeHeap(Heap *h, uintptr_t *sp, uintptr_t *exnPtr, size_t exnCnt, serverstate ss); - -// [deleteHeap(h)] deletes the heap by freeing it. Also frees region -// pages in the regions in the heap. -void deleteHeap(Heap *h); - -// [clearHeapCache()] deletes all heaps in the pool of heaps. Assumes -// that no client has a handle to a heap. -void clearHeapCache(); - -#endif diff --git a/src/Runtime/IO.c b/src/Runtime/IO.c index c31a7d563..a8bfbbf73 100644 --- a/src/Runtime/IO.c +++ b/src/Runtime/IO.c @@ -25,72 +25,72 @@ #include "Runtime.h" uintptr_t -openInStream(String path, uintptr_t exn) /* SML Basis */ +openInStream(Context ctx, String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; if ((fileDesc = fopen(&(path->data), "r")) == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); } check_tag_scalar(fileDesc); return (uintptr_t)(tag_scalar(fileDesc)); } uintptr_t -openOutStream(String path, uintptr_t exn) /* SML Basis */ +openOutStream(Context ctx, String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; if ((fileDesc = fopen(&(path->data), "w")) == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); } check_tag_scalar(fileDesc); return (uintptr_t)(tag_scalar(fileDesc)); } uintptr_t -openAppendStream(String path, uintptr_t exn) /* SML Basis */ +openAppendStream(Context ctx, String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; if ((fileDesc = fopen(&(path->data), "a")) == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); } check_tag_scalar(fileDesc); return (uintptr_t)(tag_scalar(fileDesc)); } uintptr_t -openInBinStream(String path, uintptr_t exn) /* SML Basis */ +openInBinStream(Context ctx, String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; if ((fileDesc = fopen(&(path->data), "rb")) == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); } check_tag_scalar(fileDesc); return (uintptr_t)(tag_scalar(fileDesc)); } uintptr_t -openOutBinStream(String path, uintptr_t exn) /* SML Basis */ +openOutBinStream(Context ctx, String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; if ((fileDesc = fopen(&(path->data), "wb")) == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); } check_tag_scalar(fileDesc); return (uintptr_t)(tag_scalar(fileDesc)); } uintptr_t -openAppendBinStream(String path, uintptr_t exn) /* SML Basis */ +openAppendBinStream(Context ctx, String path, uintptr_t exn) /* SML Basis */ { FILE *fileDesc; if ((fileDesc = fopen(&(path->data), "ab")) == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); } check_tag_scalar(fileDesc); return (uintptr_t)(tag_scalar(fileDesc)); @@ -194,13 +194,13 @@ endOfStream(FILE *stream) */ size_t -outputStream(uintptr_t os1, String s, uintptr_t exn) +outputStream(Context ctx, uintptr_t os1, String s, uintptr_t exn) { FILE *os = (FILE *)untag_scalar(os1); if ( fputs(&(s->data), os) == EOF ) { fflush(os); - raise_exn(exn); + raise_exn(ctx,exn); } return mlUNIT; } @@ -234,39 +234,39 @@ stdErrStream(uintptr_t dummy) } void -sml_chdir(String dirname, uintptr_t exn) /* SML Basis */ +sml_chdir(Context ctx, String dirname, uintptr_t exn) /* SML Basis */ { if ( chdir(&(dirname->data)) != 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); } return; } void -sml_remove(String name, uintptr_t exn) /* SML Basis */ +sml_remove(Context ctx, String name, uintptr_t exn) /* SML Basis */ { int ret; ret = unlink(&(name->data)); if ( ret != 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); } return; } void -sml_rename(String oldname, String newname, uintptr_t exn) /* SML Basis */ +sml_rename(Context ctx, String oldname, String newname, uintptr_t exn) /* SML Basis */ { if ( rename(&(oldname->data), &(newname->data)) != 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); } return; } size_t -sml_access(String path, size_t permarg, uintptr_t exn) /* ML */ +sml_access(String path, size_t permarg) /* ML */ { long perms; long perm = convertIntToC(permarg); @@ -285,7 +285,7 @@ sml_access(String path, size_t permarg, uintptr_t exn) /* ML */ } String -REG_POLY_FUN_HDR(sml_getdir, Region rAddr, uintptr_t exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_getdir, Region rAddr, Context ctx, uintptr_t exn) /* SML Basis */ { char directory[MAXPATHLEN]; char *res; @@ -293,18 +293,18 @@ REG_POLY_FUN_HDR(sml_getdir, Region rAddr, uintptr_t exn) /* S res = getcwd(directory, MAXPATHLEN); if ( res == NULL ) { - raise_exn(exn); + raise_exn(ctx,exn); } return REG_POLY_CALL(convertStringToML, rAddr, directory); } size_t -sml_isdir(String path, uintptr_t exn) /* SML Basis */ +sml_isdir(Context ctx, String path, uintptr_t exn) /* SML Basis */ { struct stat buf; if ( stat(&(path->data), &buf) == -1 ) { - raise_exn(exn); + raise_exn(ctx,exn); } if (S_ISDIR(buf.st_mode)) { @@ -314,23 +314,23 @@ sml_isdir(String path, uintptr_t exn) /* SML Basis */ } void -sml_mkdir(String path, uintptr_t exn) /* SML Basis */ +sml_mkdir(Context ctx, String path, uintptr_t exn) /* SML Basis */ { if ( mkdir(&(path->data), 0777) == -1 ) { - raise_exn(exn); + raise_exn(ctx,exn); } return; } uintptr_t -sml_modtime(uintptr_t vAddr, String path, uintptr_t exn) /* SML Basis */ +sml_modtime(uintptr_t vAddr, Context ctx, String path, uintptr_t exn) /* SML Basis */ { struct stat buf; if ( stat(&(path->data), &buf) == -1 ) { - raise_exn(exn); + raise_exn(ctx,exn); } get_d(vAddr) = (double)(buf.st_mtime); set_dtag(vAddr); @@ -338,53 +338,53 @@ sml_modtime(uintptr_t vAddr, String path, uintptr_t exn) /* SML Basi } void -sml_rmdir(String path, uintptr_t exn) /* SML Basis */ +sml_rmdir(Context ctx, String path, uintptr_t exn) /* SML Basis */ { if ( rmdir(&(path->data)) == -1 ) { - raise_exn(exn); + raise_exn(ctx,exn); } return; } void -sml_settime(String path, uintptr_t time, uintptr_t exn) /* SML Basis */ +sml_settime(Context ctx, 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 ) { - raise_exn(exn); + raise_exn(ctx,exn); } return; } size_t -sml_filesize(String path, uintptr_t exn) /* SML Basis */ +sml_filesize(Context ctx, String path, uintptr_t exn) /* SML Basis */ { struct stat buf; if ( stat(&(path->data), &buf) == -1 ) { - raise_exn(exn); + raise_exn(ctx,exn); } return (convertIntToML(buf.st_size)); } uintptr_t -sml_opendir(String path, uintptr_t exn) /* SML Basis */ +sml_opendir(Context ctx, String path, uintptr_t exn) /* SML Basis */ { DIR * dstr; dstr = opendir(&(path->data)); if ( dstr == NULL ) { - raise_exn(exn); + raise_exn(ctx,exn); } check_tag_scalar(dstr); return (uintptr_t)tag_scalar(dstr); } String -REG_POLY_FUN_HDR(sml_readdir, Region rAddr, uintptr_t v, uintptr_t exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_readdir, Region rAddr, Context ctx, uintptr_t v, uintptr_t exn) /* SML Basis */ { struct dirent *direntry; String res; @@ -393,7 +393,7 @@ REG_POLY_FUN_HDR(sml_readdir, Region rAddr, uintptr_t v, uintptr_t exn) /* SM direntry = readdir(dir_ptr); if (direntry == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); return NULL; } else @@ -414,14 +414,14 @@ sml_rewinddir(uintptr_t v) /* SML Basis */ } void -sml_closedir(uintptr_t v, uintptr_t exn) /* SML Basis */ +sml_closedir(Context ctx, uintptr_t v, uintptr_t exn) /* SML Basis */ { DIR *dir_ptr; dir_ptr = (DIR *)untag_scalar(v); if (closedir(dir_ptr) == -1) { - raise_exn(exn); + raise_exn(ctx,exn); } return; } @@ -444,12 +444,12 @@ REG_POLY_FUN_HDR(sml_errormsg, Region rAddr, size_t errnum) /* SML Basis */ } size_t -sml_islink(String path, uintptr_t exn) /* SML Basis */ +sml_islink(Context ctx, String path, uintptr_t exn) /* SML Basis */ { struct stat buf; if (lstat(&(path->data), &buf) == -1) { - raise_exn(exn); + raise_exn(ctx,exn); } if (S_ISLNK(buf.st_mode)) { @@ -459,12 +459,12 @@ sml_islink(String path, uintptr_t exn) /* SML Basis */ } size_t -sml_isreg(size_t fd, uintptr_t exn) /* SML Basis */ +sml_isreg(Context ctx, size_t fd, uintptr_t exn) /* SML Basis */ { struct stat buf; if (fstat(convertIntToC(fd), &buf) == -1) { - raise_exn(exn); + raise_exn(ctx, exn); } if (S_ISREG(buf.st_mode)) { @@ -474,25 +474,25 @@ sml_isreg(size_t fd, uintptr_t exn) /* SML Basis */ } size_t -sml_filesizefd(size_t fd, uintptr_t exn) /* SML Basis */ +sml_filesizefd(Context ctx, size_t fd, uintptr_t exn) /* SML Basis */ { struct stat buf; if (fstat(convertIntToC(fd), &buf) == -1) { - raise_exn(exn); + raise_exn(ctx,exn); } return convertIntToML(buf.st_size); } String -REG_POLY_FUN_HDR(sml_readlink, Region rAddr, String path, uintptr_t exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_readlink, Region rAddr, Context ctx, String path, uintptr_t exn) /* SML Basis */ { char buffer[MAXPATHLEN]; long result; result = readlink(&(path->data), buffer, MAXPATHLEN); if (result == -1 || result >= MAXPATHLEN) { - raise_exn(exn); + raise_exn(ctx,exn); } buffer[result] = '\0'; return REG_POLY_CALL(convertStringToML, rAddr, buffer); @@ -501,26 +501,26 @@ REG_POLY_FUN_HDR(sml_readlink, Region rAddr, String path, uintptr_t exn) /* S extern char *realpath(); String -REG_POLY_FUN_HDR(sml_realpath, Region rAddr, String path, uintptr_t exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_realpath, Region rAddr, Context ctx, String path, uintptr_t exn) /* SML Basis */ { char buffer[MAXPATHLEN]; char *result; result = realpath(&(path->data), buffer); if (result == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); return NULL; } return REG_POLY_CALL(convertStringToML, rAddr, result); } uintptr_t -sml_devinode(uintptr_t vAddr, String path, uintptr_t exn) /* SML Basis */ +sml_devinode(uintptr_t vAddr, Context ctx, String path, uintptr_t exn) /* SML Basis */ { struct stat buf; if (stat(&(path->data), &buf) == -1) { - raise_exn(exn); + raise_exn(ctx,exn); } // Return a pair of the device and the inode first(vAddr) = convertIntToML((uintptr_t)buf.st_dev); @@ -530,7 +530,7 @@ sml_devinode(uintptr_t vAddr, String path, uintptr_t exn) /* SML Bas } size_t -sml_system(String cmd, uintptr_t exn) /* SML Basis */ +sml_system(String cmd) /* SML Basis */ { int res; res = system(&(cmd->data)); @@ -542,19 +542,19 @@ sml_system(String cmd, uintptr_t exn) /* SML Basis */ } String -REG_POLY_FUN_HDR(sml_getenv, Region rAddr, String var, uintptr_t exn) /* SML Basis */ +REG_POLY_FUN_HDR(sml_getenv, Region rAddr, Context ctx, String var, uintptr_t exn) /* SML Basis */ { char *res; res = (char *)(getenv(&(var->data))); if (res == NULL) { - raise_exn(exn); + raise_exn(ctx,exn); } return REG_POLY_CALL(convertStringToML, rAddr, res); } size_t -outputBinStream(uintptr_t os1, String s, uintptr_t exn) +outputBinStream(Context ctx, uintptr_t os1, String s, uintptr_t exn) { long strsize; FILE *os = (FILE *) os1; strsize = sizeStringDefine(s); @@ -562,7 +562,7 @@ outputBinStream(uintptr_t os1, String s, uintptr_t exn) if ( fwrite(&(s->data), 1, strsize, os) != strsize ) { fflush(os); - raise_exn(exn); + raise_exn(ctx,exn); } return mlUNIT; } diff --git a/src/Runtime/IO.h b/src/Runtime/IO.h index feebc54f6..191fa29f3 100644 --- a/src/Runtime/IO.h +++ b/src/Runtime/IO.h @@ -12,13 +12,13 @@ /*----------------------------------------------------------------* * Prototypes for external and internal functions. * *----------------------------------------------------------------*/ -uintptr_t openInStream(String filenamePtr, uintptr_t exn); -uintptr_t openOutStream(String filenamePtr, uintptr_t exn); -uintptr_t openAppendStream(String filenamePtr, uintptr_t exn); +uintptr_t openInStream(Context ctx, String filenamePtr, uintptr_t exn); +uintptr_t openOutStream(Context ctx, String filenamePtr, uintptr_t exn); +uintptr_t openAppendStream(Context ctx, String filenamePtr, uintptr_t exn); void closeStream(uintptr_t stream); // int endOfStream(FILE *stream); -uintptr_t outputStream(uintptr_t outStream, String stringPtr, uintptr_t exn); -uintptr_t outputBinStream(uintptr_t outStream, String stringPtr, uintptr_t exn); +uintptr_t outputStream(Context ctx, uintptr_t outStream, String stringPtr, uintptr_t exn); +uintptr_t outputBinStream(Context ctx, uintptr_t outStream, String stringPtr, uintptr_t exn); void flushStream(uintptr_t stream); uintptr_t stdInStream(uintptr_t dummy); uintptr_t stdOutStream(uintptr_t dummy); diff --git a/src/Runtime/Interp.c b/src/Runtime/Interp.c deleted file mode 100644 index 505f86ce8..000000000 --- a/src/Runtime/Interp.c +++ /dev/null @@ -1,1639 +0,0 @@ -/* The Bytecode Interpreter for the Kit Abstract Machine */ - -/* Registers for the KAM - pc the code pointer - sp the stack pointer (grows downward) - acc the accumulator - env the closure environment - exn_ptr pointer to the current exception frame - freelist pointer to the free list -- declared in Region.h -*/ - -#include -#include -#include -#include -#include -#include -#include /* to allow user-defined C-functions to raise exceptions using - * the raise_exn primitive */ -#include /* Dynamic linking */ -#include - -#include "Runtime.h" -#include "Stack.h" -#include "Tagging.h" -#include "KamInsts.h" -#include "Region.h" -#include "LoadKAM.h" -#include "List.h" -#include "Exception.h" -#include "Interp.h" -#include "String.h" -#include "Math.h" -#include "Table.h" -#include "Locks.h" -#include "Dlsym.h" -#include "Prims.h" - -// extern void checkCaches(void *); - -#ifdef KAM -Exception *exn_OVERFLOW; // Initialized in Interp.c -Exception *exn_INTERRUPT; // Initialized in Interp.c -Exception *exn_BIND; // Initialized in Interp.c -Exception *exn_DIV; // Initialized in Interp.c -Exception *exn_MATCH; // Initialized in Interp.c -jmp_buf global_exn_env; // -void raise_exn(uintptr_t exn) { - longjmp(global_exn_env, (int)exn); // never returns -} -#endif - -size_t -printList (uintptr_t l) { // function to print out a list - printf("\nList = ["); - for (; isCONS(l); l = tl(l)) - printf("%#016lx : elem = %#016lx\n", (unsigned long)l, (unsigned long) hd(l)); - printf("]\n"); - return mlUNIT; -} - -/* A sequence of bytecodes */ -// typedef unsigned char * bytecode_t; -// bytecode_t start_code; - -typedef int int32; -typedef unsigned int uint32; - -#define SHORT (sizeof(short)) -#define LONG (sizeof(int32)) -#define DOUBLE (sizeof(double)) - -#define s32(p) (* (int32 *) (p)) -#define s32_1(p) (* (int32 *) (p+4)) -#define s32_2(p) (* (int32 *) (p+8)) -#define u32_1(p) (* (uint32 *) (p+4)) -#define u32_2(p) (* (uint32 *) (p+8)) -#define u32(p) (* (uint32 *) (p)) - -#define u8pc (unsigned char)(*pc) -#define s32pc s32(pc) -#define s32_1pc s32_1(pc) -#define s32_2pc s32_2(pc) -#define u32pc u32(pc) -#define u32_1pc u32_1(pc) -#define u32_2pc u32_2(pc) -#define inc32pc pc += 4 -#define inc2_32pc pc += 8 - -#define Raise(EXNVALUE) { \ - debug(printf("RAISE; EXNVALUE = %x\n", EXNVALUE)); \ - deallocateRegionsUntil((Region)exnPtr, topRegionCell); \ - debug(printf(" after deallocateRegionsUntil\n")); \ - \ - sp = exnPtr - 1; /* reset stack pointer */ \ - exnPtr = (uintptr_t *)*exnPtr; /* enable the previous handler */ \ - \ - debug(printf(" now calling the handler function\n")); \ - /* now do the function call! The \ - * closure and the return address \ - * are on the stack... */ \ - env = (int *) selectStackDef(0); /* one argument */ \ - debug(printf("Writing to sp = 0x%x\n", sp -1)); \ - pushDef(EXNVALUE); \ - pc = (bytecode_t) *env; \ -} - -// FIXME setjmp and longjmp only handles integers. Thus an exception map is needed. - -#define Setup_for_c_call int return_value; \ - if( (return_value = setjmp(global_exn_env)) == 0 ) { - - -#define Restore_after_c_call } else { \ - debug(printf("\n***Exception raised***\n")); \ - acc = return_value; \ - goto raise_exception; \ - } - -#define JUMPTGT(offset) (bytecode_t)(pc + offset) -#define branch() pc = JUMPTGT(s32pc) - -#ifdef LAB_THREADED -#define Instruct(name) lbl_##name -// #define Next { temp = (int)pc; inc32pc; if ((inst_count++ % 1000) == 0) debug_writer5 ("INST %d, %d, env 0x%x, *env 0x%x --- **(ds + 0x5fb) = 0x%x\n", inst_count, getInstNumber(jumptable, jumptableSize, *(void **) temp), (int) env, (uint) env > 100 ? *env : 0, debug_file != -1 ? *((unsigned long *)*(ds + 0x5fb)) : 0); goto **(void **)temp; } -// #define Next { temp = (int)pc; inc32pc; inst_count++; /*if ((inst_count % 1) == 0)*/ debug_writer2 ("INST %d, %d %x\n", inst_count, getInstNumber(jumptable, jumptableSize, *(void **) temp)); checkCaches(serverCtx->aux); goto **(void **)temp; } -#define Next { temp = (uintptr_t)pc; inc32pc; goto **(void **)temp; } -#else -#define Instruct(name) case name -#define Next break -#endif /*LAB_THREADED*/ - -#ifdef DEBUG -#define debug(Arg) Arg -#else -#define debug(Arg) {} -#endif - -#define primintbinop(name,msg,bop) \ - Instruct(name): { \ - acc = ((int)(popValDef)) bop ((int)acc); \ - debug(printf("%s gives %d\n", msg,acc)); \ - Next; \ - } - -#define primfbinop(name,msg,bop) \ - Instruct(name): { \ - *(double*)acc = (*(double*)selectStackDef(-2)) bop (*(double*)selectStackDef(-1)); \ - popNDef(2); \ - Next; \ - } - -#define primfunaryop(name,msg,uop) \ - Instruct(name): { \ - *(double*)acc = uop (*(double*)popValDef); \ - Next; \ - } - -#define primwbinop(name,msg,bop) \ - Instruct(name): { \ - acc = ((unsigned long)(popValDef)) bop ((unsigned long)acc); \ - debug(printf("%s gives %x\n", msg,acc)); \ - Next; \ - } - -#define priminttest(name,msg,tst) \ - Instruct(name): { \ - if (((int)popValDef) tst ((int)acc)) \ - acc = mlTRUE; \ - else \ - acc = mlFALSE; \ - debug(printf("%s gives acc = %d\n", msg, acc)); \ - Next; \ - } - -#define primftest(name,msg,tst) \ - Instruct(name): { \ - if (get_d(popValDef) tst get_d(acc)) \ - acc = mlTRUE; \ - else \ - acc = mlFALSE; \ - debug(printf("%s gives acc = %d\n", msg, acc)); \ - Next; \ - } - - -#define primwtest(name,msg,tst) \ - Instruct(name): { \ - unsigned long t1, t2; \ - t1 = (unsigned long)popValDef; \ - t2 = (unsigned long)acc; \ - if ((t1) tst (t2)) \ - acc = mlTRUE; \ - else \ - acc = mlFALSE; \ - debug(printf("%s(%d,%d) gives acc = %d\n", msg, t1, t2, acc)); \ - Next; \ - } - -/* the following doesn't work with gcc 2.96 under Redhat 7.0 ... -#define primwtest(name,msg,tst) \ - Instruct(name): { \ - if (((unsigned long)popValDef) tst ((unsigned long)acc)) \ - acc = mlTRUE; \ - else \ - acc = mlFALSE; \ - debug(printf("%s gives acc = %d\n", msg, acc)); \ - Next; \ - } -*/ -// Do not pop value on stack, as used by the binary search -// on switches. - -/* -#define iftest(name, msg,tst) \ - Instruct(name): { \ - if (((int)selectStackDef(-1)) tst ((int)acc)) \ - branch(); \ - else \ - inc32pc; \ - debug(printf("%s %d and %d\n", msg,selectStackDef(-1),acc)); \ - Next; \ - } -*/ - -#define iftestimmed(name, msg, tst) \ - Instruct(name): { \ - debug(printf("%s %d and %d\n",msg,acc,s32_1pc)); \ - if (((int)acc) tst ((int)s32_1pc)) \ - branch(); \ - else { \ - inc32pc; \ - inc32pc; \ - } \ - Next; \ - } - -#define allocN { \ - debug(printf("allocN %d\n", s32pc)); \ - acc = (int) alloc((Region)acc, s32pc); \ -} - -#define allocIfInfN { \ - debug(printf("allocIfInfN %d acc = 0x%x\n", s32pc, acc)); \ - if (is_inf(acc)) { \ - debug(printf(" allocating\n")); \ - acc = (int) alloc((Region)acc, s32pc); \ - } \ -} - -#define allocSatInfN { \ - debug(printf("allocSatInfN %d\n", s32pc)); \ - if (is_atbot((Region)acc)) \ - resetRegion((Region)acc); \ - acc = (int) alloc((Region)acc, s32pc); \ -} - -#define allocSatIfInfN { \ - debug(printf("allocSatIfInfN %d acc = 0x%x\n", s32pc,acc)); \ - if (is_inf_and_atbot((Region)acc)) { \ - resetRegion((Region)acc); \ - debug(printf(" resetting\n")); \ - } \ - if (is_inf((Region)acc)) { \ - debug(printf(" allocating\n")); \ - acc = (int) alloc((Region)acc, s32pc); \ - } \ -} - -#define allocAtbotN { \ - debug(printf("allocAtbotN %d\n", s32pc)); \ - resetRegion((Region)acc); \ - acc = (int) alloc((Region)acc, s32pc); \ -} - -#define blockCopy2 { \ - *((int *)acc + 1) = popValDef; \ - *((int *)acc) = popValDef; \ -} - -#define blockCopyN { \ - debug(printf("blockCopyN %d at %x\n", s32pc,acc)); \ - for (temp=s32pc-1;temp>=0;temp--) \ - *(((int *)acc)+temp) = popValDef; \ -} - - -/* To get things to work with threadding, we need to be able to - * transform instruction numbers to instruction addresses (pointers to - * labels, e.g.: &&lbl_RETURN). Unfortunately, the address of a label - * in a C function can be taken only inside the C function. In our case, - * the instruction addresses within the interp function can be resolved - * with the notation &&lbl_RETURN only within the function interp. - * - * Thus, to make it possible to transform code sequences separately from the - * execution step (e.g., for caching), we arrange that interp can be - * in two modes, `RESOLVEINSTS' and `INTERPRET'. When interp is called in `RESOLVEINSTS' - * mode, instructions are resolved in the code and the interp function returns - * without the code being executed. In this mode, the value of sp, ds, and - * exnCnt are not used. Contrary, when interp is called in mode - * `INTERPRET', the interp function executes the code, assuming that instructions - * have been resolved already. - */ - -/* -static int -getInstNumber(void *jumptable[], unsigned int jumptableSize, void *inst) -{ - unsigned int i; - for (i = 0; i < jumptableSize; i++) - { - if (inst == jumptable[i]) return i; - } - return -1; -} -*/ - -/* replace instruction numbers with instruction addresses */ -void -resolveInstructions(int sizeW, bytecode_t start_code, - void * jumptable [], unsigned int jumptableSize, - void *ccalltable[]) { - unsigned long *real_code; - int tmp, tmp2; - int j, i = 0; - real_code = (unsigned long*)start_code; - - while ( i < sizeW ) { - int arity; - unsigned long inst; - inst = *(real_code + i); - arity = getInstArity(inst); - if ( arity == -100 ) - { // Check to see if we already resolved this code - // This is not entirely sound, but it would be very coincidential - // if an instrution number without an arity is the same as - // a pointer to an instruction in our interpreter. - // This is needed to let apache restart without trouble - for (j = 0; j < jumptableSize; j++) - { - if (((unsigned long) jumptable[j]) == inst) - { - return; - } - } - fprintf(stderr, "No arity for inst %ld\n", inst); - die("Interp.resolveInstructions"); - } - debug(printf("i=%d ; inst = %d; arity = %d\n", i, inst, arity)); - if (inst > 1000) { - printf ("sizeW = %d, i= %d, inst = %ld\n", sizeW, i, inst); - die ("resolveInstructions: Hmm - inst number > 1000"); - } - *(real_code + i) = (unsigned long)(jumptable[inst]); - for (tmp = 0, tmp2 = 0; tmp < 7; tmp++) - { - if (jumptable[inst] == ccalltable[tmp]) tmp2 = 1; - } - if (tmp2) - { - inst = real_code[i+1]; - if (inst != 0) // Static Ccall - { - //printf("converting %d to %x\n", inst, cprim[inst-1]); - real_code[i+1] = (unsigned long) cprim[inst-1]; - } - } - switch (arity) { /* IMMED_STRING -- compute arity... */ - case -1: - { - int str_size; - int str_size_bytes = get_string_size(*(real_code + i + 1)); - str_size_bytes += 1; // zero-termination - if (str_size_bytes % 4 != 0) - str_size_bytes += (4 - (str_size_bytes % 4)); - str_size = str_size_bytes / 4; - arity = str_size + 1; /*tag*/ - break; - } - case -2: - { /* JMP_VECTOR -- compute arity */ - int jvec_size = *(real_code + i + 3); - arity = jvec_size + 3; - debug(printf("jvec_size = %d; arity = %d\n", jvec_size, arity)); - break; - } - case -3: - { - die ("resolveInstructions: DOT_LABEL - opcode not expected!"); - break; - } - case -4: - { - die ("resolveInstructions: LABEL - opcode not expected!"); - break; - } - }; - i += (arity + 1); /* 1 for the opcode */ - } -} - -enum interp_mode { - RESOLVEINSTS, - INTERPRET -}; - -static ssize_t -interp(Interp* interpreter, // Interp; NULL if mode=RESOLVEINSTS - uintptr_t * sp0, // Stack pointer - uintptr_t * ds, // Data segment pointer - uintptr_t * exnPtr, // Pointer to next exn-handler on stack - Ro ** topRegionCell, // Cell for holding a pointer to the top-most region - char ** errorStr, // Cell to store error-string in case of an uncaught exception - size_t *exnCnt, // Exception name counter - bytecode_t b_prog, // The actual code - size_t sizeW, // Size of code in words - int interp_mode, // Mode: RESOLVEINSTS or INTERPRET - serverstate serverCtx) // Apache request_rec pointer -{ - -/* Declarations for the registers of the abstract machine. - The most heavily used registers come first. - For reasonable performance, "pc" MUST reside in a register. - Many ``optimizing'' compilers underestimate the importance of "pc", - and don't put it in a register. - For GCC users, registers are hans-assigned for some architectures. -*/ - - register ssize_t acc; - -#if defined(__GNUC__) && defined(i386) - register bytecode_t pc asm("%esi"); - register uintptr_t * sp asm("%edi"); -#else - register bytecode_t pc; - register uintptr_t * sp; -#endif - - bytecode_t pc_temp; - int *env = NULL; - uint32 cur_instr = 0; - ssize_t temp; - ssize_t *tmp2; - // c_primitive primtmp; - - -#ifdef LAB_THREADED - static void * jumptable[] = { -# include "jumptbl.h" - }; - static void *ccalltable[] = - { - &&lbl_C_CALL0, - &&lbl_C_CALL1, - &&lbl_C_CALL2, - &&lbl_C_CALL3, - &&lbl_C_CALL4, - &&lbl_C_CALL5, - &&lbl_C_CALL6, - &&lbl_C_CALL7 - }; - static size_t jumptableSize = sizeof(jumptable) / sizeof(void *); -#endif - - acc = convertIntToML(0); - pc = b_prog; - sp = sp0; - - debug(printf("Entering interp\n")); - - if ( interp_mode == RESOLVEINSTS ) { -#ifdef LAB_THREADED - resolveInstructions(sizeW, b_prog, jumptable, jumptableSize, ccalltable); - debug(printf("returning from interp\n")); -#endif - return 0; - } - -#ifdef LAB_THREADED - debug_writer1("interp %d Jump to FIRST INSTRUCTION\n",0); - debug_file_as(unsigned long inst_count,0); - Next; // jump to first instruction -#else - while (1) { - debug(if ( (unsigned long)pc < 10000 ) printf("*** LOW PC ***\n") ); - cur_instr = u32pc; - debug(printf("0x%x: ", pc)); - inc32pc; - switch (cur_instr) { -#endif /*LAB_THREADED*/ - - Instruct(ALLOC_N): { - allocN; - inc32pc; - Next; - } - Instruct(ALLOC_IF_INF_N): { - allocIfInfN; - inc32pc; - Next; - } - Instruct(ALLOC_SAT_INF_N): { - allocSatInfN; - inc32pc; - Next; - } - Instruct(ALLOC_SAT_IF_INF_N): { - allocSatIfInfN; - inc32pc; - Next; - } - Instruct(ALLOC_ATBOT_N): { - allocAtbotN; - inc32pc; - Next; - } - Instruct(BLOCK_ALLOC_2): { - acc = (int) alloc((Region)acc, 2); - blockCopy2; - Next; - } - Instruct(BLOCK_ALLOC_N): { - allocN; - blockCopyN; - inc32pc; - Next; - } - Instruct(BLOCK_ALLOC_IF_INF_N): { - allocIfInfN; - blockCopyN; - inc32pc; - Next; - } - Instruct(BLOCK_ALLOC_SAT_INF_N): { - allocSatInfN; - blockCopyN; - inc32pc; - Next; - } - Instruct(BLOCK_N): { - blockCopyN; - inc32pc; - Next; - } - Instruct(BLOCK_ALLOC_SAT_IF_INF_N): { - allocSatIfInfN; - blockCopyN; - inc32pc; - Next; - } - Instruct(BLOCK_ALLOC_ATBOT_N): { - allocAtbotN; - blockCopyN; - inc32pc; - Next; - } - Instruct(CLEAR_ATBOT_BIT): { - debug(printf("clearAtbotBit\n")); - acc = clearAtbotBit(acc); - Next; - } - - Instruct(SET_BIT_30): - Instruct(SET_ATBOT_BIT): { - debug(printf("setAtbotBit\n")); - acc = setAtbotBit(acc); - Next; - } - Instruct(SET_BIT_31): { - debug(printf("setInfiniteBit\n")); - acc = setInfiniteBit(acc); - Next; - } - - Instruct(CLEAR_BIT_30_AND_31): { - debug(printf("clearBitStatusBits\n")); - acc = (int)clearStatusBits((Region)acc); - Next; - } - - Instruct(PUSH): { - pushDef(acc); - debug(printf("PUSH with acc %d (0x%x) - sp = 0x%x\n", acc,acc,sp)); - Next; - } - Instruct(PUSH_LBL): { - debug(printf("PUSH_LBL: %x\n", JUMPTGT(s32pc))); - debug_writer2 ("PUSH_LBL pc = 0x%x - *pc = 0x%x\n", (int) pc, (int) s32pc); - pushDef((int) JUMPTGT(s32pc)); - inc32pc; - Next; - } - - Instruct(POP_1): { popNDef(1); Next; } - Instruct(POP_2): { popNDef(2); Next; } - - Instruct(POP_N): { - popNDef(s32pc); - debug(printf("POP_N(%d) - sp = 0x%x\n",s32pc, sp)); - inc32pc; - Next; - } - - Instruct(APPLY_FN_CALL): { /*mael: ok*/ - debug(printf("APPLY_FN_CALL(acc %d, num args %d, return address %x on stack address %x)\n",acc,s32pc,selectStackDef(-s32pc-1), sp-s32pc-1)); - temp = (int) env; - env = (int *) selectStackDef(-s32pc); - selectStackDef(-s32pc) = temp; - debug(printf("Writing to sp = 0x%x\n", sp -s32pc)); - pushDef(acc); - pc = (bytecode_t) *env; - Next; - } - Instruct(APPLY_FN_JMP): { /*mael: ok*/ - debug(printf("APPLY_FN_JMP(acc %d, num args = %d, num rets = %d)\n",acc,s32pc,s32_1pc)); - env = (int *) selectStackDef(-s32pc); - for (temp=0;temp temp ) goto raise_overflow; - Next; - */ - } - - Instruct(PRIM_SUB_I2): { - if ( acc == Min_Int || acc == Min_Int + 1 ) goto raise_overflow; - acc = acc - 2; - Next; - /* - temp = acc; - acc = acc - 2; - if ( acc > temp ) goto raise_overflow; - Next; - */ - } - - Instruct(PRIM_SUB_I): { - int temp1 = popValDef; - temp = acc; - acc = temp1 - temp; - debug(printf("PRIM_SUB_I gives %d\n", acc)); - if ( ( temp1 > 0 && temp < 0 && (acc < -temp || acc < temp1) ) - || ( temp1 <= 0 && temp > 0 && (acc > -temp || acc > temp1) ) ) - goto raise_overflow; - Next; - } - - Instruct(PRIM_ADD_I1): { - if ( acc == Max_Int ) goto raise_overflow; - acc = acc + 1; - Next; - /* - temp = acc; - acc = acc + 1; - if ( acc < temp ) goto raise_overflow; - Next; - */ - } - - Instruct(PRIM_ADD_I2): { - if ( acc == Max_Int || acc == Max_Int - 1 ) goto raise_overflow; - acc = acc + 2; - Next; - /* - temp = acc; - acc = acc + 2; - if ( (int)acc < (int)temp ) goto raise_overflow; - Next; - */ - } - - Instruct(PRIM_ADD_I): { - int temp1 = popValDef; - temp = acc; - acc = temp1 + acc; - debug(printf("PRIM_ADD_I gives %d\n", acc)); - if ( ( temp1 > 0 && temp > 0 && (acc < temp || acc < temp1) ) - || ( temp1 <= 0 && temp < 0 && (acc > temp || acc > temp1) ) ) - goto raise_overflow; - Next; - } - - Instruct(PRIM_MUL_I): { - int temp1 = popValDef; - temp = acc; - acc = temp1 * temp; - debug(printf("PRIM_MUL_I gives %d\n", acc)); - if ( (temp1 != 0) && (acc / temp1 != temp) ) - goto raise_overflow; - Next; - } - - primwbinop(PRIM_SUB_W,"PRIM_SUB_W",-); - primwbinop(PRIM_ADD_W,"PRIM_ADD_W",+); - primwbinop(PRIM_MUL_W,"PRIM_MUL_W",*); - - primwbinop(PRIM_AND_W,"PRIM_AND_W", &); - primwbinop(PRIM_OR_W,"PRIM_OR_W", |); - primwbinop(PRIM_XOR_W,"PRIM_XOR_W", ^); - primwbinop(PRIM_SHIFT_LEFT_W,"PRIM_SHIFT_LEFT_W", <<); - primintbinop(PRIM_SHIFT_RIGHT_SIGNED_W,"PRIM_SHIFT_RIGHT_SIGNED_W", >>); - primwbinop(PRIM_SHIFT_RIGHT_UNSIGNED_W,"PRIM_SHIFT_RIGHT_UNSIGNED_W", >>); - - priminttest(PRIM_EQUAL_I,"PRIM_EQUAL_I",==); - priminttest(PRIM_LESS_EQUAL,"PRIM_LESS_EQUAL",<=); - priminttest(PRIM_LESS_THAN,"PRIM_LESS_THAN",<); - priminttest(PRIM_GREATER_THAN,"PRIM_GREATER_THAN",>); - priminttest(PRIM_GREATER_EQUAL,"PRIM_GREATER_EQUAL",>=); - - primwtest(PRIM_LESS_EQUAL_UNSIGNED,"PRIM_LESS_EQUAL_UNSIGNED",<=); - primwtest(PRIM_LESS_THAN_UNSIGNED,"PRIM_LESS_THAN_UNSIGNED",<); - primwtest(PRIM_GREATER_THAN_UNSIGNED,"PRIM_GREATER_THAN_UNSIGNED",>); - primwtest(PRIM_GREATER_EQUAL_UNSIGNED,"PRIM_GREATER_EQUAL_UNSIGNED",>=); - - // Special instructions for binary search on switches. - - Instruct(IF_NOT_EQ_JMP_REL_IMMED3): { - if (((int)acc) != 3) - branch(); - else { - inc32pc; - } - Next; - } - - iftestimmed(IF_NOT_EQ_JMP_REL_IMMED,"IF_NOT_EQ_JMP_REL_IMMED",!=); - iftestimmed(IF_LESS_THAN_JMP_REL_IMMED,"IF_LESS_THAN_JMP_REL_IMMED",<); - iftestimmed(IF_GREATER_THAN_JMP_REL_IMMED,"IF_GREATER_THAN_JMP_REL_IMMED",>); - - // Floating point instructions - primfbinop(PRIM_ADD_F, "PRIM_ADD_F", +); - primfbinop(PRIM_SUB_F, "PRIM_SUB_F", -); - primfbinop(PRIM_MUL_F, "PRIM_MUL_F", *); - primfbinop(PRIM_DIV_F, "PRIM_DIV_F", /); - primfunaryop(PRIM_NEG_F, "PRIM_NEG_F", -); - primfunaryop(PRIM_ABS_F, "PRIM_ABS_F", fabs); - primftest(PRIM_LESS_EQUAL_F,"PRIM_LESS_EQUAL_F",<=); - primftest(PRIM_LESS_THAN_F,"PRIM_LESS_THAN_F",<); - primftest(PRIM_GREATER_THAN_F,"PRIM_GREATER_THAN_F",>); - primftest(PRIM_GREATER_EQUAL_F,"PRIM_GREATER_EQUAL_F",>=); - - Instruct(JMP_VECTOR): { - temp = s32pc + (acc-s32_1pc)*4; - debug(printf("s32pc = %d \n",s32pc)); - debug(printf("s32_1pc = %d \n",s32_1pc)); - debug(printf("acc = %d \n",acc)); - debug(printf("JMP_VECTOR(%x) with offset %d\n", cur_instr,temp)); - debug(printf("value in slot %x \n",(*((int32 *)(pc+temp))))); - pc = JUMPTGT((*((int32 *)(pc+temp)))+temp); - debug(printf("instruct in slot pc %x\n",s32pc)); - Next; - } - - Instruct(JMP_REL): { - debug(printf("JMP_REL with offset %d\n", s32pc)); - branch(); - Next; - } - Instruct(C_CALL0): { - Setup_for_c_call; - debug(printf("C_CALL0(%d)\n", u32pc)); - debug_writer1("C_CALL0(0x%x)\n", u32pc); - acc = ((c_primitive) u32pc)(); - inc32pc; /* index in c_prim */ - Restore_after_c_call; - debug(printf("C_CALL0 end\n")); - Next; - } - Instruct(C_CALL1): { - Setup_for_c_call; - //debug(printf("C_CALL1(%d) with acc %d (0x%x)\n", cprim[u32pc], acc, acc)); - debug(printf("C_CALL1(%d) with acc %d (0x%x)\n", u32pc, acc, acc)); - debug_writer2("C_CALL1(0x%x) with acc %d\n", u32pc, acc); - acc = ((c_primitive) u32pc)(acc); - inc32pc; /* index in c_prim */ - Restore_after_c_call; - debug(printf("C_CALL1 end\n")); - Next; - } - Instruct(C_CALL2): { - Setup_for_c_call; - debug(printf("C_CALL2(%d) with acc %d and arg %d\n", u32pc, acc, selectStackDef(-1))); - //debug(printf("C_CALL2(%d) with acc %d and arg %d\n", cprim[u32pc], acc, selectStackDef(-1))); - debug_writer3("C_CALL2(0x%x) with acc %d and arg %d\n", u32pc, acc, selectStackDef(-1)); - acc = ((c_primitive) u32pc)(popValDef, acc); - inc32pc; /* index in c_prim */ - Restore_after_c_call; - debug(printf("C_CALL2 end\n")); - Next; - } - Instruct(C_CALL3): { - Setup_for_c_call; - debug(printf("C_CALL3(%d) with acc %d and arg %d\n", u32pc, acc, selectStackDef(-1))); - debug_writer4("C_CALL3(0x%x) with acc %d and args (%d,%d)\n", u32pc, acc, selectStackDef(-2), selectStackDef(-1)); - temp = popValDef; - acc = ((c_primitive) u32pc)(popValDef, temp, acc); - inc32pc; /* index in c_prim */ - Restore_after_c_call; - debug(printf("C_CALL3 end\n")); - Next; - } - Instruct(C_CALL4): { - Setup_for_c_call; - debug(printf("C_CALL4 - %d - (%d,%d,%d,%d)\n", u32pc, selectStackDef(-3), selectStackDef(-2), selectStackDef(-1), acc)); - debug_writer5("C_CALL4(0x%x) with acc %d and args (%d,%d,%d)\n", u32pc, acc, selectStackDef(-3), selectStackDef(-2),selectStackDef(-1)); - acc = ((c_primitive) u32pc)(selectStackDef(-3), selectStackDef(-2), selectStackDef(-1), acc); - popNDef(3); - inc32pc; /* index in c_prim */ - Restore_after_c_call; - debug(printf("C_CALL4 end\n")); - Next; - } - - Instruct(C_CALL5): { - Setup_for_c_call; - debug(printf("C_CALL5 - %d - (%d,%d,%d,%d,%d)\n", u32pc, selectStackDef(-4), - selectStackDef(-3), selectStackDef(-2), selectStackDef(-1), acc)); - debug_writer6("C_CALL5(0x%x) with acc %d and args (%d,%d,%d,%d)\n", u32pc, acc, selectStackDef(-4), selectStackDef(-3), selectStackDef(-2),selectStackDef(-1)); - acc = ((c_primitive) u32pc)(selectStackDef(-4), selectStackDef(-3), selectStackDef(-2), selectStackDef(-1), acc); - popNDef(4); - inc32pc; /* index in c_prim */ - Restore_after_c_call; - debug(printf("C_CALL5 end\n")); - Next; - } - - Instruct(C_CALL6): { - Setup_for_c_call; - debug(printf("C_CALL6 - %d - (%d,%d,%d,%d,%d,%d)\n", u32pc, selectStackDef(-5), - selectStackDef(-4), selectStackDef(-3), selectStackDef(-2), selectStackDef(-1), acc)); - debug_writer7("C_CALL6(0x%x) with acc %d and args (%d,%d,%d,%d,%d)\n", u32pc, acc, selectStackDef(-5), selectStackDef(-4), selectStackDef(-3), selectStackDef(-2),selectStackDef(-1)); - acc = ((c_primitive) u32pc)(selectStackDef(-5), selectStackDef(-4), selectStackDef(-3), selectStackDef(-2), - selectStackDef(-1), acc); - popNDef(5); - inc32pc; /* index in c_prim */ - Restore_after_c_call; - debug(printf("C_CALL6 end\n")); - Next; - } - - Instruct(C_CALL7): { - Setup_for_c_call; - debug(printf("C_CALL7 - %d - (%d,%d,%d,%d,%d,%d,%d)\n", u32pc, selectStackDef(-6), - selectStackDef(-5), selectStackDef(-4), selectStackDef(-3), selectStackDef(-2), - selectStackDef(-1), acc)); - debug_writer8("C_CALL7(0x%x) with acc %d and args (%d,%d,%d,%d,%d,%d)\n", u32pc, acc, selectStackDef(-6), selectStackDef(-5), selectStackDef(-4), selectStackDef(-3), selectStackDef(-2),selectStackDef(-1)); - acc = ((c_primitive) u32pc)(selectStackDef(-6), selectStackDef(-5), selectStackDef(-4), - selectStackDef(-3), selectStackDef(-2), selectStackDef(-1), acc); - popNDef(6); - inc32pc; /* index in c_prim */ - Restore_after_c_call; - debug(printf("C_CALL7 end\n")); - Next; - } - - Instruct(UB_TAG_CON): { - // If temp = (11xxxxxxxxxxxxx), then we are dealing with a nullary - // constructor and all bits are used. - debug(printf("UB_TAG_CON: %x\n", acc)); - temp = acc; - acc = acc & 0x00000003; - if (acc == 0x00000003) - acc = temp; - Next; - } - - Instruct(SELECT_STACK_M1): { acc = selectStackDef(-1); Next; } - Instruct(SELECT_STACK_M2): { acc = selectStackDef(-2); Next; } - Instruct(SELECT_STACK_M3): { acc = selectStackDef(-3); Next; } - Instruct(SELECT_STACK_M4): { acc = selectStackDef(-4); Next; } - Instruct(SELECT_STACK_N): { - debug(printf("SELECT_STACK_N %d\n", s32pc)); - acc = selectStackDef(s32pc); - inc32pc; - Next; - } - - Instruct(SELECT_0): { acc = *(int *)acc; Next; } - Instruct(SELECT_1): { acc = *((int *)acc + 1); Next; } - Instruct(SELECT_2): { acc = *((int *)acc + 2); Next; } - Instruct(SELECT_3): { acc = *((int *)acc + 3); Next; } - Instruct(SELECT_N): { - debug(printf("SELECT_N %d\n", s32pc)); - acc = *(((int *)acc) + s32pc); - inc32pc; - Next; - } - - Instruct(SELECT_ENV_N): { - debug(printf("SELECT_ENV_N %d - env = 0x%x\n", s32pc, env)); - debug_writer2("SELECT_ENV_N %d - env = 0x%x\n", (int) s32pc, (int) env); - acc = *(env + s32pc); - inc32pc; - Next; - } - Instruct(ENV_TO_ACC): { - debug(printf("ENV_TO_ACC\n")); - acc = (int) env; - Next; - } - - Instruct(STORE_0): { *(int *)popValDef = acc; acc = mlUNIT; Next; } - Instruct(STORE_1): { *((int *)popValDef + 1) = acc; acc = mlUNIT; Next; } - Instruct(STORE_2): { *((int *)popValDef + 2) = acc; acc = mlUNIT; Next; } - Instruct(STORE_3): { *((int *)popValDef + 3) = acc; acc = mlUNIT; Next; } - Instruct(STORE_N): { - debug(printf("STORE_N %d \n", acc)); - temp = (int)(((int *)popValDef) + s32pc); - *((int *)temp) = acc; - debug(printf("Writing to sp = 0x%x\n", temp)); - acc = mlUNIT; - inc32pc; - Next; - } - - Instruct(STACK_ADDR_INF_BIT) : { - acc = (int) (sp + s32pc); - acc = setInfiniteBit(acc); /* bug fix - inserted acc = ... */ - debug(printf("STACK_ADDR_INF_BIT %d at %d (0x%x)\n", s32pc, acc, acc)); - inc32pc; - Next; - } - Instruct(STACK_ADDR): { - acc = (int) (sp + s32pc); - debug(printf("STACK_ADDR %d at %x\n", s32pc, acc)); - inc32pc; - Next; - } - - Instruct(RETURN_1_1): { - pc_temp = (bytecode_t) selectStackDef(-3); - env = (int *) selectStackDef(-2); - popNDef(3); - pc = pc_temp; - Next; - } - Instruct(RETURN_N_1): { - pc_temp = (bytecode_t) selectStackDef(-s32pc-2); - env = (int *) selectStackDef(-s32pc-1); - popNDef(s32pc+2); - pc = pc_temp; - Next; - } - Instruct(RETURN): { - debug(printf("RETURN(old_args %d,res %d)\n",s32pc,s32_1pc)); - pc_temp = (bytecode_t) selectStackDef(-s32_1pc-s32pc-1); - debug(printf("Return-pointer stack-slot = 0x%x\n", sp -s32_1pc-s32pc-1)); - env = (int *) selectStackDef(-s32pc-s32_1pc); - for (temp=0;temp x ) { temp = y; y = x; x = temp; } - if( y > MaxChunk ) - goto raise_overflow; - if( x <= MaxChunk ) { - acc = i32ub_to_i31(isNegative?(-(x * y)):(x * y)); - } else { /* x > MaxChunk */ - temp = (x >> ChunkLen) * y; - if( temp > MaxChunk + 1) - goto raise_overflow; - temp = (temp << ChunkLen) + (x & MaxChunk) * y; - if( isNegative ) temp = - temp; - acc = i32ub_to_i31(temp); - if( i31_to_i32ub(acc) != temp ) - goto raise_overflow; - } - Next; - } - - Instruct(PRIM_NEG_I31): { - debug(printf("PRIM_NEG_I31\n")); - temp = - i31_to_i32ub(acc); - acc = i32ub_to_i31(temp); - if( i31_to_i32ub(acc) != temp ) - goto raise_overflow; - Next; - } - - Instruct(PRIM_ABS_I31): { - debug(printf("PRIM_ABS_I31\n")); - if ( acc < 0 ) { - temp = - i31_to_i32ub(acc); - acc = i32ub_to_i31(temp); - if( i31_to_i32ub(acc) != temp ) - goto raise_overflow; - } - Next; - } - - Instruct(PRIM_XOR_W31): { - debug(printf("PRIM_XOR_W31\n")); - acc = 1 + (acc ^ ((int)(popValDef))); - Next; - } - - Instruct(PRIM_SHIFT_LEFT_W31): { /* shift amount is untagged */ - debug(printf("PRIM_SHIFT_LEFT_W31\n")); - acc = 1 + ( (((int)(popValDef)) - 1) << acc ); - Next; - } - - Instruct(PRIM_SHIFT_RIGHT_SIGNED_W31): { /* shift amount is untagged */ - debug(printf("PRIM_SHIFT_RIGHT_SIGNED_W31\n")); - acc = 1 | ( (((int)(popValDef)) - 1) >> acc ); - Next; - } - - Instruct(PRIM_SHIFT_RIGHT_UNSIGNED_W31): { /* shift amount is untagged */ - debug(printf("PRIM_SHIFT_RIGHT_UNSIGNED_W31\n")); - acc = 1 | ( ((unsigned int)(popValDef) - 1) >> acc ); - Next; - } - - /* Unsigned integer arithmetic modulo 2^(wordsize-1) */ - - Instruct(PRIM_ADD_W31): { - debug(printf("PRIM_ADD_W31\n")); - acc = (int)((unsigned int)(popValDef) + (unsigned int)(acc - 1)); - Next; - } - - Instruct(PRIM_SUB_W31): { - debug(printf("PRIM_SUB_W31\n")); - acc = (int)((unsigned int)(popValDef) - (unsigned int)(acc - 1)); - Next; - } - - Instruct(PRIM_MUL_W31): { - debug(printf("PRIM_MUL_W31\n")); - acc = (int)(1 + (unsigned int)((popValDef) >> 1) * (unsigned int)(acc - 1)); - Next; - } - - Instruct(PRIM_I31_TO_I): { - debug(printf("PRIM_I31_TO_I\n")); - acc = i31_to_i32ub(acc); - Next; - } - - Instruct(PRIM_I_TO_I31): { - debug(printf("PRIM_I_TO_I31\n")); - temp = acc; - acc = i32ub_to_i31(acc); - if ( i31_to_i32ub(acc) != temp ) - goto raise_overflow; - Next; - } - - Instruct(PRIM_W31_TO_W): { - debug(printf("PRIM_W31_TO_W\n")); - acc = i31_to_i32ub(acc); - Next; - } - - Instruct(PRIM_W_TO_W31): { - debug(printf("PRIM_W_TO_W31\n")); - acc = i32ub_to_i31(acc); - Next; - } - - Instruct(PRIM_W31_TO_W_X): { - debug(printf("PRIM_W31_TO_W_X\n")); - acc = i31_to_i32ub(acc); - Next; - } - - Instruct(PRIM_W_TO_I): { - debug(printf("PRIM_W_TO_I\n")); - if ( acc < 0 ) - goto raise_overflow; - Next; - } - - Instruct(PRIM_BYTETABLE_SUB): { - debug(printf("PRIM_BYTETABLE_SUB(%d,%d)\n", selectStackDef(-1), acc)); - acc = (int)(*((unsigned char *)(&(((String)(popValDef))->data) + acc))); - Next; - } - - Instruct(PRIM_BYTETABLE_UPDATE): { - debug(printf("PRIM_BYTETABLE_UPDATE(%d,%d,%d)\n", selectStackDef(-2), selectStackDef(-1), acc)); - *(&(((String)(selectStackDef(-2)))->data) + (selectStackDef(-1))) = (unsigned char)acc; - popNDef(2); - Next; - } - - Instruct(PRIM_WORDTABLE_SUB): { - debug(printf("PRIM_WORDTABLE_SUB(%d,%d)\n", selectStackDef(-1), acc)); - acc = *(&(((Table)(popValDef))->data) + acc); - Next; - } - - Instruct(PRIM_WORDTABLE_UPDATE): { - debug(printf("PRIM_WORDTABLE_UPDATE(%d,%d,%d)\n", selectStackDef(-2), selectStackDef(-1), acc)); - *(&(((Table)(selectStackDef(-2)))->data) + (selectStackDef(-1))) = acc; - popNDef(2); - Next; - } - - Instruct(PRIM_TABLE_SIZE): { - debug(printf("PRIM_TABLE_SIZE\n")); - acc = get_table_size(((String)acc)->size); // get_table_size == get_string_size - Next; - } - - Instruct(PRIM_IS_NULL): { - debug(printf("PRIM_IS_NULL\n")); - if ( acc == 0 ) acc = mlTRUE; - else acc = mlFALSE; - Next; - } - - // Passing state around; used in apache to pass request_rec with the connection - Instruct(GET_CONTEXT): { - debug(printf("GET_CONTEXT\n")); - acc = (int) serverCtx->aux; - Next; - } - - Instruct(CHECK_LINKAGE): { - if (u32pc == 0) - { - acc = popValDef; - inc32pc; /* Index in dynamic_funcs */ - Next; - } - else - { - Setup_for_c_call; - if (u32pc == 1) - { - localResolveLibFnAuto(((const void **) pc)+2, (const char *) (&(((String) acc)->data))); - } - else if (u32pc == 2) - { - localResolveLibFnAuto(((const void **) pc)+2, (const char *) acc); - } - if (u32_2pc == 0) - { - raise_exn((int) &exn_MATCH); - } - u32pc = 0; - acc = popValDef; - inc32pc; /* Index in dynamic_funcs */ - Restore_after_c_call; - Next; - } - } - -#ifdef LAB_THREADED -// lbl_EVENT: - lbl_DOT_LABEL: - lbl_LABEL: -#else - default: { -#endif /*LAB_THREADED*/ - printf("Default: Instruction %d(hex %x) not recognized\n", cur_instr, cur_instr); - printf("Stack pointer sp = %p\n", sp); - printf("Code pointer pc = %p\n", pc); - die("Instruction not recognized"); - return -1; -#ifndef LAB_THREADED - } - } - } -#endif -} - - -/* Interpret code; assumes that code is already resolved; i.e., that - * instruction numbers are turned into instruction addresses. */ -ssize_t -interpCode(Interp* interpreter, // The interpreter - register uintptr_t * sp, // Stack pointer - uintptr_t * ds, // Data segment pointer - uintptr_t * exnPtr, // Pointer to next exn-handler on stack - Ro** topRegionCell, // Cell for holding a pointer to the top-most region - char ** errorStr, // Cell to store error-string in case of an uncaught exception - uintptr_t *exnCnt, // Exception name counter - bytecode_t b_prog, // The actual code - void *serverCtx) // Apache request_rec pointer -{ - debug_writer1("interpCode %d interp\n",0); - int res = interp(interpreter, sp, ds, exnPtr, topRegionCell, errorStr, - exnCnt, b_prog, 0, INTERPRET, serverCtx); - debug_writer1("interpCode %d interp DONE\n",0); - // sizeW not used when mode is INTERPRET - return res; -} - - -/* Resolve code; i.e., turn instruction numbers into instruction - * addresses. */ -void -resolveCode(bytecode_t b_prog, // Code to resolve - size_t sizeW) { // Size of code in words - interp(NULL, NULL, NULL, NULL, NULL, NULL, 0, b_prog, sizeW, RESOLVEINSTS, NULL); -} - -void print_code(bytecode_t b_prog, int code_size) { - int j; - for (j=0;j -#include -#include -#include -#include -#include - -#include "LoadKAM.h" -#include "Runtime.h" -#include "Region.h" -#include "KamInsts.h" -#include "Stack.h" -#include "HeapCache.h" -#include "Exception.h" -#include "Interp.h" -#include "../CUtils/polyhashmap.h" - -#if ( THREADS && CODE_CACHE ) -#include -#include "Locks.h" -#include "LogLevel.h" -#endif - -#ifdef DEBUG -#define debug(Arg) Arg -#else -#define debug(Arg) {} -#endif - -/* ----------------------------------------------------- - * String to Code Map - * ----------------------------------------------------- */ - -static int -streq(const char* s1,const char* s2) -{ - if ( strcmp(s1,s2) == 0 ) - return 1; - return 0; -} - -#if ( THREADS && CODE_CACHE ) -// extern void logMsg1(char* msg, void *serverState); - -DEFINE_NHASHMAP(strToCodeMap, charhashfunction, streq) - -void -strToCodeMapInsert(strToCodeMap m, const char* name, bytecode_t code) -{ - char* name_copy; - name_copy = (char*)malloc(strlen(name)+1); - if ( name_copy == 0 ) - { - die("strToCodeMapInsert: cannot allocate memory for name"); - } - strcpy(name_copy,name); - strToCodeMap_update(m,name_copy,code); - return; -} - -// lookup bytecode in a strToCodeMap; returns 0 on failure - -bytecode_t -strToCodeMapLookup(strToCodeMap m, const char* k) -{ - bytecode_t b; - if ( strToCodeMap_find(m,k,&b) == hash_OK ) - return b; - else - return 0; -} - -void -strToCodeMapClear_fn(const char* k,bytecode_t code) -{ - free((void *) k); - free(code); -} - -strToCodeMap -strToCodeMapClear(strToCodeMap m) -{ - strToCodeMap_Apply(m,strToCodeMapClear_fn); - strToCodeMap_reinit(m); - return strToCodeMap_new(); -} - -#endif - -/* ----------------------------------------------------- - * Label Map - * ----------------------------------------------------- */ - -unsigned long -label_hash(label lab) -{ - unsigned long acc; - acc = charhashfunction(&(lab->base)); - return acc + lab->id; -} - -int -label_eq(label lab1,label lab2) -{ - if ( lab1->id == lab2->id && streq(&(lab1->base),&(lab2->base))) - return 1; - else return 0; -} - -DEFINE_NHASHMAP(labelMap,label_hash,label_eq) - -void -labelMapInsert(labelMap m, - label k, - const uintptr_t v) -{ - labelMap_update(m,k,v); -} - -labelMap -labelMapNew(void) -{ - return labelMap_new(); -} - -void -printLabelId(label lab,uintptr_t id) -{ - printf(" Lab(%ld,%s) -> %zd\n",lab->id,&(lab->base),id); -} - -void -labelMapPrint(labelMap m) -{ - printf("LabelMap = {\n"); - labelMap_Apply(m,printLabelId); - printf("}\n"); -} - -// lookup a label in a labelMapHashTable; returns 0 on failure - -uintptr_t -labelMapLookup(labelMap m, label lab) -{ - uintptr_t res; - if ( labelMap_find(m,lab,&res) == hash_OK ) - return res; - else return 0; -} - -void -free_label(label lab,uintptr_t res) -{ - free(lab); -} - -labelMap -labelMapClear(labelMap m) -{ - labelMap_Apply(m,free_label); - labelMap_reinit(m); - return m; -} - -/* Global regions 0-6, global exception - * constructors 7-11 are allocated in data segment - * and a garbage field located in 12 */ -#define INTERP_INITIAL_DATASIZE 13 - -/* Create a new interpreter: - * - We could perhaps allocate the interpreter stack when - * we first create an interpreter - this way, each interpreter - * thread could reuse its own stack! Now we malloc a new stack - * whenever a script is run. - */ -Interp* -interpNew(void) -{ - Interp* interp; - - if ( (interp = (Interp*)malloc (sizeof(Interp))) <= 0 ) { - die("Unable to allocate memory for interpreter"); - } - - interp->codeMap = labelMapNew(); - interp->dataMap = labelMapNew(); - interp->codeList = NULL; - interp->exeList = NULL; - interp->data_size = INTERP_INITIAL_DATASIZE; -#if ( THREADS && CODE_CACHE ) - interp->codeCache = strToCodeMap_new(); -#endif - /* debug(printf("interpNew4\n")); */ - return interp; -} - -LongList* -listCons(unsigned long elem, LongList* longList) -{ - LongList* longList2; - - if ( (longList2 = (LongList*) malloc (sizeof(LongList))) <= 0 ) { - die("Unable to allocate memory for list"); - } - longList2->next = longList; - longList2->elem = elem; - return longList2; -} - -void -longListFreeElem(LongList* longList) -{ - LongList* l; - while ( longList ) - { - l = longList->next; - free((void*)(longList->elem)); - free(longList); - longList = l; - } -} - -void -longListFree(LongList* longList) -{ - LongList* l; - while ( longList ) - { - l = longList->next; - free(longList); - longList = l; - } -} - -// read_long: read a long from a buffer -#define READ_ERROR -1 -#define READ_OK 0 - -static int -read_unsigned_long(FILE* fd, unsigned long* v_ptr) -{ - unsigned char buffer[sizeof(unsigned long)]; - int i,c; - - for ( i = 0 ; i < sizeof(unsigned long) ; i++ ) - { - if ( (c = fgetc(fd)) == EOF ) - return READ_ERROR; - buffer[i] = (unsigned char)c; - } - *v_ptr = *(unsigned long*)buffer; - return READ_OK; -} - -static int -read_string_buf(FILE* fd,unsigned long n,char* buf) -{ - unsigned long i; - int c; - for ( i = 0 ; i < n ; i++ ) - { - if ( (c = fgetc(fd)) == EOF) - return READ_ERROR; - buf[i] = (char)c; - } - buf[i] = 0; - return READ_OK; -} - -static int -skip_string_buf(FILE* fd,unsigned long n) -{ - unsigned long i; - int c; - for ( i = 0 ; i < n ; i++ ) - { - if ( (c = fgetc(fd)) == EOF) - return READ_ERROR; - } - return READ_OK; -} - -// A label is layed out in the file as |id;sz_str;chars| - no trailing zero -static int -read_label(FILE* fd, label* lab_ptr) -{ - label lab; - unsigned long id, str_sz; - if ( read_unsigned_long(fd, &id) == READ_ERROR ) - return READ_ERROR; - if ( read_unsigned_long(fd, &str_sz) == READ_ERROR ) - return READ_ERROR; - lab = (label)malloc(str_sz + 1 + sizeof(long)); - if ( lab == 0 ) - die ("read_label: failed to allocate memory for label"); - lab->id = id; - if ( read_string_buf(fd,str_sz,&(lab->base)) == READ_ERROR ) - { - free(lab); - return READ_ERROR; - } - debug(printf("read_label: id = %d; str_sz = %d; base = %s\n", id, str_sz, &(lab->base))); - *lab_ptr = lab; - return READ_OK; -} - -// A label is layed out in the file as |id;sz_str;chars| - no trailing zero -static int -skip_label(FILE* fd) -{ - unsigned long str_sz; - if ( read_unsigned_long(fd, &str_sz) == READ_ERROR ) - return READ_ERROR; - if ( read_unsigned_long(fd, &str_sz) == READ_ERROR ) - return READ_ERROR; - if ( skip_string_buf(fd,str_sz) == READ_ERROR ) - { - return READ_ERROR; - } - debug(printf("skip_label: str_sz = %d\n", str_sz)); - return READ_OK; -} -/* -// For debugging -static void -print_exec_header(struct exec_header* exec_header) -{ - printf("Header:\n\ - code_size: %ld\n\ - main_lab: Lab(%ld,%s)\n\ - import_size_code: %ld\n\ - import_size_data: %ld\n\ - export_size_code: %ld\n\ - export_size_data: %ld\n\ - magic: %lx\n", - exec_header->code_size, - exec_header->main_lab_opt->id, - &(exec_header->main_lab_opt->base), - exec_header->import_size_code, - exec_header->import_size_data, - exec_header->export_size_code, - exec_header->export_size_data, - exec_header->magic); -} -*/ -// read_exec_header: Leaves fd at the beginning of the code -// segment on success -static int -read_exec_header(FILE* fd, struct exec_header * exec_header) -{ - if ( read_unsigned_long(fd, &(exec_header->code_size)) == READ_ERROR - || read_label(fd, &(exec_header->main_lab_opt)) == READ_ERROR - || read_unsigned_long(fd, &(exec_header->import_size_code)) == READ_ERROR - || read_unsigned_long(fd, &(exec_header->import_size_data)) == READ_ERROR - || read_unsigned_long(fd, &(exec_header->export_size_code)) == READ_ERROR - || read_unsigned_long(fd, &(exec_header->export_size_data)) == READ_ERROR - || read_unsigned_long(fd, &(exec_header->magic)) == READ_ERROR ) - return TRUNCATED_FILE; - if ( exec_header->magic == EXEC_MAGIC ) - return 0; - else - return BAD_MAGIC_NUM; -} - - -/* attempt_open: Leaves fd at the beginning of the code segment on success - * remember to close the returned file descriptor when the file has been - * read. - */ - -static int -attempt_open(const char* restrict name, struct exec_header* restrict exec_header, serverstate ss, FILE **result) -{ - FILE *fd; - int res; - - debug(printf("opening file %s\n", name)); - fd = fopen(name, "r"); - if ( fd == NULL ) { - die2("attempt_open: fopen returns NULL when trying to open file ", name); - exit(-1); - } - if ( (res = read_exec_header(fd, exec_header)) < 0 ) { - switch (res) { - case FILE_NOT_FOUND: - die2("attempt_open: cannot find the file ", name); - break; - case TRUNCATED_FILE: - die2("attempt_open: truncated file: ", name); - break; - case BAD_MAGIC_NUM: - die2("attempt_open: bad magic number in the bytecode file ", name); - break; - } - exit(-1); - } - *result = fd; - return 0; -} - -static int -loadCode(FILE *fd, unsigned long n, bytecode_t ch) -{ - int c; - while (n > 0) { - if ( (c = fgetc(fd)) == EOF ) { - return -1; - } - *ch++ = (unsigned char)c; - n--; - } - return 0; -} - -/* for each entry (relAddr,label) in the file do - * *(start_code + relAddr) = labelMap[label] - */ - -#define PAIR_SIZE (2*sizeof(long)) - -static int -resolveCodeImports(labelMap labelMap, - FILE* fd, - unsigned long import_size, // size is in entries - bytecode_t start_code) -{ - unsigned long relAddr; - label label; - bytecode_t absTargetAddr; - bytecode_t absSourceAddr; - - while ( import_size > 0 ) { - if ( read_unsigned_long(fd, &relAddr) == READ_ERROR - || read_label(fd, &label) == READ_ERROR ) - return TRUNCATED_FILE; - - debug(printf("Importing relAddr = %d (0x%x), label = %d (0x%x) \n", - relAddr, relAddr, label, label)); - - if ( (absTargetAddr = (bytecode_t)labelMapLookup(labelMap, label)) == 0 ) - { - free(label); - return -4; - } - free(label); - absSourceAddr = start_code + relAddr; - * (unsigned long*)absSourceAddr = - (unsigned long)(absTargetAddr - absSourceAddr); - import_size --; - } - return 0; -} - -static int -resolveDataImports(labelMap labelMap, - FILE* fd, - unsigned long import_size, // size is in entries - bytecode_t start_code) -{ - unsigned long relAddr, dsAddr; - label lab; - - while ( import_size > 0 ) { - if ( read_unsigned_long(fd, &relAddr) == READ_ERROR - || read_label(fd, &lab) == READ_ERROR ) - return TRUNCATED_FILE; - - debug(printf("Importing relAddr = %d (0x%x), label = %d (0x%x) \n", - relAddr, relAddr, lab, lab)); - debug_writer4("Importing relAddr = %d (0x%x), label = %d (0x%x) \n", - relAddr, relAddr, lab, lab); - - if ( (dsAddr = labelMapLookup(labelMap, lab)) == 0 ) { - free(lab); - return -4; - } - free(lab); - * (unsigned long*)(start_code + relAddr) = dsAddr; - import_size --; - } - return 0; -} - -/* for each entry (label, relAddr) in the file extend the - * labelMap with the entry (label, start_code + relAddr) - */ -static int -addCodeExports(labelMap m, - FILE* fd, - unsigned long export_size, // size is in entries - bytecode_t start_code) -{ - label lab; - unsigned long relAddr; - bytecode_t absAddr; - - while ( export_size > 0 ) { - if ( read_label(fd, &lab) == READ_ERROR ) - return TRUNCATED_FILE; - if ( read_unsigned_long(fd, &relAddr) == READ_ERROR ) - { - free(lab); - return TRUNCATED_FILE; - } - absAddr = start_code + relAddr; - - debug(printf ("Reading export entry, label = %d (0x%x), relAddr = %d (0x%x), absAddr = %d (0x%x)\n", - lab, lab, relAddr, relAddr, absAddr, absAddr)); - - labelMapInsert(m, lab, (unsigned long)absAddr); - export_size --; - } - return 0; -} - -static int -skipCodeExports(labelMap m, - FILE* fd, - unsigned long export_size) // size is in entries -{ - unsigned long relAddr; - - while ( export_size > 0 ) - { - if ( skip_label(fd) == READ_ERROR ) - return TRUNCATED_FILE; - if ( read_unsigned_long(fd, &relAddr) == READ_ERROR ) - { - return TRUNCATED_FILE; - } - export_size --; - } - return 0; -} - -/* Read entries (lab, relAddr), where lab is a compile time label for - * a slot in the data segment and relAddr is the place in the bytecode - * where lab appears in a `StoreData lab' instruction. For each pair, - * a new slot is allocated in the data segment (data_size is - * incremented), then the `StoreData lab' instruction is modified, and - * finally, the label is associated with the new offset in the hash - * table that maps labels to offsets. */ - -static int -addDataExports(Interp* interp, - FILE* fd, - unsigned long export_size, // size is in entries - bytecode_t start_code) -{ - label lab; - unsigned long relAddr, newDsAddr; - - while ( export_size > 0 ) { - if ( read_label(fd, &lab) == READ_ERROR ) - return TRUNCATED_FILE; - // relAddr is the relative address of `StoreData lab' address in bytecode - if ( read_unsigned_long(fd, &relAddr) == READ_ERROR ) - { - free(lab); - return TRUNCATED_FILE; - } - // newDsAddr is the new data segment address (relative to ds-register) - newDsAddr = interp->data_size++; - - debug(printf("Export label = %d (0x%x), relAddr = %d (0x%x), newDsAddr = %d\n", - lab, lab, relAddr, relAddr, newDsAddr)); - debug_writer5("Export label = %d (0x%x), relAddr = %d (0x%x), newDsAddr = %d\n", - lab, lab, relAddr, relAddr, newDsAddr); - - * (unsigned long*)(start_code + relAddr) = newDsAddr; - labelMapInsert(interp->dataMap, lab, newDsAddr); - export_size --; - } - return 0; -} - -/* alias data export labels with the garbage pointer */ -static int -garbageDataExports(Interp* interp, - FILE* fd, - unsigned long export_size, // size is in entries - bytecode_t start_code) -{ - unsigned long relAddr; - - while ( export_size > 0 ) - { - if ( skip_label(fd) == READ_ERROR ) - return TRUNCATED_FILE; - // relAddr is the relative address of `StoreData lab' address in bytecode - if ( read_unsigned_long(fd, &relAddr) == READ_ERROR ) - { - return TRUNCATED_FILE; - } - - debug(printf("Garbage export label relAddr = %d (0x%x), newDsAddr = %d\n", - relAddr, relAddr, INTERP_INITIAL_DATASIZE - 1)); - debug_writer3("Garbage export label relAddr = %d (0x%x), newDsAddr = %d\n", - relAddr, relAddr, INTERP_INITIAL_DATASIZE -1); - - * (unsigned long*)(start_code + relAddr) = INTERP_INITIAL_DATASIZE - 1; - export_size --; - } - return 0; -} - - -static bytecode_t -interpLoad(Interp* interp, const char* file, FILE* fd, - struct exec_header* exec_header_ptr, serverstate ss) -{ - bytecode_t start_code; - - debug(print_exec_header(exec_header_ptr)); - - // allocate space for loaded code - if ( (start_code = (bytecode_t) malloc(exec_header_ptr->code_size)) == 0 ) - { - die2("interpLoad: Cannot allocate start_code for ", file); - } - - debug(printf("[Load code segment]\n")); - if ( loadCode(fd, exec_header_ptr->code_size, start_code) < 0 ) { - die2("interpLoad: Cannot load code for ", file); - } - - debug(printf("[Resolving code imports]\n")); - /* Now, resolve the labels in the import table - - * first the code labels then the data labels */ - if ( resolveCodeImports(interp->codeMap, fd, - exec_header_ptr->import_size_code, - start_code) < 0 ) - { - die2("interpLoad: Cannot resolve code imports for ", file); - } - - debug(printf("[Resolving data imports]\n")); - if ( resolveDataImports(interp->dataMap, fd, - exec_header_ptr->import_size_data, - start_code) < 0 ) - { - die2("interpLoad: Cannot resolve data imports for ", file); - } - -#ifdef LAB_THREADED - debug(printf("[Resolving instructions]\n")); - if ( (exec_header_ptr->code_size % 4) != 0 ) { - die2("interpLoad: Code size not a multiple of 4 for ", file); - } - resolveCode(start_code, exec_header_ptr->code_size / 4); -#endif - - return start_code; -} - -/* ------------------------------------------------------------ - * interpLoadExtend - load bytecode file and extend interpreter - * with information about the identifiers that this bytecode file - * declares. - * ------------------------------------------------------------ */ -int -interpLoadExtend(Interp* interp, const char* file, serverstate ss) -{ - FILE *fd; - struct exec_header exec_header; - bytecode_t start_code; - - attempt_open(file, &exec_header, ss, &fd); - - start_code = interpLoad(interp, file, fd, &exec_header, ss); - - debug(printf("[Extend hash table with code exports]\n")); - if ( addCodeExports(interp->codeMap, fd, - exec_header.export_size_code, - start_code) < 0 ) - { - die2("interpLoadExtend: Cannot extract code exports for ", file); - } - - debug(printf("[Extend hash table with data exports]\n")); - if ( addDataExports(interp, fd, exec_header.export_size_data, - start_code) < 0 ) - { - die2("interpLoadExtend: Cannot extract data exports for ", file); - } - - fclose(fd); - - // extend the code list with the new code segment - interp->codeList = listCons((unsigned long)start_code, interp->codeList); - - if ( exec_header.main_lab_opt->id == 0 - && strcmp(&(exec_header.main_lab_opt->base),"") == 0 ) - return 0; - else - { - unsigned long absAddr; /* We need to look up this - * label in the code export map */ - if ( (absAddr = labelMapLookup(interp->codeMap, - exec_header.main_lab_opt)) == 0 ) - { - die2("interpLoadExtend: Failed to lookup absolute main-label address for ", - file); - } - interp->exeList = listCons(absAddr, interp->exeList); - } - return 0; -} - - -/* allocate global region and store - * address in data segment at address n */ - -#define GLOBAL_REGION(n) { \ - debug(printf("Allocating global region %d at sp=%x\n",(n),sp)); \ - *(ds + (n)) = (uintptr_t) allocateRegion((Ro*) sp, &topRegion); \ - offsetSP(sizeRo); \ -} - -#define GLOBAL_EXCON(X, NAME) { \ - debug(printf("Allocating global excon (%d) at sp=%x\n", (X), sp)); \ - selectStackDef(0) = (unsigned long)(sp + 1); \ - selectStackDef(1) = exnCnt++; \ - selectStackDef(2) = (unsigned long)convertStringToML((Region)*(ds + 2), (NAME)); \ - *(ds + (X)) = (unsigned long)sp; \ - offsetSP(3); \ -} - -/* - * interpRun - Run the interpreter passed as argument; the second - * argument extra_code is put on the stack for execution in case it is - * not NULL (used by the interpLoadRun function). - * - * Returns: whatever the interpreter returns - */ - -#define INIT_CODE_SIZE 3 -static unsigned long init_code[INIT_CODE_SIZE] = { - RETURN,0,1 -}; - - -// We don't actually deallocate the global regions, because in -// SMLserver, the global regions are restored to an initial state so -// that the result of executing library code can be reused for future -// requests. When used for non-SMLserver purposes, the memory for the -// entire process is collected by the OS, thus it is ok not to -// deallocate the global regions in this case. - -#define EXIT_CODE_SIZE 2 -static unsigned long exit_code[EXIT_CODE_SIZE] = { - // ENDREGION_INF, // deallocate the four global regions - // ENDREGION_INF, - // ENDREGION_INF, - // ENDREGION_INF, - IMMED_INT0, // success - HALT // make the interpreter return the - // content of the accumulator -}; - -static unsigned long global_exnhandler_closure[1] = { - 0 // place holder for code pointer -}; - -#define GLOBAL_EXNHANDLER_CODE_SIZE 2 -static unsigned long global_exnhandler_code[GLOBAL_EXNHANDLER_CODE_SIZE] = { - GLOBAL_EXN_HANDLER_REPORT, // sets acc to error (-1 or -2) - // POP_N, 3, - // ENDREGION_INF, // deallocate the four global regions - // ENDREGION_INF, - // ENDREGION_INF, - // ENDREGION_INF, - HALT // make the interpreter return the - // content of the accumulator -}; - -/* resolveGlobalCodeFragments is called from main_interp and - * SMLserver's Ns_ModuleInit function; should be called exactly once - * before execution of any bytecode. */ -void -resolveGlobalCodeFragments(void) -{ - resolveCode((bytecode_t)init_code, INIT_CODE_SIZE); - resolveCode((bytecode_t)exit_code, EXIT_CODE_SIZE); - resolveCode((bytecode_t)global_exnhandler_code, - GLOBAL_EXNHANDLER_CODE_SIZE); - // create closure (no env) - * global_exnhandler_closure = (unsigned long)global_exnhandler_code; -} - -ssize_t -interpRun(Interp* interpreter, bytecode_t extra_code, char**errorStr, serverstate ss) -{ - uintptr_t *ds, *sp, *exnPtr, *sp0; - size_t exnCnt = 0; - Heap* h; - ssize_t res = 0; - LongList* p; - Ro* topRegion = NULL; - -// debug_writer1("interpRun getHeap %d\n", 0); - h = getHeap(ss); - if ( h->status == HSTAT_UNINITIALIZED ) - { - debug_writer1("interpRun %d init heap\n", 0); - ds = h->ds; - sp = ds; - - // make room for data space on the stack - debug(printf("DATASPACE ds = 0x%x\n", ds)); - sp += interpreter->data_size; - debug(printf("STACK sp = 0x%x, datasize = %d\n", sp, interpreter->data_size)); -// debug_writer3("interpRun data_size = 0x%x - sp = 0x%x - ds = 0x%x\n", interpreter->data_size, (int) sp, (int) ds); - - // Now, allocate global regions and store addresses in data segment - // the indexes should be the same as those defined in Manager/Name.sml - GLOBAL_REGION(0); // rtype top, uses ds, modifies sp - // GLOBAL_REGION(1); // rtype bot - GLOBAL_REGION(2); // rtype pair - GLOBAL_REGION(3); // rtype string - GLOBAL_REGION(4); // rtype array - GLOBAL_REGION(5); // rtype ref - GLOBAL_REGION(6); // rtype triple - - // Initialize primitive exceptions - GLOBAL_EXCON(7,"Div"); // uses ds, modifies sp - GLOBAL_EXCON(8,"Match"); - GLOBAL_EXCON(9,"Bind"); - GLOBAL_EXCON(10,"Overflow"); - GLOBAL_EXCON(11,"Interrupt"); - // 12 is used for garbage - - exn_DIV = (Exception*)**(size_t **)(ds+7); - exn_MATCH = (Exception*)**(size_t **)(ds+8); - exn_BIND = (Exception*)**(size_t **)(ds+9); - exn_OVERFLOW = (Exception*)**(size_t **)(ds+10); - exn_INTERRUPT = (Exception*)**(size_t **)(ds+11); - - // Push global exception handler on the stack - pushDef((size_t)exit_code); // push return address on stack - pushDef((size_t) 0); // Dummy env for exit_code - pushDef((size_t)global_exnhandler_closure); // push closure on stack (no env) - pushDef(0); // no previous handler on stack - - exnPtr = sp - 1; // update exnPtr - - /* push address for exit-bytecode on the stack */ - debug(printf("Pushing exit-address %x on stack at sp = %x\n", - (size_t)exit_code, sp)); - pushDef((size_t)exit_code); - pushDef((size_t)0); - - sp0 = sp; - - // push all execution addresses on the stack - for (p = interpreter->exeList; p ; p = p->next) { - debug(printf("Pushing address %x on stack at sp = %x\n", - (size_t)p->elem, sp)); - pushDef((size_t)p->elem); - pushDef((size_t)0); - } - - // start interpretation by interpreting the init_code -// debug_writer1("interpRun %d interpCode init_code\n", 0); - // int tmp; - // debug_file_as(tmp, debug_file); - // debug_file_as(debug_file,-1); - res = interpCode(interpreter,sp,ds,exnPtr,&topRegion,errorStr, - &exnCnt,(bytecode_t)init_code, ss); - - // debug_file_as(debug_file,tmp); -// debug_writer4("initializeHeap sp = 0x%x - sp0 = 0x%x - ds = 0x%x - topRegion = 0x%x\n", (int) sp, (int) sp0, (int) ds, (int) topRegion); - - if ( res >= 0 && extra_code ) - { -// debug_writer1("interpRun %d initializeHeap\n", 0); - initializeHeap(h,sp0,exnPtr, exnCnt, ss); - } - else - { -#ifdef THREADS - (*ss->report) (NOTICE, "Exception raised during execution of library code", ss->aux); -#endif - deleteHeap(h); - return res; - } - } - - // no exception raised by code so far; perhaps jump to the extra bytecode - if ( extra_code ) { - - // fetch heap data - sp = (uintptr_t *)(h->sp); - ds = (uintptr_t *)(h->ds); - exnPtr = (uintptr_t *)(h->exnPtr); - exnCnt = h->exnCnt; - topRegion = h->r6copy->r; - - touchHeap(h,ss); - - debug_writer1("interpRun %d interpCode extra_code\n", 0); - res = interpCode(interpreter,sp,ds,exnPtr,&topRegion,errorStr, - &exnCnt,(bytecode_t)extra_code, ss); - - debug_writer1("interpRun %d releaseHeap\n", 0); - releaseHeap(h,ss); - } - - return res; // return whatever the interpreter returns -} - -/* ------------------------------------------------------ - * interpLoadRun - load a bytecode file, run it, and release the - * loaded code. - * Returns 0 on success and 1 on error - * ------------------------------------------------------ */ - -ssize_t -interpLoadRun(Interp* interp, const char* file, char** errorStr, serverstate ss, ssize_t *res) -{ - bytecode_t start_code; - FILE *fd; - debug_writer1("interpLoadRun %d starting\n", 0); - -#if ( THREADS && CODE_CACHE ) - debug_writer1("interpLoadRun %d lock\n", 0); - LOCK_LOCK(CODECACHEMUTEX); - debug_writer1("interpLoadRun %d find code\n", 0); - start_code = strToCodeMapLookup(interp->codeCache,file); - if ( start_code == NULL ) - { -#endif - struct exec_header exec_header; - debug_writer1("interpLoadRun %d open file\n", 0); - attempt_open(file, &exec_header, ss, &fd); - debug_writer1("interpLoadRun %d load\n", 0); - start_code = interpLoad(interp, file, fd, &exec_header, ss); - debug(printf("[skip code exports]\n")); - if ( skipCodeExports(interp->codeMap, fd, - exec_header.export_size_code) < 0 ) - { - die2("interpLoadRun: Cannot extract code exports for ", file); - } - - debug(printf("[alias data exports labels with garbage field]\n")); - if ( garbageDataExports(interp, fd, exec_header.export_size_data, - start_code) < 0 ) - { - die2("interpLoadRun: Cannot extract data exports for ", file); - } - debug_writer1("interpLoadRun %d close file\n", 0); - fclose(fd); // as we only read files we don't care about the return value -#if ( THREADS && CODE_CACHE ) - debug_writer1("interpLoadRun %d insert code\n", 0); - strToCodeMapInsert(interp->codeCache,file,start_code); - (*ss->report) (INFO, file,ss->aux); - } - debug_writer1("interpLoadRun %d unlock\n", 0); - LOCK_UNLOCK(CODECACHEMUTEX); -#endif - - /* - * Run the code by passing to the interpRun function the newly - * loaded bytecode as an extra parameter. - */ - - debug_writer1("interpLoadRun %d run\n", 0); - *res = interpRun(interp, start_code, errorStr, ss); - -#if !( THREADS && CODE_CACHE ) - debug_writer1("interpLoadRun %d free\n", 0); - free(start_code); -#endif - - debug_writer1("interpLoadRun %d done\n", 0); - return 0; // return whatever the bytecode interpreter returns -} - -void -interpClear(Interp* interp) -{ - interp->codeMap = labelMapClear(interp->codeMap); - interp->dataMap = labelMapClear(interp->dataMap); -#if ( THREADS && CODE_CACHE ) - interp->codeCache = strToCodeMapClear(interp->codeCache); -#endif - longListFreeElem(interp->codeList); - interp->codeList = NULL; - longListFree(interp->exeList); // here we free only the list - not the - interp->exeList = NULL; // elements, which have already been freed - interp->data_size = INTERP_INITIAL_DATASIZE; -} - diff --git a/src/Runtime/LoadKAM.h b/src/Runtime/LoadKAM.h deleted file mode 100644 index a2ecad999..000000000 --- a/src/Runtime/LoadKAM.h +++ /dev/null @@ -1,174 +0,0 @@ -#ifndef LOADKAM_H -#define LOADKAM_H - -#include -#include -#include "../CUtils/polyhashmap.h" -#include "../CUtils/hashfun.h" -#include "LogLevel.h" - -/* LoadKAM.h : format of bytecode files */ -/* This module loads a KAM module into the code segment, being */ -/* a flat memory area containing KAM instructions. */ - -/* Bytecode file: */ -/* beginning of file ---> header - offset 0 ---> code block - import environment mapping relative addresses - to those labels that need be resolved - export environment mapping labels - to relative addresses - end of file ---> -*/ - -// Comment out the following line to disable caching of leaf-bytecode (for SMLserver) -#define CODE_CACHE 1 - -#define FILE_NOT_FOUND (-1) -#define TRUNCATED_FILE (-2) -#define BAD_MAGIC_NUM (-3) - -// Labels -typedef struct { - unsigned long id; - char base; -} Label; -typedef Label* label; - -// ServerState -typedef struct { - void *aux; - void (*report) (enum reportLevel level, const char *data, void *aux); -} Serverstate; -typedef Serverstate* serverstate; - -/* Compared to Moscow ML, we put the various information in front of the file. */ - -struct exec_header { - unsigned long code_size; /* Size of the code block (in bytes) */ - label main_lab_opt; /* Optional main label; (0,"") is NONE */ - unsigned long import_size_code; /* Number of code import entries */ - unsigned long import_size_data; /* Number of data import entries */ - unsigned long export_size_code; /* Number of code export entries */ - unsigned long export_size_data; /* Number of code export entries */ - unsigned long magic; /* A magic number */ -}; - -#define HEADER_SIZE sizeof(struct exec_header) - -/* Magic number for this release: "K001" */ -#define EXEC_MAGIC 0x4b303031 - -/* The type of loaded KAM code - each instruction takes - * up one word (i.e., a long) but we use a pointer to a - * char to locate the code... - */ -typedef unsigned char * bytecode_t; - - -/* ---------------------------------------------------------- - * Support for HashTables mapping strings to loaded bytecode - * - * The following type definition is for holding elements of - * the mapping from strings (file names) to loaded byte code. - * See hashmap_typed.h - * ---------------------------------------------------------- */ - -#ifdef CODE_CACHE -DECLARE_NHASHMAP(strToCodeMap, bytecode_t, char *, , const) -typedef strToCodeMap_hashtable_t * strToCodeMap; -void strToCodeMapInsert(strToCodeMap m, const char* s, bytecode_t code); -bytecode_t strToCodeMapLookup(strToCodeMap m, const char* s); -strToCodeMap strToCodeMapClear(strToCodeMap m); -#endif - - -/* -------------------------------------------------- - * Support for HashTables mapping labels to absolute addresses - * - * The following type definition is for holding elements - * of the mapping from labels to resolved absolute addresses. - * See polyhashmap.h - * -------------------------------------------------- */ - -DECLARE_NHASHMAP(labelMap,uintptr_t,label,,) - -typedef labelMap_hashtable_t * labelMap; - -void labelMapInsert(labelMap labelMap, label label, uintptr_t address); -labelMap labelMapNew(void); -uintptr_t labelMapLookup(labelMap labelMap, label label); -void labelMapFree(labelMap labelMap); - -typedef struct longList { - unsigned long elem; /* the element */ - struct longList * next; /* the remainder of the list; terminated - * with a NULL pointer */ -} LongList; -void longListFree(LongList* longList); - -typedef struct { - labelMap codeMap; /* Mapping code labels to absolute addresses */ - labelMap dataMap; /* Mapping data labels to relative addresses - * with respect to a data segment */ - LongList* codeList; /* Addresses of all malloc'ed - * code elements; used for freeing memory - * occupied by interpreter. */ - LongList* exeList; /* Labels for those program units that need be - * initialized by running some code. */ -#ifdef CODE_CACHE - strToCodeMap codeCache; /* Caching support for loaded leafs. */ -#endif - unsigned long data_size; /* Accumulated size (in entries) of data segment */ -} Interp; - -/*----------------------------------------------------------------* - * Prototypes for external and internal functions. * - *----------------------------------------------------------------*/ - - -/* Create a new interpreter */ -Interp *interpNew(void); - -/* Extend an interpreter by loading a bytecode file */ -int interpLoadExtend(Interp* interp, const char* file,serverstate ss); - -/* Load a bytecode file and run it, then release the loaded code; - * later we can provide a version of this function that caches the - * loaded code. */ -ssize_t interpLoadRun(Interp* interp, const char* file, char** errorStr, serverstate ss, ssize_t *result); - -/* Run an interpreter */ -ssize_t interpRun(Interp* interp, bytecode_t extra_code, char** errorStr, serverstate ss); - -/* Free all loaded code */ -void interpClear(Interp* interp); - -/* Initialize global code fragments */ -void resolveGlobalCodeFragments(void); - -#if 0 // APACHE -extern int debug_file; -extern void debug_writer1(char *, int); -extern void debug_writer2(char *, int,int); -extern void debug_writer3(char *, int,int,int); -extern void debug_writer4(char *, int,int,int,int); -extern void debug_writer5(char *, int,int,int,int,int); -extern void debug_writer6(char *, int,int,int,int,int,int); -extern void debug_writer7(char *, int,int,int,int,int,int,int); -extern void debug_writer8(char *, int,int,int,int,int,int,int,int); -#define debug_file_as(LV,EXP) LV = EXP -#else -#define debug_writer1(Q,A) {} -#define debug_writer2(Q,A,B) {} -#define debug_writer3(Q,A,B,C) {} -#define debug_writer4(Q,A,B,C,D) {} -#define debug_writer5(Q,A,B,C,D,E) {} -#define debug_writer6(Q,A,B,C,D,E,F) {} -#define debug_writer7(Q,A,B,C,D,E,F,G) {} -#define debug_writer8(Q,A,B,C,D,E,F,G,H) {} -#define debug_file_as(LV,EXP) {} -#endif - - -#endif /* LOADKAM_H */ diff --git a/src/Runtime/Locks.h b/src/Runtime/Locks.h index 00c913fb9..02ba30853 100644 --- a/src/Runtime/Locks.h +++ b/src/Runtime/Locks.h @@ -19,22 +19,7 @@ void mutex_unlock(int id); // defined in Spawn.c #include "../config.h" #ifdef THREADS -#ifdef APACHE - -#define str(s) # s -#define xstr(s) str(s) - -#include "../SMLserver/apache/Locks.h" - -#define LOCK_LOCK(name) runtime_lock(name) -#define LOCK_UNLOCK(name) runtime_unlock(name) - -#define CODECACHEMUTEX 0 -#define FREELISTMUTEX 1 -#define STACKPOOLMUTEX 2 -#define FUNCTIONTABLEMUTEX 3 - -#elif PTHREADS // APACHE +#ifdef PTHREADS #define CODECACHEMUTEX 0 #define FREELISTMUTEX 1 diff --git a/src/Runtime/LogLevel.h b/src/Runtime/LogLevel.h deleted file mode 100644 index 3aa50bbb8..000000000 --- a/src/Runtime/LogLevel.h +++ /dev/null @@ -1,24 +0,0 @@ - -#ifndef LOGLEVEL -#define LOGLEVEL - -#ifdef APACHE -enum reportLevel -{ - DIE, - NOTICE, - INFO, - DEBUG -}; - -#else - -enum reportLevel -{ - DIE, - CONTINUE -}; - -#endif - -#endif // LOGLEVEL diff --git a/src/Runtime/Makefile.in b/src/Runtime/Makefile.in index 275061c83..62a6b8989 100644 --- a/src/Runtime/Makefile.in +++ b/src/Runtime/Makefile.in @@ -13,7 +13,7 @@ BINDIR=@top_srcdir@/bin LIBDIR=@top_srcdir@/lib OFILES=Runtime.o IO.o String.o Math.o Region.o Icp.o Table.o Time.o Profiling.o CommandLine.o \ - Posix.o Dlsym.o ../CUtils/hashmap.o ../CUtils/hashmap_typed.o Export.o + Posix.o Dlsym.o ../CUtils/hashmap.o ../CUtils/hashmap_typed.o Export.o Socket.o OFILESWITHGC=$(OFILES) GC.o OFILESWITHPAR=$(OFILES) Spawn.o CFILES_PAR=$(OFILESWITHPAR:%.o=%.c) @@ -27,18 +27,8 @@ OFILES_GEN_GC = $(OFILESWITHGC:%.o=%-gengc.o) 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 -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 -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:=-Wall -std=gnu99 OPT:=$(OPT) $(CFLAGS) @@ -46,7 +36,7 @@ AR=ar rc .PHONY: depend clean runtime all -all: kam runtimeSystemGCProf.a runtimeSystemGC.a runtimeSystemProf.a \ +all: runtimeSystemGCProf.a runtimeSystemGC.a runtimeSystemProf.a \ runtimeSystem.a runtimeSystemTag.a runtimeSystemGCTP.a \ runtimeSystemGCTPProf.a runtimeSystemGenGC.a runtimeSystemGenGCProf.a \ runtimeSystemPar.a @@ -66,14 +56,6 @@ gen_syserror: gen_syserror.c $(CC) gen_syserror.c -o gen_syserror -%-kam.o: %.c - $(CC) -c -DKAM -DLAB_THREADED $(OPT) -o $*-kam.o $< -# $(CC) -c -DKAM -DDEBUG -DLAB_THREADED $(OPT) -o $*-kam.o $< -# $(CC) -c -DKAM $(OPT) -o $*-kam.o $< - -%-smlserver.o: %.c Makefile - $(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 $< @@ -134,16 +116,6 @@ runtimeSystemGenGCProf.a: $(OFILES_GEN_GC_PROF) $(HEADER_FILES) $(MKDIR) $(LIBDIR) $(INSTALLDATA) $@ $(LIBDIR) -kam: $(OFILES_KAM) $(HEADER_FILES) - $(CC) -o $@ $(OFILES_KAM) -lm -ldl -m32 - $(MKDIR) $(LIBDIR) - $(INSTALL) $@ $(LIBDIR) - -runtimeSystemKamApSml.o: $(OFILES_SMLSERVER) $(HEADER_FILES) - ld -r -o $@ $(OFILES_SMLSERVER) - $(MKDIR) $(LIBDIR) - $(INSTALLDATA) $@ $(LIBDIR) - runtimeSystemGCTP.a: $(OFILES_GC_TP) $(HEADER_FILES) $(AR) $@ $(OFILES_GC_TP) $(MKDIR) $(LIBDIR) @@ -170,18 +142,16 @@ depend: $(CC) -MM -DTAG_VALUES -DTAG_FREE_PAIRS -DPROFILING -DENABLE_GC -DENABLE_GEN_GC $(CFILES) | sed -e 's/\.o/-gengc-p.o/'; \ $(CC) -MM -DTAG_VALUES -DENABLE_GC $(CFILES) | sed -e 's/\.o/-gc-tp.o/'; \ $(CC) -MM -DTAG_VALUES -DPROFILING -DENABLE_GC $(CFILES) | sed -e 's/\.o/-gc-tp-p.o/'; \ - $(CC) -MM -DKAM $(CFILES_KAM) | sed -e 's/\.o/-kam.o/'; \ - $(CC) -MM -DKAM $(CFILES_SMLSERVER) | sed -e 's/\.o/-smlserver.o/'; \ $(CC) -MM -DPARALLEL $(CFILES_PAR) | sed -e 's/\.o/-par.o/'; \ $(CC) -MM -DTAG_VALUES -DTAG_FREE_PAIRS $(CFILES) | sed -e 's/\.o/-tag.o/') > Makefile.in 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_GC_PROF) $(OFILES_GC_TP_PROF) rm -f $(OFILES_GEN_GC_PROF) $(OFILES_GEN_GC) $(OFILES_PAR) rm -f core a.out *~ *.bak gen_syserror SysErrTable.h - rm -f runtimeSystemKamApSml.o kam runtimeSystemGCProf.a runtimeSystemGC.a + rm -f runtimeSystemGCProf.a runtimeSystemGC.a rm -f runtimeSystemGCTPProf.a runtimeSystemGCTP.a rm -f runtimeSystemProf.a runtimeSystemTag.a runtimeSystem.a rm -f runtimeSystemGenGCProf.a runtimeSystemGenGC.a runtimeSystemPar.a diff --git a/src/Runtime/Math.c b/src/Runtime/Math.c index 3608d973b..74558eb9b 100644 --- a/src/Runtime/Math.c +++ b/src/Runtime/Math.c @@ -32,18 +32,18 @@ precision(ssize_t dummy) /* ML */ } ssize_t -__div_int31(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ +__div_int31(Context ctx, ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ { int x = (int)x0; int y = (int)y0; if (y == 1) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } if ( y == -1 && x == -2147483647 ) // -2147483647 = 2 * Int31.minInt + 1 { - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); return 0; // never reached } if (x == 1) return 1; @@ -55,18 +55,18 @@ __div_int31(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ } ssize_t -__div_int63(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ +__div_int63(Context ctx, ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ { long int x = (long int)x0; long int y = (long int)y0; if (y == 1) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } if ( y == -1 && x == ( 2 * (-4611686018427387904) + 1 ) ) // = 2 * Int63.minInt + 1 { - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); return 0; // never reached } if (x == 1) return 1; @@ -78,18 +78,18 @@ __div_int63(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ } ssize_t -__div_int32ub(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ +__div_int32ub(Context ctx, ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ { int x = (int)x0; int y = (int)y0; if (y == 0) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } if ( y == -1 && x == (-2147483647 - 1) ) { - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); return 0; // never reached } if (x < 0 && y > 0) @@ -100,18 +100,18 @@ __div_int32ub(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ } ssize_t -__div_int64ub(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ +__div_int64ub(Context ctx, ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ { long int x = (long int)x0; long int y = (long int)y0; if (y == 0) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } if ( y == -1 && x == (-9223372036854775807 - 1) ) { - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); return 0; // never reached } if (x < 0 && y > 0) @@ -122,68 +122,68 @@ __div_int64ub(ssize_t x0, ssize_t y0, uintptr_t exn) /* ML */ } size_t -__div_word32ub(size_t x0, size_t y0, uintptr_t exn) /* ML */ +__div_word32ub(Context ctx, size_t x0, size_t y0, uintptr_t exn) /* ML */ { unsigned int x = (unsigned int)x0; unsigned int y = (unsigned int)y0; if ( y == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } return (x / y); } size_t -__div_word64ub(size_t x0, size_t y0, uintptr_t exn) /* ML */ +__div_word64ub(Context ctx, size_t x0, size_t y0, uintptr_t exn) /* ML */ { unsigned long int x = (unsigned long int)x0; unsigned long int y = (unsigned long int)y0; if ( y == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } return (x / y); } size_t -__div_word31(size_t x, size_t y, uintptr_t exn) /* ML */ +__div_word31(Context ctx, size_t x, size_t y, uintptr_t exn) /* ML */ { unsigned int xC = i31_to_i32ub((unsigned int)x); unsigned int yC = i31_to_i32ub((unsigned int)y); if ( yC == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } return i32ub_to_i31(xC / yC); } size_t -__div_word63(size_t x, size_t y, uintptr_t exn) /* ML */ +__div_word63(Context ctx, size_t x, size_t y, uintptr_t exn) /* ML */ { unsigned long int xC = i63_to_i64ub((unsigned long int)x); unsigned long int yC = i63_to_i64ub((unsigned long int)y); if ( yC == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } return i64ub_to_i63(xC / yC); } ssize_t -__mod_int31(ssize_t x0ML, ssize_t y0ML, uintptr_t exn) +__mod_int31(Context ctx, ssize_t x0ML, ssize_t y0ML, uintptr_t exn) { int xML = (int)x0ML; int yML = (int)y0ML; if ( yML == 1 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } if ((xML-1)%(yML-1) == 0 || (xML>1 && yML>1) || (xML<1 && yML<1)) @@ -193,14 +193,14 @@ __mod_int31(ssize_t x0ML, ssize_t y0ML, uintptr_t exn) } ssize_t -__mod_int63(ssize_t x0ML, ssize_t y0ML, uintptr_t exn) +__mod_int63(Context ctx, ssize_t x0ML, ssize_t y0ML, uintptr_t exn) { long int xML = (long int)x0ML; long int yML = (long int)y0ML; if ( yML == 1 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } if ((xML-1)%(yML-1) == 0 || (xML>1 && yML>1) || (xML<1 && yML<1)) @@ -210,13 +210,13 @@ __mod_int63(ssize_t x0ML, ssize_t y0ML, uintptr_t exn) } ssize_t -__mod_int32ub(ssize_t x0, ssize_t y0, uintptr_t exn) +__mod_int32ub(Context ctx, ssize_t x0, ssize_t y0, uintptr_t exn) { int x = (int)x0; int y = (int)y0; if ( y == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } if ( (x > 0 && y > 0) || (x < 0 && y < 0) || (x % y == 0) ) @@ -227,13 +227,13 @@ __mod_int32ub(ssize_t x0, ssize_t y0, uintptr_t exn) } ssize_t -__mod_int64ub(ssize_t x0, ssize_t y0, uintptr_t exn) +__mod_int64ub(Context ctx, ssize_t x0, ssize_t y0, uintptr_t exn) { long int x = (long int)x0; long int y = (long int)y0; if ( y == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } if ( (x > 0 && y > 0) || (x < 0 && y < 0) || (x % y == 0) ) @@ -244,54 +244,54 @@ __mod_int64ub(ssize_t x0, ssize_t y0, uintptr_t exn) } size_t -__mod_word32ub(size_t x0, size_t y0, uintptr_t exn) +__mod_word32ub(Context ctx, size_t x0, size_t y0, uintptr_t exn) { unsigned int x = (unsigned int)x0; unsigned int y = (unsigned int)y0; if ( y == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } return (x % y); } size_t -__mod_word64ub(size_t x0, size_t y0, uintptr_t exn) +__mod_word64ub(Context ctx, size_t x0, size_t y0, uintptr_t exn) { unsigned long int x = (unsigned long int)x0; unsigned long int y = (unsigned long int)y0; if ( y == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } return (x % y); } size_t -__mod_word31(size_t x, size_t y, uintptr_t exn) +__mod_word31(Context ctx, size_t x, size_t y, uintptr_t exn) { unsigned int xC = i31_to_i32ub((unsigned int)x); unsigned int yC = i31_to_i32ub((unsigned int)y); if ( yC == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } return i32ub_to_i31(xC % yC); } size_t -__mod_word63(size_t x, size_t y, uintptr_t exn) +__mod_word63(Context ctx, size_t x, size_t y, uintptr_t exn) { unsigned long int xC = i63_to_i64ub((unsigned long int)x); unsigned long int yC = i63_to_i64ub((unsigned long int)y); if ( yC == 0 ) { - raise_exn(exn); + raise_exn(ctx,exn); return 0; // never reached } return i64ub_to_i63(xC % yC); @@ -366,33 +366,33 @@ __rem_int63(ssize_t xML, ssize_t yML) #ifdef TAG_VALUES size_t* -__div_int32b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +__div_int32b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn) { - get_i32b(b) = __div_int32ub(get_i32b(x), get_i32b(y), exn); + get_i32b(b) = __div_int32ub(ctx, 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) +__div_word32b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn) { - get_i32b(b) = __div_word32ub(get_i32b(x), get_i32b(y), exn); + get_i32b(b) = __div_word32ub(ctx, 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) +__mod_int32b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn) { - get_i32b(b) = __mod_int32ub(get_i32b(x), get_i32b(y), exn); + get_i32b(b) = __mod_int32ub(ctx, 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) +__mod_word32b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn) { - get_i32b(b) = __mod_word32ub(get_i32b(x), get_i32b(y), exn); + get_i32b(b) = __mod_word32ub(ctx, get_i32b(x), get_i32b(y), exn); set_i32b_tag(b); return b; } @@ -416,33 +416,33 @@ __rem_int32b(size_t* b, size_t* x, size_t* y) } size_t* -__div_int64b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +__div_int64b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn) { - get_i64b(b) = __div_int64ub(get_i64b(x), get_i64b(y), exn); + get_i64b(b) = __div_int64ub(ctx, get_i64b(x), get_i64b(y), exn); set_i64b_tag(b); return b; } size_t* -__div_word64b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +__div_word64b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn) { - get_i64b(b) = __div_word64ub(get_i64b(x), get_i64b(y), exn); + get_i64b(b) = __div_word64ub(ctx, get_i64b(x), get_i64b(y), exn); set_i64b_tag(b); return b; } size_t* -__mod_int64b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +__mod_int64b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn) { - get_i64b(b) = __mod_int64ub(get_i64b(x), get_i64b(y), exn); + get_i64b(b) = __mod_int64ub(ctx, get_i64b(x), get_i64b(y), exn); set_i64b_tag(b); return b; } size_t* -__mod_word64b(size_t* b, size_t* x, size_t* y, uintptr_t exn) +__mod_word64b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn) { - get_i64b(b) = __mod_word64ub(get_i64b(x), get_i64b(y), exn); + get_i64b(b) = __mod_word64ub(ctx, get_i64b(x), get_i64b(y), exn); set_i64b_tag(b); return b; } @@ -530,7 +530,7 @@ realRound(ssize_t d, ssize_t x) } long int -floorFloat(ssize_t f) +floorFloat(Context ctx, ssize_t f) { double r; long int i; @@ -540,13 +540,13 @@ floorFloat(ssize_t f) { if ( r >= (Max_Int_d + 1.0) ) { - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); } return (convertIntToML((long int) r)); } if( r < Min_Int_d ) { - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); } i = (long int) r; if( r < ((double) i) ) @@ -557,20 +557,20 @@ floorFloat(ssize_t f) } ssize_t -truncFloat(ssize_t f) +truncFloat(Context ctx, ssize_t f) { double r; r = get_d(f); if ((r >= (Max_Int_d + 1.0)) || (r <= (Min_Int_d - 1.0))) { - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); } return convertIntToML((ssize_t)r); } ssize_t -ceilFloat(ssize_t f) +ceilFloat(Context ctx, ssize_t f) { double arg; ssize_t i; @@ -591,7 +591,7 @@ ceilFloat(ssize_t f) return convertIntToML(i); raise_ceil: - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); return 0; // never reached } diff --git a/src/Runtime/Math.h b/src/Runtime/Math.h index 5095f4a2e..57edd8bb2 100644 --- a/src/Runtime/Math.h +++ b/src/Runtime/Math.h @@ -61,25 +61,25 @@ ssize_t max_fixed_int(ssize_t dummy); ssize_t min_fixed_int(ssize_t dummy); ssize_t precision(ssize_t dummy); -ssize_t __div_int31(ssize_t x, ssize_t y, uintptr_t exn); -ssize_t __div_int63(ssize_t x, ssize_t y, uintptr_t exn); -ssize_t __mod_int31(ssize_t x, ssize_t y, uintptr_t exn); -ssize_t __mod_int63(ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __div_int31(Context ctx, ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __div_int63(Context ctx, ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __mod_int31(Context ctx, ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __mod_int63(Context ctx, ssize_t x, ssize_t y, uintptr_t exn); ssize_t __quot_int31(ssize_t x, ssize_t y); ssize_t __quot_int63(ssize_t x, ssize_t y); ssize_t __rem_int31(ssize_t x, ssize_t y); ssize_t __rem_int63(ssize_t x, ssize_t y); -size_t __div_word31(size_t x, size_t y, uintptr_t exn); -size_t __div_word63(size_t x, size_t y, uintptr_t exn); -size_t __mod_word31(size_t x, size_t y, uintptr_t exn); -size_t __mod_word63(size_t x, size_t y, uintptr_t exn); +size_t __div_word31(Context ctx, size_t x, size_t y, uintptr_t exn); +size_t __div_word63(Context ctx, size_t x, size_t y, uintptr_t exn); +size_t __mod_word31(Context ctx, size_t x, size_t y, uintptr_t exn); +size_t __mod_word63(Context ctx, size_t x, size_t y, uintptr_t exn); ssize_t realInt(ssize_t d, ssize_t x); -ssize_t floorFloat(ssize_t f); -ssize_t ceilFloat(ssize_t f); +ssize_t floorFloat(Context ctx, ssize_t f); +ssize_t ceilFloat(Context ctx, ssize_t f); ssize_t roundFloat(ssize_t f); -ssize_t truncFloat(ssize_t f); +ssize_t truncFloat(Context ctx, ssize_t f); ssize_t realFloor(ssize_t d, ssize_t x); ssize_t realCeil(ssize_t d, ssize_t x); ssize_t realTrunc(ssize_t d, ssize_t x); @@ -127,35 +127,35 @@ void printReal(size_t f); #ifdef TAG_VALUES -size_t* __div_int32b(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); -size_t* __mod_int32b(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); +size_t* __div_int32b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn); +size_t* __div_word32b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn); +size_t* __mod_int32b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn); +size_t* __mod_word32b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn); size_t* __quot_int32b(size_t* b, size_t* x, size_t* y); size_t* __rem_int32b(size_t* b, size_t* x, size_t* y); -size_t* __div_int64b(size_t* b, size_t* x, size_t* y, uintptr_t exn); -size_t* __div_word64b(size_t* b, size_t* x, size_t* y, uintptr_t exn); -size_t* __mod_int64b(size_t* b, size_t* x, size_t* y, uintptr_t exn); -size_t* __mod_word64b(size_t* b, size_t* x, size_t* y, uintptr_t exn); +size_t* __div_int64b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn); +size_t* __div_word64b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn); +size_t* __mod_int64b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn); +size_t* __mod_word64b(size_t* b, Context ctx, size_t* x, size_t* y, uintptr_t exn); size_t* __quot_int64b(size_t* b, size_t* x, size_t* y); size_t* __rem_int64b(size_t* b, size_t* x, size_t* y); #else -ssize_t __div_int32ub(ssize_t x, ssize_t y, uintptr_t exn); -ssize_t __div_int64ub(ssize_t x, ssize_t y, uintptr_t exn); -ssize_t __mod_int32ub(ssize_t x, ssize_t y, uintptr_t exn); -ssize_t __mod_int64ub(ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __div_int32ub(Context ctx, ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __div_int64ub(Context ctx, ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __mod_int32ub(Context ctx, ssize_t x, ssize_t y, uintptr_t exn); +ssize_t __mod_int64ub(Context ctx, ssize_t x, ssize_t y, uintptr_t exn); ssize_t __quot_int32ub(ssize_t x, ssize_t y); ssize_t __quot_int64ub(ssize_t x, ssize_t y); ssize_t __rem_int32ub(ssize_t x, ssize_t y); ssize_t __rem_int64ub(ssize_t x, ssize_t y); -size_t __div_word32ub(size_t x, size_t y, uintptr_t exn); -size_t __div_word64ub(size_t x, size_t y, uintptr_t exn); -size_t __mod_word32ub(size_t x, size_t y, uintptr_t exn); -size_t __mod_word64ub(size_t x, size_t y, uintptr_t exn); +size_t __div_word32ub(Context ctx, size_t x, size_t y, uintptr_t exn); +size_t __div_word64ub(Context ctx, size_t x, size_t y, uintptr_t exn); +size_t __mod_word32ub(Context ctx, size_t x, size_t y, uintptr_t exn); +size_t __mod_word64ub(Context ctx, size_t x, size_t y, uintptr_t exn); #endif diff --git a/src/Runtime/Posix.c b/src/Runtime/Posix.c index 43da0abf7..acbde6717 100644 --- a/src/Runtime/Posix.c +++ b/src/Runtime/Posix.c @@ -82,7 +82,7 @@ sml_waitpid(uintptr_t pair, size_t waitpid_arg, size_t flags) } ssize_t -sml_sysconf(ssize_t t) +sml_sysconf(Context ctx, ssize_t t) { long res; switch (convertIntToC(t)) @@ -124,7 +124,7 @@ sml_sysconf(ssize_t t) res = sysconf(_SC_GETPW_R_SIZE_MAX); break; default: - raise_exn((uintptr_t)&exn_OVERFLOW); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); res = 0; break; } @@ -142,14 +142,14 @@ usec_of_clock_t(long clk_tck, clock_t c) { } uintptr_t -sml_times(uintptr_t tuple) +sml_times(uintptr_t tuple, Context ctx) // ctx after storage arguments { struct tms buf; clock_t r; long clk_tck = sysconf(_SC_CLK_TCK); mkTagRecordML(tuple, 8); r = times(&buf); // returns number of seconds since year 1970; use getrealtime instead in Posix.sml - if (r == (clock_t) -1) raise_exn((uintptr_t)&exn_OVERFLOW); + if (r == (clock_t) -1) raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); elemRecordML(tuple,0) = convertIntToML(sec_of_clock_t(clk_tck, buf.tms_utime)); elemRecordML(tuple,1) = convertIntToML(usec_of_clock_t(clk_tck, buf.tms_utime)); elemRecordML(tuple,2) = convertIntToML(sec_of_clock_t(clk_tck, buf.tms_stime)); @@ -748,7 +748,7 @@ REG_POLY_FUN_HDR(sml_errorName, Region rs, uintptr_t e) } uintptr_t -REG_POLY_FUN_HDR(sml_getgrgid, uintptr_t triple, Region nameR, Region memberListR, Region memberR, size_t g, size_t s, uintptr_t exn) +REG_POLY_FUN_HDR(sml_getgrgid, uintptr_t triple, Region nameR, Region memberListR, Region memberR, Context ctx, size_t g, size_t s, uintptr_t exn) { uintptr_t res; uintptr_t *list, *pair; @@ -775,7 +775,7 @@ REG_POLY_FUN_HDR(sml_getgrgid, uintptr_t triple, Region nameR, Region memberList if (!gbuf2) { free(b); - raise_exn(exn); + raise_exn(ctx,exn); } first(triple) = (size_t) REG_POLY_CALL(convertStringToML, nameR, gbuf2->gr_name); members = gbuf2->gr_mem; @@ -794,7 +794,7 @@ REG_POLY_FUN_HDR(sml_getgrgid, uintptr_t triple, Region nameR, Region memberList } uintptr_t -REG_POLY_FUN_HDR(sml_getgrnam, uintptr_t triple, Region memberListR, Region memberR, String nameML, size_t s, uintptr_t exn) +REG_POLY_FUN_HDR(sml_getgrnam, uintptr_t triple, Region memberListR, Region memberR, Context ctx, String nameML, size_t s, uintptr_t exn) { uintptr_t res; uintptr_t *list, *pair; @@ -821,7 +821,7 @@ REG_POLY_FUN_HDR(sml_getgrnam, uintptr_t triple, Region memberListR, Region memb if (!gbuf2) { free(b); - raise_exn(exn); + raise_exn(ctx,exn); } first(triple) = convertIntToML(gbuf2->gr_gid); members = gbuf2->gr_mem; @@ -840,7 +840,7 @@ REG_POLY_FUN_HDR(sml_getgrnam, uintptr_t triple, Region memberListR, Region memb } long -REG_POLY_FUN_HDR(sml_getpwuid, long tuple, Region nameR, Region homeR, Region shellR, long u, long s, long exn) +REG_POLY_FUN_HDR(sml_getpwuid, long tuple, Region nameR, Region homeR, Region shellR, Context ctx, long u, long s, long exn) { long res; char *b; @@ -865,7 +865,7 @@ REG_POLY_FUN_HDR(sml_getpwuid, long tuple, Region nameR, Region homeR, Region sh if (!pbuf2) { free(b); - raise_exn(exn); + raise_exn(ctx,exn); } elemRecordML(tuple,0) = (long) REG_POLY_CALL(convertStringToML, nameR, pbuf2->pw_name); elemRecordML(tuple,1) = (long) pbuf2->pw_gid; @@ -876,7 +876,7 @@ REG_POLY_FUN_HDR(sml_getpwuid, long tuple, Region nameR, Region homeR, Region sh } long -REG_POLY_FUN_HDR(sml_getpwnam, long tuple, Region homeR, Region shellR, String nameML, long s, long exn) +REG_POLY_FUN_HDR(sml_getpwnam, long tuple, Region homeR, Region shellR, Context ctx, String nameML, long s, long exn) { long res; char *b; @@ -901,7 +901,7 @@ REG_POLY_FUN_HDR(sml_getpwnam, long tuple, Region homeR, Region shellR, String n if (!pbuf2) { free(b); - raise_exn(exn); + raise_exn(ctx,exn); } elemRecordML(tuple,0) = (long) pbuf2->pw_uid; elemRecordML(tuple,1) = (long) pbuf2->pw_gid; @@ -943,7 +943,7 @@ REG_POLY_FUN_HDR(sml_environ, Region rl, Region rs) } uintptr_t -REG_POLY_FUN_HDR(sml_getgroups, uintptr_t rp, Region rs, uintptr_t exn) +REG_POLY_FUN_HDR(sml_getgroups, uintptr_t rp, Region rs, Context ctx, uintptr_t exn) { uintptr_t *pair, *list; gid_t *tmp; @@ -968,7 +968,7 @@ REG_POLY_FUN_HDR(sml_getgroups, uintptr_t rp, Region rs, uintptr_t exn) if (r == -1) { free(tmp); - raise_exn(exn); + raise_exn(ctx,exn); } for(i=0; ig0); #ifdef ENABLE_GEN_GC set_pairregion(r->g1); @@ -567,9 +544,9 @@ allocatePairRegion(Region r) } Region -allocateArrayRegion(Region r) +allocateArrayRegion(Context ctx, Region r) { - r = allocateRegion0(r); + r = allocateRegion0(ctx,r); set_arrayregion(r->g0); #ifdef ENABLE_GEN_GC set_arrayregion(r->g1); @@ -579,9 +556,9 @@ allocateArrayRegion(Region r) } Region -allocateRefRegion(Region r) +allocateRefRegion(Context ctx, Region r) { - r = allocateRegion0(r); + r = allocateRegion0(ctx,r); set_refregion(r->g0); #ifdef ENABLE_GEN_GC set_refregion(r->g1); @@ -591,9 +568,9 @@ allocateRefRegion(Region r) } Region -allocateTripleRegion(Region r) +allocateTripleRegion(Context ctx, Region r) { - r = allocateRegion0(r); + r = allocateRegion0(ctx,r); set_tripleregion(r->g0); #ifdef ENABLE_GEN_GC set_tripleregion(r->g1); @@ -637,11 +614,7 @@ void free_lobjs(Lobjs* lobjs) * free list. There have to be atleast one region on the stack. * * When profiling we also use this function. * *----------------------------------------------------------------------*/ -void deallocateRegion( -#ifdef KAM - Region* topRegionCell -#endif - ) { +void deallocateRegion(Context ctx) { #ifdef PROFILING int i; #endif @@ -668,19 +641,13 @@ void deallocateRegion( /* Insert the region pages in the freelist; there is always * at least one page in a generation. */ - #ifdef KAM - LOCK_LOCK(FREELISTMUTEX); - #endif last_rp_of_gen(&(TOP_REGION->g0))->n = FREELIST; // Free pages in generation 0 FREELIST = clear_fp(TOP_REGION->g0.fp); #ifdef ENABLE_GEN_GC last_rp_of_gen(&(TOP_REGION->g1))->n = FREELIST; // Free pages in generation 1 FREELIST = clear_fp(TOP_REGION->g1.fp); #endif /* ENABLE_GEN_GC */ - #ifdef KAM - LOCK_UNLOCK(FREELISTMUTEX); - #endif - TOP_REGION=TOP_REGION->p; + TOP_REGION = TOP_REGION->p; debug(printf("]\n")); @@ -712,9 +679,6 @@ alloc_lobjs(int n) { if ( lobjs == NULL ) die("alloc_lobjs: malloc returned NULL"); #endif /* ENABLE_GC */ -#ifdef KAM - lobjs->sizeOfLobj = sizeof(uintptr_t)*n; -#endif return lobjs; } @@ -1014,14 +978,8 @@ void resetGen(Gen *gen) // concerning conservative computation. #endif /* ENABLE_GC */ -#ifdef KAM - LOCK_LOCK(FREELISTMUTEX); -#endif (last_rp_of_gen(gen))->n = FREELIST; FREELIST = (clear_fp(gen->fp))->n; -#ifdef KAM - LOCK_UNLOCK(FREELISTMUTEX); -#endif (clear_fp(gen->fp))->n = NULL; } @@ -1079,56 +1037,17 @@ resetRegion(Region rAdr) } /*-------------------------------------------------------------------------* - *deallocateRegionsUntil: * - * It is called with rAddr=sp, which do not nessesaraly point at a region * - * description. It deallocates all regions that are placed over sp. * - * The function does not return or alter anything. * - *-------------------------------------------------------------------------*/ -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) - { - deallocRegionFiniteProfiling(); - } -#endif - - while (r <= TOP_REGION) - { - /*printf("r: %0x, top region %0x\n",r,TOP_REGION);*/ - deallocateRegion( -#ifdef KAM - topRegionCell -#endif - ); - } - - debug(printf("]\n")); - - return; -} - -/*-------------------------------------------------------------------------* - *deallocateRegionsUntil_X64: version of the above function working with * - * the stack growing towards negative infinity. * + * deallocateRegionsUntil: * + * It is called with rAddr=sp, which do not necessarily point at a region * + * description. It deallocates all regions that are placed under sp. * + * (notice: the stack is growing downwards * *-------------------------------------------------------------------------*/ -#ifndef KAM void -deallocateRegionsUntil_X64(Region r) +deallocateRegionsUntil(Context ctx, Region r) { - // debug(printf("[deallocateRegionsUntil_X64(r = %x, topFiniteRegion = %x)...\n", r, topFiniteRegion)); + // debug(printf("[deallocateRegionsUntil(r = %x, topFiniteRegion = %x)...\n", r, topFiniteRegion)); - debug(printf("[deallocateRegionsUntil_X64(r = %p)...\n", r)); + debug(printf("[deallocateRegionsUntil(r = %p)...\n", r)); r = clearStatusBits(r); @@ -1146,16 +1065,13 @@ deallocateRegionsUntil_X64(Region r) while (r >= TOP_REGION) { /*printf("r: %0x, top region %0x\n",r,TOP_REGION);*/ - deallocateRegion(); + deallocateRegion(ctx); } debug(printf("]\n")); return; } -#endif /* not KAM */ - - /*----------------------------------------------------------------* * Profiling functions * @@ -1180,7 +1096,7 @@ deallocateRegionsUntil_X64(Region r) * roAddr points at. * *----------------------------------------------------------------------*/ Region -allocRegionInfiniteProfiling(Region r, size_t regionId) +allocRegionInfiniteProfiling(Context ctx, Region r, size_t regionId) { /* printf("[allocRegionInfiniteProfiling r=%x, regionId=%d...", r, regionId);*/ @@ -1219,16 +1135,16 @@ allocRegionInfiniteProfiling(Region r, size_t 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(Context ctx, Region r, size_t regionId) { - return allocRegionInfiniteProfiling(r, convertIntToC(regionId)); + return allocRegionInfiniteProfiling(ctx, r, convertIntToC(regionId)); } #ifdef ENABLE_GC Region -allocPairRegionInfiniteProfiling(Region r, size_t regionId) +allocPairRegionInfiniteProfiling(Context ctx, Region r, size_t regionId) { - r = allocRegionInfiniteProfiling(r, regionId); + r = allocRegionInfiniteProfiling(ctx, r, regionId); set_pairregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC set_pairregion(clearStatusBits(r)->g1); @@ -1237,9 +1153,9 @@ allocPairRegionInfiniteProfiling(Region r, size_t regionId) } Region -allocArrayRegionInfiniteProfiling(Region r, size_t regionId) +allocArrayRegionInfiniteProfiling(Context ctx, Region r, size_t regionId) { - r = allocRegionInfiniteProfiling(r, regionId); + r = allocRegionInfiniteProfiling(ctx, r, regionId); set_arrayregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC set_arrayregion(clearStatusBits(r)->g1); @@ -1249,9 +1165,9 @@ allocArrayRegionInfiniteProfiling(Region r, size_t regionId) } Region -allocRefRegionInfiniteProfiling(Region r, size_t regionId) +allocRefRegionInfiniteProfiling(Context ctx, Region r, size_t regionId) { - r = allocRegionInfiniteProfiling(r, regionId); + r = allocRegionInfiniteProfiling(ctx, r, regionId); set_refregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC set_refregion(clearStatusBits(r)->g1); @@ -1261,9 +1177,9 @@ allocRefRegionInfiniteProfiling(Region r, size_t regionId) } Region -allocTripleRegionInfiniteProfiling(Region r, size_t regionId) +allocTripleRegionInfiniteProfiling(Context ctx, Region r, size_t regionId) { - r = allocRegionInfiniteProfiling(r, regionId); + r = allocRegionInfiniteProfiling(ctx, r, regionId); set_tripleregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC set_tripleregion(clearStatusBits(r)->g1); @@ -1273,9 +1189,9 @@ allocTripleRegionInfiniteProfiling(Region r, size_t regionId) } Region -allocPairRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +allocPairRegionInfiniteProfilingMaybeUnTag(Context ctx, Region r, size_t regionId) { - r = allocRegionInfiniteProfiling(r, convertIntToC(regionId)); + r = allocRegionInfiniteProfiling(ctx, r, convertIntToC(regionId)); set_pairregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC set_pairregion(clearStatusBits(r)->g1); @@ -1285,9 +1201,9 @@ allocPairRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) } Region -allocArrayRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +allocArrayRegionInfiniteProfilingMaybeUnTag(Context ctx, Region r, size_t regionId) { - r = allocRegionInfiniteProfiling(r, convertIntToC(regionId)); + r = allocRegionInfiniteProfiling(ctx, r, convertIntToC(regionId)); set_arrayregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC set_arrayregion(clearStatusBits(r)->g1); @@ -1297,9 +1213,9 @@ allocArrayRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) } Region -allocRefRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +allocRefRegionInfiniteProfilingMaybeUnTag(Context ctx, Region r, size_t regionId) { - r = allocRegionInfiniteProfiling(r, convertIntToC(regionId)); + r = allocRegionInfiniteProfiling(ctx, r, convertIntToC(regionId)); set_refregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC set_refregion(clearStatusBits(r)->g1); @@ -1309,9 +1225,9 @@ allocRefRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) } Region -allocTripleRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId) +allocTripleRegionInfiniteProfilingMaybeUnTag(Context ctx, Region r, size_t regionId) { - r = allocRegionInfiniteProfiling(r, convertIntToC(regionId)); + r = allocRegionInfiniteProfiling(ctx, r, convertIntToC(regionId)); set_tripleregion(clearStatusBits(r)->g0); #ifdef ENABLE_GEN_GC set_tripleregion(clearStatusBits(r)->g1); @@ -1436,17 +1352,3 @@ allocProfiling(Region r, size_t n, size_t pPoint) return allocGenProfiling(&(clearStatusBits(r)->g0),n,pPoint); } #endif /*PROFILING*/ - -#ifdef KAM -void -free_region_pages(Rp* first, Rp* last) -{ - if ( first == 0 ) - return; - LOCK_LOCK(FREELISTMUTEX); - last->n = FREELIST; - FREELIST = first; - LOCK_UNLOCK(FREELISTMUTEX); - return; -} -#endif /*KAM*/ diff --git a/src/Runtime/Region.h b/src/Runtime/Region.h index 76195c6be..f49b82882 100644 --- a/src/Runtime/Region.h +++ b/src/Runtime/Region.h @@ -174,9 +174,6 @@ typedef struct lobjs { struct lobjs* next; // pointer to next large object or NULL #ifdef ENABLE_GC void* orig; // pointer to memory allocated by malloc - for freeing -#endif -#ifdef KAM - size_t sizeOfLobj; // size of this object #endif uintptr_t value; // a large object; inlined to avoid pointer-indirection } Lobjs; @@ -266,12 +263,11 @@ 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) -// are used to tell the type of values in the region, in the +// 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. -// We use the three least significant bits: +// on 1k boundaries, plenty of bits are available in the r->g0.fp +// pointer. We use the three least significant bits: // // 000 (hex 0x0) ordinary tagged values // 001 (hex 0x1) pairs @@ -291,11 +287,13 @@ typedef Ro* Region; // X0XXX status NONE saying that the generation is not on the scan stack // 0XXXX this is generation 0 (young generation) // 1XXXX this is generation 1 (old generation) +// // Notice, that the generation g0 is always used no matter what mode // the compiler is in (no gc, gc or gen gc). The generation g1 is only // used when generational gc is enabled. It is thus always possible to // write r->g0, whereas r->g1 makes sense only when generational gc is // enabled. +// // We do not explicitly set the generation 0 bit when allocating a // region because the bit is 0 by default, that is, set_gen_0 is not // used in Region.c @@ -341,21 +339,20 @@ typedef Ro* Region; #define get_ro_from_gen(gen) ( (Ro*)(((uintptr_t)(&(gen)))-offsetG0InRo) ) #endif /* ENABLE_GEN_GC */ -/* -Region polymorphism -------------------- -Regions can be passed to functions at runtime. The machine value that represents -a region in this situation is a 64 bit word. The least significant bit is 1 -iff the region is infinite. The second least significant bit is 1 iff stores -into the region should be preceded by emptying the region of values before -storing the new value (this is called storing a value at the {\em bottom} -of the region and is useful for, among other things, tail recursion). - -*/ +// ## Region polymorphism +// +// Regions can be passed to functions at runtime. The machine value +// that represents a region in this situation is a 64 bit word. The +// least significant bit is 1 iff the region is infinite. The second +// least significant bit is 1 iff stores into the region should be +// preceded by emptying the region of values before storing the new +// value (this is called storing a value at the _bottom_ of the region +// and is useful for, among other things, tail recursion). + +// Operations on the two least significant +// bits in a region pointer. +// C ~ 1100, D ~ 1101, E ~ 1110 og F ~ 1111. -/* Operations on the two least significant */ -/* bits in a regionpointer. */ -/* C ~ 1100, D ~ 1101, E ~ 1110 og F ~ 1111. */ #define setInfiniteBit(x) ((x) | 0x1) #define clearInfiniteBit(x) ((x) & (UINTPTR_MAX ^ 0x1)) @@ -369,43 +366,45 @@ of the region and is useful for, among other things, tail recursion). #define is_inf(x) ((((uintptr_t)(x)) & 0x1)==0x1) #define is_atbot(x) ((((uintptr_t)(x)) & 0x2)==0x2) +// ## Contexts +// +// Evaluation happens in a context, meaning that, during evaluation, +// access to the top-most region, the current exception handler, and +// other stateful information can be accessed through the context. A +// pointer to the context is held in a designated register during +// evaluation. Because evaluation happens in a context, multiple +// threads can execute in parallel in different contexts, which has +// many benefits. + +typedef struct { + Region topregion; // toplevel region + void *exnptr; // pointer to toplevel handler + long int uncaught_exnname; // > 0 implies uncaught exception + Rp *freelist; +} context; + +typedef context* Context; + /*----------------------------------------------------------------* * Type of freelist and top-level region * - * * - * When the KAM backend is used, we use an indirection to hold * - * the top-level region, so as to support multiple threads. * *----------------------------------------------------------------*/ extern Rp * freelist; -#ifdef KAM -#define TOP_REGION (*topRegionCell) -#define FREELIST freelist -void free_region_pages(Rp* first, Rp* last); -#else #ifdef PARALLEL #define TOP_REGION (thread_info()->top_region) #define FREELIST (thread_info()->freelist) #else -extern Ro * topRegion; -#define TOP_REGION topRegion +#define TOP_REGION ctx->topregion #define FREELIST freelist #endif -#endif /*----------------------------------------------------------------* * Prototypes for external and internal functions. * *----------------------------------------------------------------*/ -#ifdef KAM -Region allocateRegion(Region roAddr, Region* topRegionCell); -void deallocateRegion(Region* topRegionCell); -void deallocateRegionsUntil(Region rAdr, Region* topRegionCell); -#else -Region allocateRegion(Region roAddr); -void deallocateRegion(); -void deallocateRegionsUntil(Region rAddr); -void deallocateRegionsUntil_X64(Region rAddr); -#endif +Region allocateRegion(Context ctx, Region roAddr); +void deallocateRegion(Context ctx); +void deallocateRegionsUntil(Context ctx, Region rAddr); uintptr_t *alloc (Region r, size_t n); uintptr_t *alloc_new_block(Gen *gen); @@ -423,19 +422,19 @@ void callSbrkArg(size_t no_of_region_pages); #endif #ifdef ENABLE_GC -Region allocatePairRegion(Region roAddr); -Region allocateArrayRegion(Region roAddr); -Region allocateRefRegion(Region roAddr); -Region allocateTripleRegion(Region roAddr); +Region allocatePairRegion(Context ctx, Region roAddr); +Region allocateArrayRegion(Context ctx, Region roAddr); +Region allocateRefRegion(Context ctx, Region roAddr); +Region allocateTripleRegion(Context ctx, Region roAddr); #ifdef PROFILING -Region allocPairRegionInfiniteProfiling(Region r, size_t regionId); -Region allocPairRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId); -Region allocArrayRegionInfiniteProfiling(Region r, size_t regionId); -Region allocArrayRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId); -Region allocRefRegionInfiniteProfiling(Region r, size_t regionId); -Region allocRefRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId); -Region allocTripleRegionInfiniteProfiling(Region r, size_t regionId); -Region allocTripleRegionInfiniteProfilingMaybeUnTag(Region r, size_t regionId); +Region allocPairRegionInfiniteProfiling(Context ctx, Region r, size_t regionId); +Region allocPairRegionInfiniteProfilingMaybeUnTag(Context ctx, Region r, size_t regionId); +Region allocArrayRegionInfiniteProfiling(Context ctx, Region r, size_t regionId); +Region allocArrayRegionInfiniteProfilingMaybeUnTag(Context ctx, Region r, size_t regionId); +Region allocRefRegionInfiniteProfiling(Context ctx, Region r, size_t regionId); +Region allocRefRegionInfiniteProfilingMaybeUnTag(Context ctx, Region r, size_t regionId); +Region allocTripleRegionInfiniteProfiling(Context ctx, Region r, size_t regionId); +Region allocTripleRegionInfiniteProfilingMaybeUnTag(Context ctx, Region r, size_t regionId); #endif /* PROFILING */ #endif /* ENABLE_GC */ @@ -461,20 +460,19 @@ typedef struct finiteRegionDesc { } FiniteRegionDesc; #define sizeFiniteRegionDesc (sizeof(FiniteRegionDesc)/sizeof(long*)) -/* -Object descriptors ------------------- -When profiling is turned on, every object is prefixed by an -object descriptor, containing the information that is needed -in order to traverse objects in regions and identify allocation -points in the source program. A {\em program point} is an integer -which identifies the point in the source program where a value -is created - the user turns on a flag in the compiler to make -it print programs annotated with their program points. - -Every object is stored taking up a multiple of words (not bytes). -This applies irrespective of whether profiling is turned on or not. -*/ + +// ## Object descriptors +// +// When profiling is turned on, every object is prefixed by an object +// descriptor, containing the information that is needed in order to +// traverse objects in regions and identify allocation points in the +// source program. A {\em program point} is an integer which +// identifies the point in the source program where a value is created +// - the user turns on a flag in the compiler to make it print +// programs annotated with their program points. +// +// Every object is stored taking up a multiple of words (not bytes). +// This applies irrespective of whether profiling is turned on or not. typedef struct objectDesc { size_t atId; /* Allocation point. */ @@ -482,18 +480,17 @@ typedef struct objectDesc { } ObjectDesc; #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 -scans all the regions accessible from the region stack (which -is one of the reasons why region descriptors are linked together). -The scanning of an infinite region is done by scanning each page -in turn. Scanning of a page starts at the left end and progresses -from object to object (using the size information that prefixes -every object) and it stops when the value 'notPP' follows after -an object: -*/ + +// Profiling is done by scanning the store at regular intervals. +// Every such interruption of the normal execution is called a +// _profile tick_. During a profile tick, the runtime system scans all +// the regions accessible from the region stack (which is one of the +// reasons why region descriptors are linked together). The scanning +// of an infinite region is done by scanning each page in +// turn. Scanning of a page starts at the left end and progresses from +// object to object (using the size information that prefixes every +// object) and it stops when the value 'notPP' follows after an +// object: /*----------------------------------------------------------------------* * Extern declarations, mostly of global variables that store profiling * @@ -531,8 +528,8 @@ extern FiniteRegionDesc * topFiniteRegion; // extern uintptr_t size_to_space; /* Profiling functions. */ -Region allocRegionInfiniteProfiling(Region roAddr, size_t regionId); -Region allocRegionInfiniteProfilingMaybeUnTag(Region roAddr, size_t regionId); +Region allocRegionInfiniteProfiling(Context ctx, Region roAddr, size_t regionId); +Region allocRegionInfiniteProfilingMaybeUnTag(Context ctx, Region roAddr, size_t regionId); void allocRegionFiniteProfiling(FiniteRegionDesc *rdAddr, size_t regionId, size_t size); void allocRegionFiniteProfilingMaybeUnTag(FiniteRegionDesc *rdAddr, size_t regionId, size_t size); void deallocRegionFiniteProfiling(void); diff --git a/src/Runtime/Runtime.c b/src/Runtime/Runtime.c index 0cfb8d234..0430eb76f 100644 --- a/src/Runtime/Runtime.c +++ b/src/Runtime/Runtime.c @@ -28,10 +28,6 @@ #include "Profiling.h" #endif -#ifdef KAM -#include "Interp.h" -#endif - #ifdef PARALLEL #include "Spawn.h" #endif @@ -168,10 +164,19 @@ sml_setFailNumber(uintptr_t ep, int i) return; } + +// Here is the main thread's "uncaught exception" handler; for server +// purposes, will later allow for end users to install their own +// uncaught exception handlers. A spawned thread has its own kind of +// uncaught exception handler, which will install the exception value +// in the thread context and raise it if the parent thread tries to +// join the thread. + void -uncaught_exception (String exnStr, unsigned long n, uintptr_t ep) +uncaught_exception (Context ctx, String exnStr, unsigned long n, uintptr_t ep) { uintptr_t a; + ctx->uncaught_exnname = convertIntToC(n); fprintf(stderr,"uncaught exception "); fflush(stderr); fputs(&(exnStr->data), stderr); @@ -309,61 +314,62 @@ sig_handler_segv(int sig, siginfo_t *info, void *extra) } */ -void -sig_handler_int(void) -{ - signal(SIGINT, (SignalHandler)sig_handler_int); /* setup handler again */ - -#ifdef ENABLE_GC - if ( doing_gc ) { - raised_exn_interupt=1; - return; - } -#endif /* ENABLE_GC */ - -#ifdef PROFILING - if ( doing_prof ) { - raised_exn_interupt_prof=1; - return; - } -#endif /* PROFILING */ - - raise_exn((uintptr_t)&exn_INTERRUPT); - return; /* never comes here */ -} - -void -sig_handler_fpe(void) -{ - signal(SIGFPE, (SignalHandler)sig_handler_fpe); /* setup handler again */ - -#ifdef ENABLE_GC - if ( doing_gc ) { - raised_exn_overflow=1; - return; - } -#endif /* ENABLE_GC */ - -#ifdef PROFILING - if ( doing_prof ) { - raised_exn_overflow_prof=1; - return; - } -#endif /* PROFILING */ - - raise_exn((uintptr_t)&exn_OVERFLOW); - return; /* never comes here */ -} - -#ifndef KAM -extern void code(void); -#endif - -#ifndef APACHE +/* void */ +/* sig_handler_int(void) */ +/* { */ +/* signal(SIGINT, (SignalHandler)sig_handler_int); /\* setup handler again *\/ */ + +/* #ifdef ENABLE_GC */ +/* if ( doing_gc ) { */ +/* raised_exn_interupt=1; */ +/* return; */ +/* } */ +/* #endif /\* ENABLE_GC *\/ */ + +/* #ifdef PROFILING */ +/* if ( doing_prof ) { */ +/* raised_exn_interupt_prof=1; */ +/* return; */ +/* } */ +/* #endif /\* PROFILING *\/ */ + +/* raise_exn((uintptr_t)&exn_INTERRUPT); */ +/* return; /\* never comes here *\/ */ +/* } */ + +/* void */ +/* sig_handler_fpe(void) */ +/* { */ +/* signal(SIGFPE, (SignalHandler)sig_handler_fpe); /\* setup handler again *\/ */ + +/* #ifdef ENABLE_GC */ +/* if ( doing_gc ) { */ +/* raised_exn_overflow=1; */ +/* return; */ +/* } */ +/* #endif /\* ENABLE_GC *\/ */ + +/* #ifdef PROFILING */ +/* if ( doing_prof ) { */ +/* raised_exn_overflow_prof=1; */ +/* return; */ +/* } */ +/* #endif /\* PROFILING *\/ */ + +/* raise_exn((uintptr_t)&exn_OVERFLOW); */ +/* return; /\* never comes here *\/ */ +/* } */ + + +extern void code(Context ctx); int main(int argc, char *argv[]) { + Context ctx = (Context) malloc(sizeof(context)); + ctx->topregion = NULL; + ctx->exnptr = NULL; + //static struct sigaction sigact; //static sigset_t sigset; @@ -412,12 +418,8 @@ rpMap = regionPageMapNew(); //signal(SIGFPE, (SignalHandler)sig_handler_fpe); debug(printf("Starting execution...\n");) -#ifdef KAM - return (main_interp(argc, argv)); -#else - code(); + + code(ctx); return (EXIT_FAILURE); /* never comes here (i.e., exits through * terminateML or uncaught_exception) */ -#endif } -#endif diff --git a/src/Runtime/Runtime.h b/src/Runtime/Runtime.h index 939c0c48c..65346746e 100644 --- a/src/Runtime/Runtime.h +++ b/src/Runtime/Runtime.h @@ -7,6 +7,7 @@ #include "String.h" #include "Flags.h" +#include "Region.h" /* Structure of the runtime system is as follows: @@ -65,7 +66,6 @@ int die (const char *); int die2 (const char *, const char *); long terminate (long status); /* status is a C value */ long terminateML (long status); /* status is an ML value */ -void uncaught_exception (StringDesc *exnStr, unsigned long, uintptr_t); +void uncaught_exception (Context ctx, StringDesc *exnStr, unsigned long, uintptr_t); #endif /* RUNTIME_H */ - diff --git a/src/Runtime/Socket.c b/src/Runtime/Socket.c new file mode 100644 index 000000000..a263f79d1 --- /dev/null +++ b/src/Runtime/Socket.c @@ -0,0 +1,471 @@ +// Socket support for MLKit +// Copyright (c) 2021, Martin Elsman +// MIT License + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "Region.h" +#include "List.h" +#include "String.h" +#include "Tagging.h" +#include "Exception.h" + +#define sml_debug(x) ; + +#ifndef HOST_NAME_MAX +#if defined(__APPLE__) +#define HOST_NAME_MAX 255 +#else +#define HOST_NAME_MAX 64 +#endif /* __APPLE__ */ +#endif /* HOST_NAME_MAX */ + +uintptr_t +sml_sock_getDefines(uintptr_t tup) +{ + sml_debug("[sml_sock_getDefines"); + int i = 0; + elemRecordML(tup,i++) = convertIntToML(AF_INET); + elemRecordML(tup,i++) = convertIntToML(AF_UNIX); + elemRecordML(tup,i++) = convertIntToML(INADDR_ANY); + elemRecordML(tup,i++) = convertIntToML(SHUT_RD); + elemRecordML(tup,i++) = convertIntToML(SHUT_RDWR); + elemRecordML(tup,i++) = convertIntToML(SHUT_WR); + elemRecordML(tup,i++) = convertIntToML(SOCK_DGRAM); + elemRecordML(tup,i++) = convertIntToML(SOCK_RAW); + elemRecordML(tup,i++) = convertIntToML(SOCK_STREAM); + elemRecordML(tup,i++) = convertIntToML(SO_BROADCAST); + elemRecordML(tup,i++) = convertIntToML(SO_DEBUG); + elemRecordML(tup,i++) = convertIntToML(SO_DONTROUTE); + elemRecordML(tup,i++) = convertIntToML(SO_ERROR); + elemRecordML(tup,i++) = convertIntToML(SO_KEEPALIVE); + elemRecordML(tup,i++) = convertIntToML(SO_LINGER); + elemRecordML(tup,i++) = convertIntToML(SO_OOBINLINE); + elemRecordML(tup,i++) = convertIntToML(SO_RCVBUF); + elemRecordML(tup,i++) = convertIntToML(SO_REUSEADDR); + elemRecordML(tup,i++) = convertIntToML(SO_SNDBUF); + elemRecordML(tup,i++) = convertIntToML(SO_TYPE); + mkTagRecordML(tup,i); + sml_debug("]\n"); + return tup; +} + +// returns file desc +size_t +sml_sock_socket(size_t d, size_t t) +{ + sml_debug("[sml_sock_socket"); + int res = socket(convertIntToC((int)d), + convertIntToC((int)t), + 0); + sml_debug("]\n"); + return (size_t)convertIntToML(res); +} + +uintptr_t +sml_sock_accept_inet(uintptr_t vTriple, + Context ctx, + size_t sock) +{ + // return type is "sock * addr * port" + // vTriple points to allocated return triple + + sml_debug("[sml_sock_accept_inet"); + + struct sockaddr_in addr; + socklen_t len = sizeof(addr); + + // initialise allocated memory + mkTagTripleML(vTriple); + first(vTriple) = convertIntToML(0); // initialise + second(vTriple) = convertIntToML(0); + third(vTriple) = convertIntToML(0); + int ret = accept(convertIntToC(sock), + (struct sockaddr *) &addr, + &len); + + if (ret < 0 || len > sizeof(addr)) { + sml_debug("]*\n"); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); + } + first(vTriple) = convertIntToML(ret); + second(vTriple) = convertIntToML(ntohl(addr.sin_addr.s_addr)); + third(vTriple) = convertIntToML(ntohs(addr.sin_port)); + sml_debug("]\n"); + return vTriple; +} + +uintptr_t +REG_POLY_FUN_HDR(sml_sock_accept_unix, + uintptr_t vPair, + Region rString, + Context ctx, + size_t sock) +{ + // return type is "sock * name" + // vPair points to allocated return pair + // rString points to a string region + + sml_debug("[sml_sock_accept_unix"); + + struct sockaddr_un addr; + socklen_t len = sizeof(addr); + + // initialise allocated memory + memset(&addr, '\0', sizeof(addr)); // zero structure out + mkTagPairML(vPair); + first(vPair) = convertIntToML(0); // initialise + second(vPair) = convertIntToML(0); + int ret = accept(convertIntToC(sock), + (struct sockaddr *) &addr, + &len); + + if (ret < 0 || len > sizeof(addr)) { + sml_debug("]*\n"); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); + } + first(vPair) = convertIntToML(ret); + second(vPair) = (size_t)(REG_POLY_CALL(convertStringToML, rString, addr.sun_path)); + sml_debug("]\n"); + return vPair; +} + +// returns -1 on error +size_t +sml_sock_listen(size_t sock, size_t i) +{ + sml_debug("[sml_sock_listen"); + int ret = listen(convertIntToC(sock), + convertIntToC(i)); // queue length + sml_debug("]\n"); + return convertIntToML(ret); +} + +// sendvec: sock * vec slice -> int +size_t +sml_sock_sendvec(size_t sock, String s, size_t i, size_t n) +{ + sml_debug("[sml_sock_sendvec"); + char *start = (&(s->data)) + convertIntToC(i); + int ret = send(convertIntToC(sock), (void*)start, convertIntToC(n), 0); + sml_debug("]\n"); + return (size_t)convertIntToML(ret); +} + +// recvvec: ctx * sock * i -> string +String +REG_POLY_FUN_HDR(sml_sock_recvvec, Region rString, Context ctx, size_t sock, size_t i) +{ + sml_debug("[sml_sock_recvvec"); + char *buf = (char *)malloc(i+1); // temporary storage + if (buf == NULL) { + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); + return NULL; + } + int ret = recv(convertIntToC(sock), buf, convertIntToC(i), 0); + if (ret < 0) { + free(buf); + sml_debug("]*\n"); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); + return NULL; + } + String s = REG_POLY_CALL(convertBinStringToML, rString, ret, buf); + free(buf); + sml_debug("]\n"); + return s; +} + +// bind: returns -1 on error +size_t +sml_sock_bind_inet(size_t sock, size_t addr, size_t port) +{ + sml_debug("[sml_sock_bind_inet"); + struct sockaddr_in saddr; + int size = sizeof(struct sockaddr_in); + memset(&saddr, '\0', size); + saddr.sin_family = AF_INET; + saddr.sin_addr.s_addr = htonl(convertIntToC(addr)); + saddr.sin_port = htons(convertIntToC(port)); + + int ret = bind(convertIntToC(sock), + (struct sockaddr *) &saddr, + size); + sml_debug("]\n"); + return convertIntToML(ret); +} + +// bind: returns -1 on error +size_t +sml_sock_bind_unix(size_t sock, String name) +{ + sml_debug("[sml_sock_bind_unix"); + struct sockaddr_un saddr; + int size = sizeStringDefine(name) + 1; // 0-terminated string + saddr.sun_family = AF_UNIX; + bcopy(&(name->data), saddr.sun_path, size); + int ret = bind(convertIntToC(sock), + (struct sockaddr *) &saddr, + size); + sml_debug("]\n"); + return convertIntToML(ret); +} + +// setsockopt: returns -1 on error +size_t +sml_sock_setsockopt(size_t sock, size_t v, size_t b) +{ + sml_debug("[sml_sock_setsockopt"); + int reuse = (b == mlTRUE)? 1 : 0; + int ret = setsockopt(convertIntToC(sock), + SOL_SOCKET, + convertIntToC(v), + (const char*)&reuse, + sizeof(reuse)); + sml_debug("]\n"); + return convertIntToML(ret); +} + +// setsockopt: returns -1 on error +size_t +sml_sock_getsockopt(size_t sock, size_t v) +{ + sml_debug("[sml_sock_getsockopt"); + int res = 0; + socklen_t optlen = sizeof(size_t); + int ret = getsockopt(convertIntToC(sock), + SOL_SOCKET, + convertIntToC(v), + (void*)&res, + &optlen); + sml_debug("]\n"); + if (optlen != sizeof(size_t)) { + return convertIntToML(-1); + } else if (ret < 0) { + return convertIntToML(ret); + } else { + return convertIntToML(res); + } +} + +size_t +sml_sock_shutdown(size_t sock, size_t how) +{ + sml_debug("[sml_sock_shutdown"); + int ret = shutdown(convertIntToC(sock), + convertIntToC(how)); + sml_debug("]"); + return convertIntToML(ret); +} + +// returns accumulated max value of fd +int +mk_set(fd_set *s, uintptr_t xs, int m) +{ + FD_ZERO(s); + while (isCONS(xs)) { + int fd = hd(xs); + FD_SET(fd,s); + m = (fd > m) ? fd : m; + xs = tl(xs); + }; + return m; +} + +uintptr_t +REG_POLY_FUN_HDR(mk_list, Region r, fd_set* s, uintptr_t l) +{ + uintptr_t nl = NIL; // new list + while (isCONS(l)) { + int fd = convertIntToC(hd(l)); + if (FD_ISSET(fd,s)) { + uintptr_t *p; + REG_POLY_CALL(allocPairML,r,p); + first(p) = convertIntToML(fd); + second(p) = nl; + nl = (uintptr_t)p; + }; + l = tl(l); + } + return nl; +} + +uintptr_t +REG_POLY_FUN_HDR(sml_sock_select, + uintptr_t vTriple, Region rRds, Region rWrs, Region rExs, + Context ctx, uintptr_t rds, uintptr_t wrs, uintptr_t exs, double t) +{ + sml_debug("[sml_sock_select"); + mkTagTripleML(vTriple); // initialise result + first(vTriple) = NIL; + second(vTriple) = NIL; + third(vTriple) = NIL; + struct timeval tv; + tv.tv_sec = (uint32_t)t; + tv.tv_usec = (uint32_t)(1.0e6 * (t - (double)tv.tv_sec)); + fd_set r_set, w_set, e_set; + int nfds = 0; + nfds = mk_set(&r_set,rds,nfds); + nfds = mk_set(&w_set,wrs,nfds); + nfds = mk_set(&e_set,exs,nfds); + int ret = select(nfds, + isNIL(rds) ? NULL : &r_set, + isNIL(wrs) ? NULL : &w_set, + isNIL(exs) ? NULL : &e_set, + &tv); + if (ret < 0) { + sml_debug("]*\n"); + raise_exn(ctx,(uintptr_t)&exn_OVERFLOW); + } + first(vTriple) = REG_POLY_CALL(mk_list,rRds,&r_set,rds); + second(vTriple) = REG_POLY_CALL(mk_list,rWrs,&w_set,wrs); + third(vTriple) = REG_POLY_CALL(mk_list,rExs,&e_set,exs); + sml_debug("]"); + return vTriple; +} + + +void +sml_gethostby_init(uintptr_t vTup5) +{ + int i = 0; + elemRecordML(vTup5,i++) = convertIntToML(AF_INET); + elemRecordML(vTup5,i++) = NIL; // addresses + elemRecordML(vTup5,i++) = NIL; // aliases + elemRecordML(vTup5,i++) = NIL; // host name + elemRecordML(vTup5,i++) = convertIntToML(0); // no error + mkTagRecordML(vTup5,i); +} + +void +REG_POLY_FUN_HDR(sml_gethostby_fill, + uintptr_t vTup5, + Region rAddrListPairs, // for address list pairs + Region rAliasListPairs, // for alias list pairs + Region rAliasStrings, // for alias strings + Region rHostNameString, // for host name + struct hostent *host) +{ + elemRecordML(vTup5,3) = (uintptr_t)REG_POLY_CALL(convertStringToML, rHostNameString, host->h_name); + uintptr_t aliases = NIL; + for (int i = 0 ; host->h_aliases[i]; ++i) { + uintptr_t *pair; + REG_POLY_CALL(allocPairML, rAliasListPairs, pair); + mkTagPairML(pair); + first(pair) = (uintptr_t)REG_POLY_CALL(convertStringToML, rAliasStrings, host->h_aliases[i]); + second(pair) = aliases; + aliases = (uintptr_t)pair; + }; + elemRecordML(vTup5,2) = aliases; + + uintptr_t addresses = NIL; + for (int i = 0 ; host->h_addr_list[i]; ++i) { + uintptr_t *pair; + REG_POLY_CALL(allocPairML, rAddrListPairs, pair); + mkTagPairML(pair); + struct in_addr aa; + aa = *(struct in_addr*)(host->h_addr_list[i]); + first(pair) = convertIntToML( (uintptr_t)(ntohl(aa.s_addr)) ); + second(pair) = addresses; + addresses = (uintptr_t)pair; + }; + elemRecordML(vTup5,1) = addresses; +} + +uintptr_t +REG_POLY_FUN_HDR(sml_gethostbyname, + uintptr_t vTup5, + Region rAddrListPairs, // for address list pairs + Region rAliasListPairs, // for alias list pairs + Region rAliasStrings, // for alias strings + Region rHostNameString, // for host name + String n) +{ + sml_debug("[sml_gethostbyname"); + sml_gethostby_init(vTup5); + struct hostent *host = gethostbyname(&(n->data)); + if (host == NULL) { + elemRecordML(vTup5,4) = convertIntToML(-1); + sml_debug("]*\n"); + return vTup5; + }; + REG_POLY_CALL(sml_gethostby_fill, vTup5, rAddrListPairs, + rAliasListPairs, rAliasStrings, rHostNameString, + host); + sml_debug("]\n"); + return vTup5; +} + +uintptr_t +REG_POLY_FUN_HDR(sml_gethostbyaddr, + uintptr_t vTup5, + Region rAddrListPairs, // for address list pairs + Region rAliasListPairs, // for alias list pairs + Region rAliasStrings, // for alias strings + Region rHostNameString, // for host name + uintptr_t a) +{ + sml_debug("[sml_gethostbyaddr"); + sml_gethostby_init(vTup5); + struct in_addr aa; + memset(&aa, '\0', sizeof(struct in_addr)); + aa.s_addr = htonl((unsigned long)convertIntToC(a)); + + struct hostent *host = gethostbyaddr((void*)((struct in_addr*)&aa), + sizeof(struct in_addr), + AF_INET); + if (host == NULL) { + elemRecordML(vTup5,4) = convertIntToML(-1); + sml_debug("]*\n"); + return vTup5; + }; + REG_POLY_CALL(sml_gethostby_fill, vTup5, rAddrListPairs, + rAliasListPairs, rAliasStrings, rHostNameString, + host); + sml_debug("]\n"); + return vTup5; +} + +String +REG_POLY_FUN_HDR(sml_inaddr_tostring, Region rString, uintptr_t a) +{ + sml_debug("[sml_inaddr_tostring"); + struct in_addr aa; + memset(&aa, '\0', sizeof(struct in_addr)); + aa.s_addr = htonl((unsigned long)convertIntToC(a)); + + char d[INET_ADDRSTRLEN]; + const char *s = inet_ntop( AF_INET, + (void*)((struct in_addr*)&aa), + d, + INET_ADDRSTRLEN ); + if (s == NULL) { + sml_debug("]*\n"); + return NULL; + } + String res = REG_POLY_CALL(convertStringToML, rString, s); + sml_debug("]\n"); + return res; +} + +String +REG_POLY_FUN_HDR(sml_gethostname, Region rString) +{ + sml_debug("[sml_gethostname"); + char buf[HOST_NAME_MAX+1]; + if ( gethostname(buf,HOST_NAME_MAX) != 0 ) { + sml_debug("]*\n"); + return NULL; + } + String res = REG_POLY_CALL(convertStringToML, rString, buf); + sml_debug("]\n"); + return res; +} diff --git a/src/Runtime/String.c b/src/Runtime/String.c index 80f1a8fcd..79fa856b4 100644 --- a/src/Runtime/String.c +++ b/src/Runtime/String.c @@ -36,7 +36,7 @@ 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) +convertStringToC(Context ctx, String mlStr, char *buf, size_t buflen, uintptr_t exn) { size_t sz; char *p; @@ -44,7 +44,7 @@ convertStringToC(String mlStr, char *buf, size_t buflen, uintptr_t exn) sz = sizeStringDefine(mlStr); if ( sz > buflen-1) { - raise_exn(exn); + raise_exn(ctx,exn); } for ( p = &(mlStr->data); *p != '\0'; ) { @@ -118,18 +118,6 @@ REG_POLY_FUN_HDR(allocStringC, Region rAddr, size_t sizeC) return strPtr; } -size_t -chrCharML(size_t charNrML, uintptr_t exn) -{ - size_t charNrC = convertIntToC(charNrML); - if ( charNrC <= 255 ) - { - return convertIntToML (charNrC); - } - raise_exn(exn); - return 0; // never reached -} - String REG_POLY_FUN_HDR(concatStringML, Region rAddr, String str1, String str2) { diff --git a/src/Runtime/String.h b/src/Runtime/String.h index b7ccd531f..18b997929 100644 --- a/src/Runtime/String.h +++ b/src/Runtime/String.h @@ -3,7 +3,7 @@ *----------------------------------------------------------------*/ /* - A string is represented as a C-string prepended with the + A string is represented as a C-string prepended with the string size (tagged). A char is represented as an integer (i.e., either as i or 2i+1 if @@ -33,16 +33,12 @@ typedef StringDesc* String; #define sizeStringDefine(str) ((((String)(str))->size) >> 6) /* Remove stringtag. We do not tag the size. */ -void convertStringToC(String mlStr, char *buf, size_t buflen, uintptr_t exn); +void convertStringToC(Context ctx, String mlStr, char *buf, size_t buflen, uintptr_t exn); /****************************************************************** * EXTERNAL DECLARATIONS (ML functions, basislib) * ******************************************************************/ -size_t chrCharML(size_t charNrML, uintptr_t exn); -// int __bytetable_size(String str); -// int __bytetable_sub(String str, int i); -// void __bytetable_update(String str, int i, int c); void printStringML(String str); size_t lessStringML(String str1, String str2); size_t lesseqStringML(String str1, String str2); diff --git a/src/Runtime/Time.c b/src/Runtime/Time.c index a7c0874da..046288136 100644 --- a/src/Runtime/Time.c +++ b/src/Runtime/Time.c @@ -11,6 +11,7 @@ #include "String.h" #include "Math.h" #include "Exception.h" +#include "Region.h" #define tm2cal(tptr) mktime(tptr) @@ -96,7 +97,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, Context ctx, uintptr_t v, int exn) { struct tm tmr; char *r; @@ -113,13 +114,13 @@ REG_POLY_FUN_HDR(sml_asctime, Region rAddr, uintptr_t v, int exn) r = asctime_r(&tmr, res); if ( r == NULL ) { - raise_exn(exn); + raise_exn(ctx,exn); } return REG_POLY_CALL(convertStringToML, rAddr, res); } String -REG_POLY_FUN_HDR(sml_strftime, Region rAddr, String fmt, uintptr_t v, int exn) +REG_POLY_FUN_HDR(sml_strftime, Region rAddr, Context ctx, String fmt, uintptr_t v, int exn) { struct tm tmr; int ressize; @@ -137,7 +138,7 @@ REG_POLY_FUN_HDR(sml_strftime, Region rAddr, String fmt, uintptr_t v, int exn) ressize = strftime(buf, BUFSIZE, &(fmt->data), &tmr); if ( ressize == 0 || ressize == BUFSIZE ) { - raise_exn(exn); + raise_exn(ctx,exn); } return REG_POLY_CALL(convertStringToML, rAddr, buf); #undef BUFSIZE diff --git a/src/RuntimePaML/.cvsignore b/src/RuntimePaML/.cvsignore deleted file mode 100644 index aca961fa9..000000000 --- a/src/RuntimePaML/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.o *.s \ No newline at end of file diff --git a/src/RuntimePaML/Makefile b/src/RuntimePaML/Makefile deleted file mode 100644 index 41d0c99c5..000000000 --- a/src/RuntimePaML/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -all: Region.o - -runtime: Region.h Region.c - m68k-palmos-coff-gcc -O3 -S Region.c -o Region.s - m68k-palmos-coff-as -l -m68000 -o Region.o Region.s - diff --git a/src/RuntimePaML/Region.c b/src/RuntimePaML/Region.c deleted file mode 100644 index 9a386c37d..000000000 --- a/src/RuntimePaML/Region.c +++ /dev/null @@ -1,205 +0,0 @@ -/*----------------------------------------------------------------* - * Regions * - *----------------------------------------------------------------*/ -#include -#include -#include -#include "Region.h" - -/*----------------------------------------------------------------* - * Global declarations * - *----------------------------------------------------------------*/ -ULong bytes_alloc = 0; -Regionpage* freelist; -Regiondesc* topRegion; -static UInt heapNo = 0; // 0 is dynamic, 1 is storage. -static Word cardNo = 0; // Always card number 0. -static UInt heapId = 0; // Set in function set_card_info. - -// Should raise Panic exception, 17/01-2000, Niels! -void panic(CharPtr errorStr) { - // FrmCustomAlert(alertID_panic,errorStr,"",""); - //exit(-1); //How do we exit the application, NH -} - -// Should raise Panic exception, 17/01-2000, Niels! -void panicN(CharPtr errorStr, ULong n) { - char tmp_text[100]; - StrPrintF(tmp_text, "[%lu] ", n); - StrCat(tmp_text,errorStr); - // FrmCustomAlert(alertID_panic,tmp_text,"",""); - //exit(-1); //How do we exit the application, NH -} - -Regionpage *mem_ptr_new() { - ULong free, max; - Err err; - Regionpage *rp; - - err = MemHeapFreeBytes(heapId, &free, &max); - if (err) - panic("mem_ptr_new: MemHeapFreeBytes"); - if (max < 5*1024) { - // Use storage memory - panic("Use storage memory."); - rp = NULL; - } - else { - // Use dynamic memory - rp = (Regionpage *)MemPtrNew(sizeof(Regionpage)); - if (rp == NULL) - panic("mem_ptr_new: I cound not allocate more memory"); - } - return rp; -} - -void alloc_regionpages() { - Regionpage *np; - ULong m = NUM_REG_PAGES_ALLOC_BY_SBRK; - - freelist = mem_ptr_new(); - m--; - - np = freelist; - while (m) { - np->n = mem_ptr_new(); - np = np->n; - m--; - } - - np->n = NULL; -} - -ULong *alloc_region(Regiondesc *rdAddr) { - Regionpage *rp; - - rdAddr = (Regiondesc *) clearStatusBits((ULong)rdAddr); - - if (freelist==NULL) alloc_regionpages(); - - rp = freelist; - freelist = freelist->n; - - rp->n = NULL; - - rdAddr->a = (ULong *)(&(rp->i)); /* We allocate from k.i in the page. */ - rdAddr->b = (ULong *)(rp+1); /* The border is after this page. */ - rdAddr->p = topRegion; /* Push this region onto the region stack. */ - rdAddr->fp = rp; /* Update pointer to the first page. */ - topRegion = rdAddr; - - /* We have to set the infinitebit. */ - rdAddr = (Regiondesc *) setInfiniteBit((ULong)rdAddr); - - return (ULong *)rdAddr; -} - -ULong *dealloc_region() { - ULong *sp; - - sp = (ULong *) topRegion; /* topRegion points at the bottom of the region - * descriptor on the stack. */ - - /* Insert the region pages in the freelist; there is always - * at-least one page in a region. */ - (((Regionpage *)topRegion->b)-1)->n = freelist; - freelist = topRegion->fp; - topRegion=topRegion->p; - - return sp; -} - -/*----------------------------------------------------------------------* - *alloc: * - * Allocates n words in region rAddr. It will make sure, that there * - * is space for the n words before doing the allocation. * - * Pre-condition: n <= ALLOCATABLE_WORDS_IN_REGION_PAGE * - *----------------------------------------------------------------------*/ -void get_regionpage_from_freelist(Regiondesc* rd) { - Regionpage* rp; - - if (freelist==NULL) alloc_regionpages(); - - rp = freelist; - freelist= freelist->n; - rp->n = NULL; - - if (rd->fp) - (((Regionpage *)(rd->b))-1)->n = rp; /* Updates the next field in the last region page. */ - else - rd->fp = rp; /* Update pointer to the first page. */ - - rd->a = (ULong *)(&(rp->i)); /* Updates the allocation pointer. */ - rd->b = (ULong *)(rp+1); /* Updates the border pointer. */ -} - -ULong *alloc (ULong rdAddr, int n) { - ULong *t1; - ULong *t2; - ULong *t3; - Regiondesc *rd; - - rd = (Regiondesc *) clearStatusBits(rdAddr); - - t1 = rd->a; - t2 = t1 + n; - - t3 = rd->b; - if (t2 > t3) { - get_regionpage_from_freelist(rd); - - t1 = rd->a; - t2 = t1 + n; - } - rd->a = t2; - - return t1; -} - -/*----------------------------------------------------------------------* - *resetRegion: * - * All regionpages except one are inserted into the free list, and * - * the region administration structure is updated. The statusbits are * - * not changed. * - *----------------------------------------------------------------------*/ -ULong reset_region(ULong rdAddr) { - Regiondesc *rd; - - rd = (Regiondesc *) clearStatusBits(rdAddr); - - /* There is always at least one page in a region. */ - if ( (rd->fp)->n != NULL ) { /* There are more than one page in the region. */ - (((Regionpage *)rd->b)-1)->n = freelist; - freelist = (rd->fp)->n; - (rd->fp)->n = NULL; - } - - rd->a = (ULong *)(&(rd->fp)->i); /* beginning of klump in first page */ - rd->b = (ULong *)((rd->fp)+1); /* end of klump in first page */ - - return rdAddr; /* We preserve rdAddr and the status bits. */ -} - -/*-------------------------------------------------------------------------* - *deallocateRegionsUntil: * - * Called with rdAddr=sp, which do not nessesaraly point at a region * - * descriptor. It deallocates all regions that are placed over sp. * - * The function does not return or alter anything. * - *-------------------------------------------------------------------------*/ -void dealloc_regions_until(ULong rdAddr) { - Regiondesc *rd; - - rd = (Regiondesc *) clearStatusBits(rdAddr); - - while (rd <= topRegion) - dealloc_region(); - - return; -} - -void init_runtime_system() { - heapId = MemHeapID(cardNo,heapNo); - freelist = NULL; - topRegion = NULL; - alloc_regionpages(); -} diff --git a/src/RuntimePaML/Region.h b/src/RuntimePaML/Region.h deleted file mode 100644 index e342f572c..000000000 --- a/src/RuntimePaML/Region.h +++ /dev/null @@ -1,127 +0,0 @@ -/*----------------------------------------------------------------* - * Regions * - *----------------------------------------------------------------*/ -#ifndef __REGION__ -#define __REGION__ - -/* -Overview --------- - -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. -Otherwise it is infinite. - -The runtime representation of a region depends on whether the region -is finite or infinite. - -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: the region is n/4 words on the runtime stack -(b) Infinite region -- meaning that the region can contain objects - of different sizes. The region is represented by a - {\em region descriptor} on the runtime stack. The region descriptor - points to the beginning and the end of a linked list of - fixed size region pages (see below). - -A {\em region page} consists of a header and an array of words that -can be used for allocation. The header takes up -HEADER_WORDS_IN_REGION_PAGE words, while the number of words -that can be allocated is ALLOCATABLE_WORDS_IN_REGION_PAGE. -Thus, a region page takes up -HEADER_WORDS_IN_REGION_PAGE + ALLOCATABLE_WORDS_IN_REGION_PAGE -words in all. -*/ - - -#define ALLOCATABLE_WORDS_IN_REGION_PAGE 63 -// A region page is 256 bytes. - -// Region pages are word aligned. Make sure that it's ok for regionpages containing double's. -typedef union regionpage { - union regionpage* n; /* NULL or pointer to next page. */ - ULong i[ALLOCATABLE_WORDS_IN_REGION_PAGE]; /* Space for data*/ -} Regionpage; - -#define HEADER_WORDS_IN_REGION_PAGE 1 - -/* -Free region pages are kept in a free list. When the free list becomes empty and -more space is required, the runtime system calls the Palm operating system -in order to get space for a number (here 10) fresh region pages: -*/ -#define NUM_REG_PAGES_ALLOC_BY_SBRK 30 - -/* -Region descriptors ------------------- -regiondesc is the type of region descriptors. Region descriptors are kept on -the runtime stack and are linked together so that one can traverse the stack -of regions (for popping of regions when exceptions are raised) -*/ - -typedef struct regiondesc { - struct regiondesc* p; /* Pointer to previous region descriptor. It has to be at - the bottom of the structure */ - ULong* a; /* Pointer to first unused word in the newest region page - of the region. */ - ULong* 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.*/ - Regionpage* 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.*/ - -} Regiondesc; -#define sizeRd (sizeof(Regiondesc)/4) /* Size of region descriptor in words */ -#define freeInRegion(rAddr) (rAddr->b - rAddr->a) /* Returns freespace in words. */ - -/* -Region polymorphism -------------------- -Regions can be passed to functions at runtime. The machine value that represents -a region in this situation is a 32 bit word. The least significant bit is 1 -iff the region is infinite. The second least significant bit is 1 iff stores -into the region should be preceded by emptying the region of values before -storing the new value (this is called storing a value at the {\em bottom} -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 clearInfiniteBit(x) ((x) & 0xFFFFFFFE) -#define setAtbotBit(x) ((x) | 0x00000002) -#define clearAtbotBit(x) ((x) & 0xFFFFFFFD) -#define setStatusBits(x) ((x) | 0x00000003) -#define clearStatusBits(x) ((x) & 0xFFFFFFFC) -#define is_inf_and_atbot(x) (((x) & 0x00000003)==0x00000003) - -/*----------------------------------------------------------------* - * Prototypes for external and internal functions. * - *----------------------------------------------------------------*/ -extern ULong bytes_alloc; -extern Regionpage* freelist; -extern Regiondesc* topRegion; - -ULong *alloc_region(Regiondesc *rdAddr); -ULong *dealloc_region(); -ULong *alloc (ULong rdAddr, int n); -ULong reset_region(ULong rdAddr); -void dealloc_regions_until(ULong rdAddr); -void init_runtime_system(); - -#endif /*__REGION__*/ - - - - diff --git a/src/SMLserver/.cvsignore b/src/SMLserver/.cvsignore deleted file mode 100644 index 6bcea37b5..000000000 --- a/src/SMLserver/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -.libs HashTable.lo HashTable.slo \ No newline at end of file diff --git a/src/SMLserver/HashTable.c b/src/SMLserver/HashTable.c deleted file mode 100644 index 48de1f47a..000000000 --- a/src/SMLserver/HashTable.c +++ /dev/null @@ -1,105 +0,0 @@ -// Hash tables with strings as domain - -#include -#include -#include "HashTable.h" - -static int -stringHash(char *s) -{ - int acc = 0; - for ( ; *s ; s++ ) - acc = 19 * acc + *s; - return acc; -} - -HashTable -emptyHashTable(int arraySize) -{ - HashTable h; - int i; - int sz_bytes; - - // MEMO: arraySize should be rounded up to a power of two minus one - - sz_bytes = 4 * (arraySize+1) + sizeof(struct hashTable); - h = (HashTable)malloc(sz_bytes); - h->arraySize = arraySize; - h->size = 0; - for ( i = 0 ; i <= arraySize ; i ++ ) - { - h->array[i] = 0; - } - return h; -} - -static char* -lookupObjectList(ObjectListHashTable *ol, char *key) -{ - for ( ; ol ; ol = ol->next ) - { - if ( strcmp(ol->key, key) == 0 ) - { - return ol->value; - } - } - return 0; -} - -char* -lookupHashTable(HashTable h, char* key) -{ - int hash; - hash = stringHash(key) & (h->arraySize); - return lookupObjectList(h->array[hash], key); -} - -void insertHashTable(HashTable h, char* key, char* value) -{ - int hash; - ObjectListHashTable *ol_new, *ol_old; - key = strdup(key); - hash = stringHash(key) & (h->arraySize); - ol_old = h->array[hash]; - ol_new = (ObjectListHashTable *)malloc(sizeof(ObjectListHashTable)); - ol_new->key = key; - ol_new->value = value; - ol_new->next = ol_old; - h->array[hash] = ol_new; - h->size = h->size + 1; - return; -} - -static void -freeObjectList(ObjectListHashTable *ol) -{ - ObjectListHashTable *ol_prev = 0; - for ( ; ol ; ol = ol->next ) - { - if ( ol_prev ) - { - free(ol_prev->key); - free(ol_prev); - } - ol_prev = ol; - } - if ( ol_prev ) - { - free(ol_prev->key); - free(ol_prev); - } - return; -} - -void -freeHashTable(HashTable h) -{ - int i; - for ( i = 0 ; i <= h->arraySize ; i ++ ) - { - freeObjectList(h->array[i]); - } - free(h); - return; -} - diff --git a/src/SMLserver/HashTable.h b/src/SMLserver/HashTable.h deleted file mode 100644 index 4def0fa95..000000000 --- a/src/SMLserver/HashTable.h +++ /dev/null @@ -1,25 +0,0 @@ - -// Hash tables with strings as keys (keys are copied during insert) - -typedef struct objectListHashTable { - char *key; - char *value; /* entry */ - struct objectListHashTable *next; /* next hashed element */ -} ObjectListHashTable; - -struct hashTable { - int size; /* Number of elements in the hash table */ - int arraySize; /* Size of array */ - ObjectListHashTable *array[0]; -}; - -typedef struct hashTable* HashTable; - -HashTable emptyHashTable(int arraySize); - -char* lookupHashTable(HashTable h, char* key); -// returns NULL if the entry does not exist - -void insertHashTable(HashTable, char* key, char* value); - -void freeHashTable(HashTable h); diff --git a/src/SMLserver/apache/.cvsignore b/src/SMLserver/apache/.cvsignore deleted file mode 100644 index bf6924716..000000000 --- a/src/SMLserver/apache/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -Makefile .libs \ No newline at end of file diff --git a/src/SMLserver/apache/.gitignore b/src/SMLserver/apache/.gitignore deleted file mode 100644 index c2295e125..000000000 --- a/src/SMLserver/apache/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -Makefile -lex.yy.c -ul.tab.c -ul.tab.h -ul.output \ No newline at end of file diff --git a/src/SMLserver/apache/DbCommon.c b/src/SMLserver/apache/DbCommon.c deleted file mode 100644 index 487b61df2..000000000 --- a/src/SMLserver/apache/DbCommon.c +++ /dev/null @@ -1,148 +0,0 @@ - -#include "DbCommon.h" -#include "mod_sml.h" -#include "apr_thread_cond.h" - -/* -void * -getSharedMem(void *rd, int size) -{ - return (void *) apr_shm_baseaddr_get(((request_data *) rd)->ctx->cachelock.shm); -} - -int -create_proc_lock(proc_lock *plock, char *plockname, void *rd) -{ - apr_status_t status; - status = apr_proc_mutex_create((apr_proc_mutex_t **) plock, plockname, APR_LOCK_DEFAULT, - ((request_rec *) rd)->server->process->pconf); - if (status == APR_SUCCESS) return 0; - return 1; -} -*/ - -int -create_thread_lock(thread_lock *tlock, void *rd) -{ - apr_status_t status; - status = apr_thread_mutex_create((apr_thread_mutex_t **) tlock, APR_THREAD_MUTEX_DEFAULT, - ((request_rec *) rd)->server->process->pconf); - if (status == APR_SUCCESS) return 0; - return 1; -} - -/* -void -lock_proc(proc_lock plock) -{ - apr_proc_mutex_lock(plock); - return; -} - -void -unlock_proc(proc_lock plock) -{ - apr_proc_mutex_unlock(plock); - return; -} -*/ - -void -lock_thread(thread_lock tlock) -{ - apr_thread_mutex_lock(tlock); - return; -} - -void -unlock_thread(thread_lock tlock) -{ - apr_thread_mutex_unlock(tlock); - return; -} - -/* -void -destroy_proc_lock(proc_lock plock) -{ - apr_proc_mutex_destroy(plock); - return; -} -*/ - -void -destroy_thread_lock(thread_lock tlock) -{ - apr_thread_mutex_destroy(tlock); - return; -} - -/* -void proc_lock_child_init(proc_lock *plock, char *plockname, void *pool) -{ - apr_proc_mutex_child_init((apr_proc_mutex_t **) plock, plockname, (apr_pool_t *) pool); - return; -} -*/ - -struct cond_var1 -{ - apr_thread_cond_t *cvar; - apr_thread_mutex_t *mutex; -}; - -int -create_cond_variable(cond_var *cvar, thread_lock l, void *rd) -{ - apr_status_t status; - struct cond_var1 *tmp = (struct cond_var1 *) malloc(sizeof(struct cond_var1)); - if (!tmp) return 1; - tmp->mutex = (apr_thread_mutex_t *) l; - status = apr_thread_cond_create(&(tmp->cvar), ((request_rec *) rd)->server->process->pconf); - if (status != APR_SUCCESS) - { - free(tmp); - return 1; - } - *cvar = tmp; - return 0; -} - -void -destroy_cond_variable(cond_var cvar) -{ - struct cond_var1 *tmp = (struct cond_var1 *) cvar; - apr_thread_cond_destroy(tmp->cvar); - free(tmp); - return; -} - -void -signal_cond(cond_var cvar) -{ - struct cond_var1 *tmp = (struct cond_var1 *) cvar; - apr_thread_cond_signal(tmp->cvar); - return; -} - -void -broadcast_cond(cond_var cvar) -{ - struct cond_var1 *tmp = (struct cond_var1 *) cvar; - apr_thread_cond_broadcast(tmp->cvar); - return; -} - -void -wait_cond(cond_var cvar) -{ - struct cond_var1 *tmp = (struct cond_var1 *) cvar; - apr_thread_cond_wait(tmp->cvar,tmp->mutex); - return; -} - -void -raise_overflow(void) -{ - raise_exn ((int) &exn_OVERFLOW); -} diff --git a/src/SMLserver/apache/DbCommon.h b/src/SMLserver/apache/DbCommon.h deleted file mode 100644 index 68abc2f5e..000000000 --- a/src/SMLserver/apache/DbCommon.h +++ /dev/null @@ -1,45 +0,0 @@ - -//typedef void * proc_lock; -typedef void * thread_lock; -typedef void * cond_var; - -//int create_proc_lock(proc_lock *plock, char *plockname, void *rd); -//void destroy_proc_lock(proc_lock plock); - -int create_thread_lock(thread_lock *tlock, void *rd); -void destroy_thread_lock(thread_lock tlock); - -//void lock_proc(proc_lock plock); -//void unlock_proc(proc_lock plock); - -void lock_thread(thread_lock tlock); -void unlock_thread(thread_lock tlock); - -int create_cond_variable(cond_var *, thread_lock, void *rd); -void destroy_cond_variable(cond_var); -void signal_cond(cond_var); -void wait_cond(cond_var); -void broadcast_cond(cond_var); - -// void * getSharedMem(void *rd, int size); -//void proc_lock_child_init(proc_lock *plock, char *plockname, void *pool); - -void raise_overflow(void); - -void dblog1(void *rd, char *txt); -void dblog2(void *rd, char *txt, int num); - -void * getDbData(int num, void *rd); - - -int putDbData(int num, void *dbdata, void *rd); - -void * getDbData(int num, void *rd); - -void removeDbData(int num, void *rd); - -void * apsmlGetDBData (int i, void *rd); -int apsmlPutDBData (int i, void *data, void child_init(void *, int, void *, void *), - void tmp_shutdown(void *, void *), - void req_cleanup(void *, void *), - void *rd); diff --git a/src/SMLserver/apache/Locks.h b/src/SMLserver/apache/Locks.h deleted file mode 100644 index c3604aa69..000000000 --- a/src/SMLserver/apache/Locks.h +++ /dev/null @@ -1,7 +0,0 @@ -#ifndef APACHE_LOCKS_H -#define APACHE_LOCKS_H - -void runtime_lock(unsigned int i); -void runtime_unlock(unsigned int i); - -#endif // APACHE_LOCKS_H diff --git a/src/SMLserver/apache/Makefile.in b/src/SMLserver/apache/Makefile.in deleted file mode 100644 index 56a11d11a..000000000 --- a/src/SMLserver/apache/Makefile.in +++ /dev/null @@ -1,91 +0,0 @@ -SHELL=@SHELL@ - -APXS=@apxs@ -ORACLE=@oracle_dir@ -ODBC=@odbc@ -CC=@CC@ -LN=@LN_S@ -MKDIR=@top_srcdir@/mkinstalldirs -INSTALL=@INSTALL@ -INSTALLDATA=@INSTALL_DATA@ -prefix=@prefix@ -LIBDIR=$(DESTDIR)@libdir@ -SOURCE=mod_sml.c mod_smllib.c DbCommon.c mailer.c cache.c dnsresolve.c \ - ../../Runtime/runtimeSystemKamApSml.o ul.tab.c lex.yy.c parseul.c \ - sched.c greeting.c -TARGET=mod_sml.la -ORACLELIB=libsmloracle.so.1.0 -ODBCLIB=libsmlodbc.so.1.0 -CFLAGS=@CFLAGS@ -OPT= -Wall -std=gnu99 -g $(CFLAGS) - -@SET_MAKE@ - -.PHONY: install all clean oracle installsml oracle_install odbc odbc_install - -ALL=${TARGET} -INST=installsml -ifneq (${ORACLE}x,x) -ALL+= oracle -INST+= oracle_install -endif - -ifneq ($(ODBC)x,nox) -ALL+= odbc -INST+= odbc_install -endif - -all: ${ALL} - -install: $(INST) - -${TARGET}: ${SOURCE} Makefile - $(APXS) -DAPACHE -Wc,"$(OPT)" -c -lresolv -lm -L. ${SOURCE} - -oracle: $(ORACLELIB) -odbc: $(ODBCLIB) - -$(ORACLELIB): oracle.c - ${CC} $(OPT) -I ${ORACLE}/sdk/include -c -fpic -DAPACHE oracle.c - ${CC} -shared -Wl,-soname,libsmloracle.so.1 -L $(ORACLE) -lclntsh -DAPACHE oracle.o -o $(ORACLELIB) - -$(ODBCLIB): odbc.c - $(CC) $(OPT) -c -fpic -DAPACHE odbc.c - $(CC) -shared -Wl,-soname,libsmlodbc.so.1 -DAPACHE odbc.o -o $(ODBCLIB) -lodbc - -# ${LN}f libsmloracle.so.1.0 libsmloracle.so.1 -# ${LN}f libsmloracle.so.1 libsmloracle.so - -installsml: ${TARGET} -# ${APXS} -i -a -n sml mod_sml.la - $(MKDIR) $(LIBDIR) - $(INSTALL) .libs/mod_sml.so $(LIBDIR) - -oracle_install: oracle - $(MKDIR) $(LIBDIR) - $(INSTALL) $(ORACLELIB) $(LIBDIR) - cd $(LIBDIR) && ${LN} -f libsmloracle.so.1.0 libsmloracle.so.1 - cd $(LIBDIR) && ${LN} -f libsmloracle.so.1 libsmloracle.so - -odbc_install: odbc - $(MKDIR) $(LIBDIR) - $(INSTALL) $(ODBCLIB) $(LIBDIR) - cd $(LIBDIR) && ${LN} -f libsmlodbc.so.1.0 libsmlodbc.so.1 - cd $(LIBDIR) && ${LN} -f libsmlodbc.so.1 libsmlodbc.so - -ul.tab.h: ul.y - bison -d ul.y - -ul.tab.c: ul.tab.h ul.y - -lex.yy.c: ul.lex ul.tab.h - flex -s ul.lex - -parseul.c: ul.tab.c - -t: parseul.o ul.tab.o lex.yy.o ulflat.o - $(CC) -o t $(OPT) -g parseul.o ul.tab.o lex.yy.o ulflat.o - -clean: - rm -f mod_sml.la libsmloracle.so.1.0 *.o *~ *.lo *.slo libsmlodbc.so.1.0 ul.tab.c ul.output lex.yy.c ul.tab.h a.log - diff --git a/src/SMLserver/apache/Notes b/src/SMLserver/apache/Notes deleted file mode 100644 index 6ad8064d9..000000000 --- a/src/SMLserver/apache/Notes +++ /dev/null @@ -1,2 +0,0 @@ -Changes the closure property of ctx to a global InterpContext pointer. As ctx -was only read, this is fine. diff --git a/src/SMLserver/apache/README b/src/SMLserver/apache/README deleted file mode 100644 index 3b17124e4..000000000 --- a/src/SMLserver/apache/README +++ /dev/null @@ -1,21 +0,0 @@ -cd mlkit/kit -make smlserver - -To generate a runtime for apache 2.0: - cd src/SMLServer/apache - make clean - edit Makefile - AP_SERVER_MINORVERSION_NUMBER=0 make - -cat README - -To get Apache2 to process .sml files add the following to httpd.conf - -LoadModule sml_module modules/mod_sml.so - - -AddHandler sml-module .sml -AddHandler sml-module .msp -SmlPrjId "web" -SmlPath "/home/varming/apache2/htdocs/web/www" - diff --git a/src/SMLserver/apache/a.tex b/src/SMLserver/apache/a.tex deleted file mode 100644 index 43823b99e..000000000 --- a/src/SMLserver/apache/a.tex +++ /dev/null @@ -1,91 +0,0 @@ - -\documentclass[a4paper]{article} - -\usepackage[latin1]{inputenc} % Dansk tegnsæt: ÆØÅæøå er lækre at have. -\usepackage{amsmath,amssymb} % amsmath og amssymb er rare når matematik optræder -\usepackage[english]{babel} % Danske navne. Contents -> Indhold, osv. -\usepackage{a4wide} % Brug lidt mere af papiret. -\usepackage{semantic} - -\newcommand{\bfandup}[1]{\textbf{\textup{#1}}} -\newcommand{\dom}{\textup{dom}} -\reservestyle{\command}{\bfandup} -\command{ULFILES,UOFILES,END,CODEFILES,SCRIPT,SCRIPTS,AS,LOC} - - -\begin{document} -\begin{gather*} -\inference -{ - \Gamma |- uo \Downarrow \Gamma' & name.uo \notin\dom(\Gamma') -} -{ - \Gamma |- uo \quad name.uo \Downarrow \Gamma',f(name.uo) -}\\ -\inference -{ - \Delta |- sml \Downarrow \Delta';\zeta' & l(name.sml) \notin\dom(\Delta') -} -{ - \Delta |- sml \quad name.sml.uo \Downarrow \Delta', - l(name.sml) : f(name.sml.uo);\zeta',l(name.sml) -}\\ -\inference -{ - \Delta |- sml \Downarrow \Delta';\zeta' & l(loc,name.sml) \notin\dom(\Delta') & loc[0] \neq '/' -} -{ - \Delta |- sml \quad name.sml.uo \quad \ \quad loc \Downarrow \Delta', - l(loc,name.sml) : f(name.sml.uo);\zeta',l(loc,name.sml) -}\\ -\inference -{ - \Delta |- sml \Downarrow \Delta';\zeta' & l(loc,name.sml) \notin\dom(\Delta') & loc[0] = '/' -} -{ - \Delta |- sml \quad name.sml.uo \quad \ \quad loc \Downarrow \Delta', - l(loc,name.sml) : f(name.sml.uo);\zeta' -}\\ -\inference -{ - f(name.ul) \notin \Psi'\\ - \Psi;\Gamma;\Delta |- ul \Downarrow \Psi';\Gamma';\Delta' & - \Psi',f(name.ul); \Gamma';\Delta' |- open (f(name.ul)) \Downarrow - \Psi'';\Gamma'';\Delta'';\zeta -} -{ - \Psi;\Gamma;\Delta |- ul \quad name.ul \quad \