├── lib ├── polymlb ├── basis │ ├── poly.mlb │ └── basis.mlb └── poly │ ├── polyml.mlb │ ├── sml90.mlb │ ├── runcall.mlb │ ├── hash-array.mlb │ ├── weak.mlb │ ├── asn1.mlb │ ├── signal.mlb │ ├── single-assignment.mlb │ ├── foreign.mlb │ ├── universal.mlb │ ├── thread.mlb │ └── net6.mlb ├── src ├── millet │ ├── basis.mlb │ ├── poly.mlb │ ├── bin.mlb │ ├── threadpools.mlb │ ├── polymlb.mlb │ └── stub.sml ├── bin │ ├── version.sml │ ├── build.sml │ └── main.sml └── lib │ ├── ThreadPools │ ├── QUEUE.sig │ ├── threadpools.mlb │ ├── ml_bind.sml │ ├── FifoQueue.fun │ ├── ThreadPool.fun │ └── PrioQueue.fun │ ├── polymlb.mlb │ ├── Log.sml │ ├── Path.sml │ ├── build.sml │ ├── Ann.sml │ ├── PolyMLB.sml │ ├── Basis.sml │ ├── Lex.sml │ ├── Parse.sml │ ├── Dag.sml │ ├── NameSpace.sml │ └── Compile.sml ├── test ├── sml │ ├── source │ │ ├── bad-exec.sml │ │ ├── illegal.sml │ │ └── good.sml │ ├── path.sml │ ├── compile.sml │ ├── namespace.sml │ ├── queues.sml │ ├── lex.sml │ ├── dag.sml │ ├── parse.sml │ └── basis.sml ├── repos │ ├── apltail.t │ ├── smlfmt.t │ ├── smlpkg.t │ ├── aplcompile.t │ ├── smlpkg.patch │ ├── aplcompile.patch │ └── apltail.patch ├── Makefile └── test.sml ├── millet.toml ├── Makefile ├── bumpver ├── LICENSE ├── README ├── polymlb.1 └── LIBRARY /lib/polymlb: -------------------------------------------------------------------------------- 1 | ../src/lib/ -------------------------------------------------------------------------------- /src/millet/basis.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | -------------------------------------------------------------------------------- /test/sml/source/bad-exec.sml: -------------------------------------------------------------------------------- 1 | raise Fail "raised" 2 | -------------------------------------------------------------------------------- /test/sml/source/illegal.sml: -------------------------------------------------------------------------------- 1 | val i : int = "foo" 2 | -------------------------------------------------------------------------------- /lib/basis/poly.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | open PolyLib 5 | end 6 | -------------------------------------------------------------------------------- /lib/basis/basis.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | open BasisLib 5 | end 6 | -------------------------------------------------------------------------------- /lib/poly/polyml.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | structure PolyML 5 | end 6 | -------------------------------------------------------------------------------- /lib/poly/sml90.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | structure SML90 5 | end 6 | -------------------------------------------------------------------------------- /lib/poly/runcall.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | structure RunCall 5 | end 6 | -------------------------------------------------------------------------------- /lib/poly/hash-array.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | structure HashArray 5 | end 6 | -------------------------------------------------------------------------------- /src/bin/version.sml: -------------------------------------------------------------------------------- 1 | val VERSION_MAJOR = 0 2 | val VERSION_MINOR = 3 3 | val VERSION_PATCH = 0 4 | -------------------------------------------------------------------------------- /lib/poly/weak.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | signature WEAK 5 | structure Weak 6 | end 7 | -------------------------------------------------------------------------------- /lib/poly/asn1.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | (* signature ASN1 *) 5 | structure Asn1 6 | end 7 | -------------------------------------------------------------------------------- /lib/poly/signal.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | signature SIGNAL 5 | structure Signal 6 | end 7 | -------------------------------------------------------------------------------- /lib/poly/single-assignment.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | structure SingleAssignment 5 | end 6 | -------------------------------------------------------------------------------- /test/repos/apltail.t: -------------------------------------------------------------------------------- 1 | url=https://github.com/melsman/apltail 2 | sha=ba4df01047fc6e8062584b020c5aab2d15f1a26d 3 | -------------------------------------------------------------------------------- /test/repos/smlfmt.t: -------------------------------------------------------------------------------- 1 | url=https://github.com/shwestrick/smlfmt 2 | sha=5c297d257503aed9e2e5e623347e64c8d7487c0f 3 | -------------------------------------------------------------------------------- /test/repos/smlpkg.t: -------------------------------------------------------------------------------- 1 | url=https://github.com/diku-dk/smlpkg 2 | sha=55e41a0a64255243934eba39adff8842a539436a 3 | -------------------------------------------------------------------------------- /test/repos/aplcompile.t: -------------------------------------------------------------------------------- 1 | url=https://github.com/melsman/aplcompile 2 | sha=645f133d00b9a6f856013a75a5579d9d12cf78d9 3 | -------------------------------------------------------------------------------- /lib/poly/foreign.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | (* signature FOREIGN *) 5 | structure Foreign 6 | end 7 | -------------------------------------------------------------------------------- /lib/poly/universal.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | structure Universal 5 | structure UniversalArray 6 | end 7 | -------------------------------------------------------------------------------- /lib/poly/thread.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | signature THREAD 5 | structure Thread 6 | structure ThreadLib 7 | end 8 | -------------------------------------------------------------------------------- /lib/poly/net6.mlb: -------------------------------------------------------------------------------- 1 | ann 2 | "poly:importAll" 3 | in 4 | structure Net6HostDB 5 | signature INET6_SOCK 6 | structure INet6Sock 7 | end 8 | -------------------------------------------------------------------------------- /test/sml/source/good.sml: -------------------------------------------------------------------------------- 1 | signature SIG = 2 | sig 3 | val i : int 4 | end 5 | 6 | structure Str : SIG = 7 | struct 8 | val i = 5 9 | end 10 | -------------------------------------------------------------------------------- /src/millet/poly.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | in 4 | ann 5 | "milletDiagnosticsIgnore true" 6 | in 7 | stub.sml 8 | end 9 | end 10 | -------------------------------------------------------------------------------- /millet.toml: -------------------------------------------------------------------------------- 1 | version = 1 2 | [workspace] 3 | root = "src/millet/bin.mlb" 4 | [workspace.path-vars] 5 | ROOT = { path = "src/lib" } 6 | [diagnostics] 7 | 5038.severity = "ignore" 8 | 5043.severity = "ignore" 9 | -------------------------------------------------------------------------------- /src/lib/ThreadPools/QUEUE.sig: -------------------------------------------------------------------------------- 1 | signature QUEUE = 2 | sig 3 | type t 4 | type inc 5 | type outc 6 | val new : unit -> t 7 | val enq : t * inc -> unit 8 | val deq : t -> outc option 9 | end 10 | -------------------------------------------------------------------------------- /src/millet/bin.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | poly.mlb 4 | polymlb.mlb 5 | $(ROOT)/build.sml 6 | in 7 | ../bin/version.sml 8 | ../bin/main.sml 9 | ../bin/build.sml 10 | end 11 | -------------------------------------------------------------------------------- /src/lib/ThreadPools/threadpools.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | $(SML_LIB)/basis/poly.mlb 4 | QUEUE.sig 5 | FifoQueue.fun 6 | PrioQueue.fun 7 | ThreadPool.fun 8 | in 9 | ml_bind.sml 10 | end 11 | -------------------------------------------------------------------------------- /src/millet/threadpools.mlb: -------------------------------------------------------------------------------- 1 | local 2 | basis.mlb 3 | poly.mlb 4 | $(ROOT)/ThreadPools/QUEUE.sig 5 | $(ROOT)/ThreadPools/FifoQueue.fun 6 | $(ROOT)/ThreadPools/PrioQueue.fun 7 | $(ROOT)/ThreadPools/ThreadPool.fun 8 | in 9 | $(ROOT)/ThreadPools/ml_bind.sml 10 | end 11 | -------------------------------------------------------------------------------- /src/lib/polymlb.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | $(SML_LIB)/basis/poly.mlb 4 | ThreadPools/threadpools.mlb 5 | Log.sml 6 | Lex.sml 7 | Parse.sml 8 | Ann.sml 9 | Path.sml 10 | Basis.sml 11 | Dag.sml 12 | NameSpace.sml 13 | Compile.sml 14 | in 15 | PolyMLB.sml 16 | end 17 | -------------------------------------------------------------------------------- /src/millet/polymlb.mlb: -------------------------------------------------------------------------------- 1 | local 2 | basis.mlb 3 | poly.mlb 4 | threadpools.mlb 5 | $(ROOT)/Log.sml 6 | $(ROOT)/Lex.sml 7 | $(ROOT)/Parse.sml 8 | $(ROOT)/Ann.sml 9 | $(ROOT)/Path.sml 10 | $(ROOT)/Basis.sml 11 | $(ROOT)/Dag.sml 12 | $(ROOT)/NameSpace.sml 13 | $(ROOT)/Compile.sml 14 | in 15 | $(ROOT)/PolyMLB.sml 16 | end 17 | -------------------------------------------------------------------------------- /src/lib/ThreadPools/ml_bind.sml: -------------------------------------------------------------------------------- 1 | structure ThreadPools = 2 | let 3 | structure Fifo = FifoQueue (type elt = unit -> unit) 4 | structure Prio = PrioQueue (type elt = unit -> unit) 5 | in 6 | struct 7 | structure FTP = ThreadPool (struct open Fifo fun conv x = x end) 8 | structure PTP = ThreadPool (struct open Prio fun conv (_, x) = x end) 9 | end 10 | end 11 | -------------------------------------------------------------------------------- /test/repos/smlpkg.patch: -------------------------------------------------------------------------------- 1 | diff --git a/src/futpkg.sml b/src/futpkg.sml 2 | index 2b73589..d6cfa7e 100644 3 | --- a/src/futpkg.sml 4 | +++ b/src/futpkg.sml 5 | @@ -1,2 +1,2 @@ 6 | 7 | -val () = Pkg.main "futhark.pkg" 8 | +fun main () = Pkg.main "futhark.pkg" 9 | diff --git a/src/smlpkg.sml b/src/smlpkg.sml 10 | index 655937b..19f3cd0 100644 11 | --- a/src/smlpkg.sml 12 | +++ b/src/smlpkg.sml 13 | @@ -1,2 +1,2 @@ 14 | 15 | -val () = Pkg.main "sml.pkg" 16 | +fun main () = Pkg.main "sml.pkg" 17 | -------------------------------------------------------------------------------- /test/sml/path.sml: -------------------------------------------------------------------------------- 1 | structure H = HashArray 2 | structure P = PolyMLB.Path 3 | 4 | val vars : string H.hash = H.hash 10; 5 | app (fn (k, v) => H.update (vars, k, v)) 6 | [ ("foo", "bar") 7 | , ("var1", "$(var2)") 8 | , ("var2", "var3") 9 | , ("empty", "") 10 | ]; 11 | 12 | val p = P.process vars; 13 | 14 | "Path.process substitutes simple variables" 15 | assert p "a $(foo) b" eq P.Path "a bar b"; 16 | 17 | "Path.process substitutes recursive and empty variables" 18 | assert p "$(var1) $(empty)." eq P.Path "var3 ."; 19 | 20 | "Path.process fails on first unbound variable" 21 | assert p "$(unset) $(unset2)" eq P.Unbound "unset"; 22 | 23 | "Path.process fails on nameless variables" 24 | assert p "$()" eq P.Unbound "" 25 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | POLYMLB != realpath ../polymlb 2 | 3 | SML != ls sml/*.sml 4 | REPOS != ls repos/*.t 5 | REPOS_DIR := repos/r 6 | 7 | all: sml 8 | 9 | sml: $(SML) 10 | 11 | $(SML): 12 | @ echo 'PolyML.print_depth ~1; use "test.sml"; use "$@";' | poly -q --error-exit 13 | @ echo $@: OK 14 | 15 | repos: $(REPOS) 16 | 17 | # requires gmake 18 | $(REPOS): 19 | @ [ -d "$(REPOS_DIR)/$(@F:.t=)" ] || { \ 20 | . $@ && \ 21 | git clone -c advice.detachedHead=false --depth=1 --revision=$$sha \ 22 | $$url $(REPOS_DIR)/$(@F:.t=) && \ 23 | cd $(REPOS_DIR)/$(@F:.t=) && \ 24 | smlpkg sync && \ 25 | git apply ../../$(@F:.t=.patch); \ 26 | } > /dev/null 27 | $(MAKE) -sj1 -C $(REPOS_DIR)/$(@F:.t=) MLCOMP="$(POLYMLB) -q" clean all 28 | 29 | clean: 30 | rm -rf $(REPOS_DIR) 31 | 32 | .PHONY: $(SML) $(REPOS) all clean 33 | -------------------------------------------------------------------------------- /test/repos/aplcompile.patch: -------------------------------------------------------------------------------- 1 | diff --git a/aplc.sml b/aplc.sml 2 | index 5970740..55f901d 100644 3 | --- a/aplc.sml 4 | +++ b/aplc.sml 5 | @@ -1,10 +1,8 @@ 6 | structure AplToMla = AplCompile(Mla) 7 | structure AplToC = AplCompile(ILapl) 8 | 9 | -val name = CommandLine.name() 10 | - 11 | fun usage() = 12 | - (print ("Usage: " ^ name ^ " [-o ofile] [-c] [-v] [-ml] file.apl...\n" ^ 13 | + (print ("Usage: " ^ CommandLine.name() ^ " [-o ofile] [-c] [-v] [-ml] file.apl...\n" ^ 14 | " -o file : specify output file\n" ^ 15 | " -c : compile only (no evaluation)\n" ^ 16 | " -noopt : disable optimizations\n" ^ 17 | @@ -29,4 +27,4 @@ fun runargs args flags = 18 | else !compileAndRunFiles flags args 19 | | nil => usage () 20 | 21 | -val () = runargs (CommandLine.arguments()) nil 22 | +fun main () = runargs (CommandLine.arguments()) nil 23 | -------------------------------------------------------------------------------- /test/repos/apltail.patch: -------------------------------------------------------------------------------- 1 | diff --git a/Makefile b/Makefile 2 | index 7433195..5087cb5 100644 3 | --- a/Makefile 4 | +++ b/Makefile 5 | @@ -29,10 +29,10 @@ src/version~: force 6 | @echo '$(GIT_VERSION) $(GIT_DATE)' | cmp -s - $@ || echo '$(GIT_VERSION) $(GIT_DATE)' > $@ 7 | 8 | src/version.sml: src/version~ 9 | - @echo "structure Version = struct\n\ 10 | + @printf "structure Version = struct\n\ 11 | val version = \"$(GIT_VERSION)\"\n\ 12 | val date = \"$(GIT_DATE)\"\n\ 13 | - val platform = \"$(PLATFORM)\"\nend" > $@ 14 | + val platform = \"$(PLATFORM)\"\nend\n" > $@ 15 | @echo Generated file $@ 16 | @echo Git version $(GIT_VERSION) $(GIT_DATE) 17 | 18 | diff --git a/src/aplt.sml b/src/aplt.sml 19 | index 2a7db7f..4ac39ca 100644 20 | --- a/src/aplt.sml 21 | +++ b/src/aplt.sml 22 | @@ -152,6 +152,6 @@ fun usage() = 23 | " -opt_loopsplit : enable loop split optimization in LAILA code generation\n" 24 | 25 | (* Parse command line arguments and pass to compileAndRun *) 26 | -val () = Flags.runargs {usage = usage, 27 | +fun main () = Flags.runargs {usage = usage, 28 | run = compileAndRun, 29 | unaries = ["-o","-oc","-O"]} 30 | -------------------------------------------------------------------------------- /src/lib/ThreadPools/FifoQueue.fun: -------------------------------------------------------------------------------- 1 | (* Two-lock fifo queue from "Simple, fast, and practical non-blocking and 2 | * blocking concurrent queue algorithms", Maged M. Michael and Michael L. Scott. 3 | * see: 4 | * https://www.cs.rochester.edu/~scott/papers/1996_PODC_queues.pdf 5 | *) 6 | functor FifoQueue (type elt) :> QUEUE 7 | where type inc = elt and type outc = elt = 8 | struct 9 | structure M = Thread.Mutex 10 | 11 | type inc = elt 12 | type outc = elt 13 | 14 | datatype n = E | N of elt * n ref 15 | 16 | type t = 17 | { hd : n ref ref 18 | , tl : n ref ref 19 | , hm : M.mutex 20 | , tm : M.mutex 21 | } 22 | 23 | fun new () = 24 | let 25 | val r = ref E 26 | in 27 | { hd = ref r 28 | , tl = ref r 29 | , hm = M.mutex () 30 | , tm = M.mutex () 31 | } 32 | end 33 | 34 | fun enq ({ tl, tm, ... } : t, x) = 35 | let 36 | val r = ref E 37 | in 38 | M.lock tm; 39 | !tl := N (x, r); 40 | tl := r; 41 | M.unlock tm 42 | end 43 | 44 | fun deq ({ hd, hm, ... } : t) = 45 | case (M.lock hm; !(!hd)) of 46 | E => (M.unlock hm; NONE) 47 | | N (x, hd') => (hd := hd'; M.unlock hm; SOME x) 48 | end 49 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PREFIX ?= /usr/local 2 | MANPREFIX ?= $(PREFIX)/share 3 | BINDIR ?= $(PREFIX)/bin 4 | LIBDIR ?= $(PREFIX)/lib 5 | MANDIR ?= $(MANPREFIX)/man 6 | 7 | SML_LIB ?= $(LIBDIR)/polymlb 8 | POLYC ?= polyc 9 | INSTALL ?= install 10 | 11 | SRC != find src/bin src/lib -name '*.sml' -o -name '*.sig' -o -name '*.fun' 12 | MLB != find src/lib -name '*.mlb' 13 | 14 | all: polymlb 15 | 16 | polymlb: $(SRC) 17 | SML_LIB=$(SML_LIB) $(POLYC) -o $@ src/bin/build.sml 18 | 19 | sml_lib: polymlb 20 | $(eval SML_LIB != ./polymlb -sml-lib) 21 | 22 | test: 23 | $(MAKE) -C test all 24 | 25 | install: all sml_lib 26 | $(INSTALL) -m 755 -d $(DESTDIR)$(BINDIR) 27 | $(INSTALL) -m 755 -d $(DESTDIR)$(SML_LIB) 28 | $(INSTALL) -m 755 -d $(DESTDIR)$(MANDIR)/man1 29 | $(INSTALL) -m 755 polymlb $(DESTDIR)$(BINDIR) 30 | cp -RL lib/* $(DESTDIR)$(SML_LIB) 31 | $(INSTALL) -m 644 polymlb.1 $(DESTDIR)$(MANDIR)/man1 32 | 33 | $(MLB): 34 | sed \ 35 | -e '/mlb$$/s:^\([[:space:]]*\).*/:\1:g' \ 36 | -e '/\(sml\|sig\|fun\)$$/s:^\([[:space:]]*\):\1$$(ROOT)$(@D:src/lib%=%)/:g' \ 37 | < $@ > src/millet/$(@F) 38 | 39 | millet-stubs: $(MLB) 40 | 41 | clean: 42 | rm -f polymlb 43 | 44 | test-clean: 45 | $(MAKE) -C test clean 46 | 47 | .PHONY: $(MLB) all clean install millet-stubs sml_lib test 48 | -------------------------------------------------------------------------------- /src/bin/build.sml: -------------------------------------------------------------------------------- 1 | val SML_LIB = 2 | case OS.Process.getEnv "SML_LIB" of 3 | SOME v => v 4 | | NONE => raise Fail "missing SML_LIB"; 5 | 6 | let 7 | val (libDir, binDir) = 8 | case PolyML.getUseFileName () of 9 | NONE => (print "invalid usage; import with use\n"; raise Fail "") 10 | | SOME d => 11 | let 12 | open OS.Path 13 | val usePath = OS.FileSys.fullPath (dir d) 14 | val cwd = OS.FileSys.getDir () 15 | val binDir = mkRelative { path = usePath, relativeTo = cwd } 16 | val libDir = (mkCanonical o concat) (binDir, "../lib") 17 | in 18 | (libDir, binDir) 19 | end 20 | 21 | fun eval s = 22 | let 23 | val str = TextIO.openString s 24 | in 25 | PolyML.compiler (fn () => TextIO.input1 str, []) () 26 | end 27 | in 28 | if OS.Path.isRelative SML_LIB then 29 | TextIO.output (TextIO.stdErr, "warning: SML_LIB: relative path\n") 30 | else 31 | (); 32 | 33 | if String.isSuffix "/" SML_LIB then 34 | TextIO.output (TextIO.stdErr, "warning: SML_LIB: trailing '/'\n") 35 | else 36 | (); 37 | 38 | use (libDir ^ "/build.sml"); 39 | eval ("HashArray.update (PolyMLB.pathMap, \"SML_LIB\", \"" ^ SML_LIB ^ "\")"); 40 | use (binDir ^ "/version.sml"); 41 | use (binDir ^ "/main.sml") 42 | end 43 | -------------------------------------------------------------------------------- /bumpver: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | case $1 in 4 | major) prog=' 5 | /MAJOR/ { $2++; major = $2; print $1 "= " $2 } 6 | /MINOR/ { minor = 0; print $1 "= 0" } 7 | /PATCH/ { patch = 0; print $1 "= 0" } 8 | ';; 9 | minor) prog=' 10 | /MAJOR/ { major = $2 + 0; print $0 } 11 | /MINOR/ { $2++; minor = $2; print $1 "= " $2 } 12 | /PATCH/ { patch = 0; print $1 "= 0" } 13 | ';; 14 | patch) prog=' 15 | /MAJOR/ { major = $2 + 0; print $0 } 16 | /MINOR/ { minor = $2 + 0; print $0 } 17 | /PATCH/ { $2++; patch = $2; print $1 "= " $2 } 18 | ';; 19 | *) echo "usage: $(basename $0) {major|minor|patch}" && exit 1 20 | esac 21 | 22 | cd "$(dirname $0)" 23 | 24 | if [ "$(git branch --show-current)" != main ]; then 25 | echo "must be on main branch" 26 | exit 1 27 | elif ! git diff-index --quiet HEAD; then 28 | echo "uncommited changes" 29 | exit 1 30 | fi 31 | 32 | end='END { print major "." minor "." patch }' 33 | prog="$prog $end" 34 | 35 | file=src/bin/version.sml 36 | 37 | z=$(awk -F '=' "$prog" < "$file") 38 | ver="$(echo "$z" | tail -1)" 39 | echo "$(echo "$z" | head -n -1)" > "$file" 40 | 41 | sed -i "1s/.*/.Dd $(date "+%B %d, %Y")/" polymlb.1 42 | 43 | git commit -am "v$ver" || { echo "could not commit" && exit 1; } 44 | 45 | if git tag -a -m "release v$ver" "v$ver"; then 46 | echo "bumped to $ver" 47 | else 48 | echo "could not tag" 49 | exit 1 50 | fi 51 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2024, vqn 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 16 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 17 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 19 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 21 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 22 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 23 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 24 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /src/lib/Log.sml: -------------------------------------------------------------------------------- 1 | structure Log :> 2 | sig 3 | datatype level = Trace | Debug | Info | Warn | Error 4 | type event = level * (unit -> string) 5 | type pathFmt = string -> string 6 | type logger = { pathFmt : pathFmt, print : event -> unit } 7 | 8 | val log : logger option -> level -> (pathFmt -> string) -> unit 9 | 10 | val locFmt : pathFmt -> PolyML.location -> string 11 | 12 | val levelToInt : level -> int 13 | val levelFromInt : int -> level 14 | end = 15 | struct 16 | datatype level = Trace | Debug | Info | Warn | Error 17 | type event = level * (unit -> string) 18 | type pathFmt = string -> string 19 | type logger = { pathFmt : pathFmt, print : event -> unit } 20 | 21 | fun log NONE _ _ = () 22 | | log (SOME { pathFmt, print }) l f = print (l, fn () => f pathFmt) 23 | 24 | val int = Int.toString 25 | 26 | fun locFmt fmt { file, startLine, startPosition, endLine, endPosition } = 27 | String.concat 28 | ( fmt file ^ ":" 29 | :: (if startLine = 0 then 30 | [] 31 | else 32 | [ int startLine, ".", int startPosition, "-" 33 | , int endLine, ".", int endPosition 34 | ]) 35 | ) 36 | 37 | fun levelToInt l = 38 | case l of 39 | Error => 1 40 | | Warn => 2 41 | | Info => 3 42 | | Debug => 4 43 | | Trace => 5 44 | 45 | fun levelFromInt i = 46 | case i of 47 | 1 => Error 48 | | 2 => Warn 49 | | 3 => Info 50 | | 4 => Debug 51 | | 5 => Trace 52 | | _ => raise Fail ("Log.levelFromInt: invalid input: " ^ Int.toString i) 53 | end 54 | -------------------------------------------------------------------------------- /test/sml/compile.sml: -------------------------------------------------------------------------------- 1 | structure C = PolyMLB.Compile 2 | structure N = PolyML.NameSpace 3 | 4 | datatype z = datatype PolyMLB.Basis.dec 5 | 6 | fun compile b () = C.compile 7 | { depsFirst = false, jobs = 0, logger = NONE } 8 | (PolyMLB.Dag.process { logger = NONE, reduce = true } 9 | (fn "root" => [Ann ([PolyMLB.Ann.ImportAll], b)] 10 | | _ => raise Fail "") 11 | "root"); 12 | 13 | "Compile.compile raises on invalid sml source" 14 | assert 15 | compile [SourceFile "sml/source/illegal.sml"] 16 | raisesMatching 17 | (fn C.Compile (C.Compilation _) => true | _ => false); 18 | 19 | "Compile.compile re-raises execution exns" 20 | assert 21 | compile [SourceFile "sml/source/bad-exec.sml"] 22 | raisesMatching 23 | (fn C.Compile (C.Execution _) => true | _ => false); 24 | 25 | "Compile.compile raises on invalid bind" 26 | assert 27 | compile [Structure ("S1", "S2")] 28 | raisesExact 29 | C.Compile (C.UnboundId "S2"); 30 | 31 | fun compile b = C.compile 32 | { depsFirst = false, jobs = 0, logger = NONE } 33 | (PolyMLB.Dag.process 34 | { logger = NONE, reduce = true } 35 | (fn "root" => [Ann ([PolyMLB.Ann.ImportAll], b)] 36 | | _ => raise Fail "") 37 | "root"); 38 | 39 | "Compile.compile valid" 40 | assert 41 | compile [SourceFile "sml/source/good.sml", Signature ("SIG2", "SIG")] 42 | is 43 | (fn (PolyMLB.NameSpace.N (_, ns)) => 44 | PolyML.pointerEq (valOf (#lookupSig ns "SIG2"), valOf (#lookupSig ns "SIG")) 45 | andalso 46 | case #lookupStruct ns "Str" of 47 | NONE => false 48 | | SOME s => Option.isSome (#lookupVal (N.Structures.contents s) "i")) 49 | -------------------------------------------------------------------------------- /test/sml/namespace.sml: -------------------------------------------------------------------------------- 1 | structure N = PolyMLB.NameSpace 2 | structure O = Option 3 | 4 | val == = PolyML.pointerEq 5 | 6 | val ns = N.empty () 7 | val { loc, pub } = N.delegates ns 8 | 9 | val pns : PolyML.NameSpace.nameSpace = case ns of N.N (_, ns) => ns 10 | val ploc : PolyML.NameSpace.nameSpace = case loc of N.N (_, ns) => ns 11 | val ppub : PolyML.NameSpace.nameSpace = case pub of N.N (_, ns) => ns 12 | 13 | val n1 = "app" 14 | val n2 = "map" 15 | val n3 = "rev" 16 | 17 | infix 3 lookup 18 | fun ns lookup s = valOf (#lookupVal ns s) 19 | 20 | val v1 = PolyML.globalNameSpace lookup n1 21 | val v2 = PolyML.globalNameSpace lookup n2 22 | val v3 = PolyML.globalNameSpace lookup n3; 23 | 24 | #enterVal pns (n1, v2); 25 | 26 | "NameSpace enterVal" 27 | assert pns lookup n1 matches (==, v2); 28 | 29 | #enterVal pns (n1, v1); 30 | 31 | "NameSpace enterVal replaces existing" 32 | assert pns lookup n1 matches (==, v1); 33 | 34 | "NameSpace.delegates loc reads from original" 35 | assert ploc lookup n1 matches (==, v1); 36 | 37 | "NameSpace.delegates pub reads from original" 38 | assert ppub lookup n1 matches (==, v1); 39 | 40 | #enterVal ploc (n2, v2); 41 | 42 | "NameSpace.delegates loc write does not propagate to original" 43 | assert #lookupVal pns n2 is not o O.isSome; 44 | 45 | "NameSpace.delegates pub reads from loc" 46 | assert ppub lookup n2 matches (==, v2); 47 | 48 | #enterVal ppub (n3, v3); 49 | 50 | "NameSpace.delegates pub write propagates to original" 51 | assert pns lookup n3 matches (==, v3); 52 | 53 | "NameSpace.delegates pub write propagates to loc through original" 54 | assert ploc lookup n3 matches (==, v3); 55 | 56 | #enterVal ploc (n3, v2); 57 | 58 | "NameSpace.delegates loc reads from itself before original" 59 | assert ploc lookup n3 matches (==, v2); 60 | 61 | "NameSpace.delegates pub reads from itself before loc" 62 | assert ppub lookup n3 matches (==, v3) 63 | -------------------------------------------------------------------------------- /test/sml/queues.sml: -------------------------------------------------------------------------------- 1 | fun for (n, f) = 2 | let 3 | fun for' i = if i = n then () else (f i; for' (i + 1)) 4 | in 5 | for' 0 6 | end 7 | 8 | fun from (n, f) = 9 | let 10 | fun from' i = if i = 0 then () else (f i; from' (i - 1)) 11 | in 12 | from' (n - 1) 13 | end 14 | 15 | val MAX = 1000 16 | 17 | structure Fifo = FifoQueue (type elt = int); 18 | structure Prio = PrioQueue (type elt = int); 19 | 20 | let 21 | val q = Fifo.new () 22 | in 23 | for (MAX, fn i => Fifo.enq (q, i)); 24 | 25 | "Fifo queue keeps all elements in the correct order" 26 | assert 27 | List.tabulate (MAX, fn _ => valOf (Fifo.deq q)) 28 | eq 29 | List.tabulate (MAX, fn i => i); 30 | 31 | "Fifo queue does not retain extra elements" 32 | assert Fifo.deq q eq NONE 33 | end; 34 | 35 | let 36 | val `^ = Word64.xorb 37 | val >> = Word64.>> 38 | 39 | infix 8 `^ >> 40 | 41 | val rand = (ref o Word64.fromLargeInt o Time.toMicroseconds o Time.now) () 42 | 43 | fun sm64 () = 44 | let 45 | val _ = rand := !rand + 0wx9e3779b97f4a7c15 46 | val w = !rand 47 | val w = (w `^ (w >> 0w30)) * 0wxbf58476d1ce4e5b9 48 | val w = (w `^ (w >> 0w27)) * 0wx94d049bb133111eb 49 | in 50 | Word64.toInt ((w `^ (w >> 0w31)) >> 0w2) mod MAX 51 | end 52 | 53 | val elts = Array.tabulate (MAX, fn i => i) 54 | val q = Prio.new () 55 | 56 | val sub = Array.sub 57 | val upd = Array.update 58 | in 59 | from (MAX, fn i => 60 | let 61 | val j = sm64 () 62 | val z = sub (elts, i) 63 | in 64 | upd (elts, i, sub (elts, j)); 65 | upd (elts, j, z) 66 | end); 67 | 68 | for (MAX, fn i => 69 | let 70 | val j = sub (elts, i) 71 | in 72 | Prio.enq (q, (j, j)) 73 | end); 74 | 75 | "Prio queue keeps all elements in the correct order" 76 | assert 77 | List.tabulate (MAX, fn i => valOf (Prio.deq q)) 78 | eq 79 | List.tabulate (MAX, fn i => MAX - i - 1); 80 | 81 | "Prio queue does not retain extra elements" 82 | assert Prio.deq q eq NONE 83 | end 84 | -------------------------------------------------------------------------------- /test/test.sml: -------------------------------------------------------------------------------- 1 | let 2 | (* PolyML.make directly calls the top level print for its 'Making ...' and 3 | * 'Created ...' messages, so we manually redirect it to /dev/null. Simply 4 | * closing TextIO.stdOut or its underlying StreamIO stream causes unhandled 5 | * exceptions when print is called. 6 | *) 7 | open TextIO 8 | val stdout = getOutstream stdOut 9 | val devnull = openOut "/dev/null" 10 | in 11 | (* use / make don't like absolute or ../ relative paths *) 12 | OS.FileSys.chDir ".."; 13 | PolyML.suffixes := ".fun" :: !PolyML.suffixes; 14 | setOutstream (stdOut, getOutstream devnull); 15 | PolyML.make "src/lib/ThreadPools"; 16 | use "src/lib/build.sml"; 17 | closeOut devnull; 18 | setOutstream (stdOut, stdout); 19 | OS.FileSys.chDir "test" 20 | end; 21 | 22 | structure Test :> 23 | sig 24 | type 'a t 25 | val assert : string * 'a -> 'a t 26 | val eq : ''a t * ''a -> unit 27 | val is : 'a t * ('a -> bool) -> unit 28 | val matches : 'a t * (('a * 'a -> bool) * 'a) -> unit 29 | val raises : (unit -> 'a) t * exn -> unit 30 | val raisesMatching : (unit -> 'a) t * (exn -> bool) -> unit 31 | val raisesExact : (unit -> 'a) t * exn -> unit 32 | end = 33 | struct 34 | type 'a t = string * 'a 35 | 36 | fun assert z = z 37 | 38 | fun fail s = 39 | ( TextIO.output (TextIO.stdErr, "Failed: " ^ s ^ "\n") 40 | ; OS.Process.exit OS.Process.failure 41 | ) 42 | 43 | fun eq ((s, a), e) = if a = e then () else fail s 44 | 45 | fun is ((s, a), f) = if f a then () else fail s 46 | 47 | fun matches ((s, a), (f, e)) = if f (e, a) then () else fail s 48 | 49 | fun raises ((s, f), e) = 50 | (f (); fail s) 51 | handle e' => if exnName e = exnName e' then () else fail s 52 | 53 | fun raisesMatching ((s, f), e) = 54 | (f (); fail s) 55 | handle e' => if e e' then () else fail s 56 | 57 | fun raisesExact ((s, f), e) = 58 | (f (); fail s) 59 | handle e' => if exnMessage e = exnMessage e' then () else fail s 60 | end 61 | 62 | infix assert eq is matches raises raisesMatching raisesExact 63 | open Test 64 | -------------------------------------------------------------------------------- /src/lib/Path.sml: -------------------------------------------------------------------------------- 1 | structure Path : 2 | sig 3 | datatype t = Path of string | Unbound of string 4 | 5 | val process : string HashArray.hash -> string -> t 6 | end = 7 | struct 8 | structure S = String 9 | 10 | datatype t = Path of string | Unbound of string 11 | 12 | fun process m s = 13 | let 14 | val var = ref false 15 | val sz = S.size s 16 | 17 | fun find (i, c) = 18 | let 19 | fun f i = 20 | if i = sz then 21 | NONE 22 | else if CharVector.sub (s, i) = c then 23 | SOME i 24 | else 25 | f (i + 1) 26 | in 27 | f i 28 | end 29 | 30 | fun f (i, l) = 31 | if i >= sz then 32 | l 33 | else 34 | case find (i, #"$") of 35 | NONE => S.extract (s, i, NONE) :: l 36 | | SOME j => 37 | if j > sz - 2 then 38 | S.extract (s, i, NONE) :: l 39 | else if CharVector.sub (s, j + 1) <> #"(" then 40 | f (j + 1, "$":: l) 41 | else 42 | case find (j + 2, #")") of 43 | NONE => S.extract (s, i, NONE) :: l 44 | | SOME k => 45 | (case (var := true; S.substring (s, j + 2, k - j - 2)) of 46 | (* todo: what's the correct behavior here? 47 | * mlton checks for an empty var '' but does not allow 48 | * setting it through -mlb-path-{map,var} 49 | *) 50 | (* "" => f (k + 1, "$()"::l) *) 51 | "" => raise Fail "" 52 | | s' => 53 | (case HashArray.sub (m, s') of 54 | NONE => 55 | raise Fail s' 56 | | SOME v => 57 | f (k + 1, v :: S.substring (s, i, j - i) :: l))) 58 | 59 | val s' = (S.concat o List.rev o f) (0, []) 60 | in 61 | if !var then 62 | process m s' 63 | else 64 | Path s' 65 | end 66 | handle Fail v => Unbound v 67 | end 68 | -------------------------------------------------------------------------------- /test/sml/lex.sml: -------------------------------------------------------------------------------- 1 | structure L = PolyMLB.Lex 2 | 3 | datatype z = datatype L.token 4 | 5 | fun pos (a, b, c, d) = 6 | { file = "" 7 | , startLine = a, startPosition = b 8 | , endLine = c, endPosition = d 9 | } 10 | 11 | val lex = map #1 o #1 o L.lex ""; 12 | 13 | "Lex.makePos works correctly" 14 | assert 15 | L.toPolyLoc 16 | ("", L.makePos { startLine = 0, startCol = 12, endLine = 56, endCol = 2 }) 17 | eq 18 | { file = "" 19 | , startLine = 0, startPosition = 12 20 | , endLine = 56, endPosition = 2 21 | }; 22 | 23 | "Lex.joinPos works correctly" 24 | assert 25 | L.toPolyLoc ("", L.joinPos 26 | ( L.makePos { startLine = 8, startCol = 3, endLine = 56, endCol = 2 } 27 | , L.makePos { startLine = 0, startCol = 12, endLine = 32, endCol = 29 } 28 | )) 29 | eq 30 | { file = "" 31 | , startLine = 0, startPosition = 12 32 | , endLine = 56, endPosition = 2 33 | }; 34 | 35 | "Lex.lex recognizes all tokens" 36 | assert 37 | lex "\"x\" y and ann bas basis end = functor in let local open ; signature \ 38 | \structure" 39 | eq 40 | [ String "x", Symbol "y", And, Ann, Bas, Basis, End, Eq, Functor, In, Let 41 | , Local, Open, Semi, Signature, Structure 42 | ]; 43 | 44 | "Lex.lex splits non space separated tokens" 45 | assert 46 | lex "Foo=Bar;local\"baz\"" 47 | eq 48 | [Symbol "Foo", Eq, Symbol "Bar", Semi, Local, String "baz"]; 49 | 50 | fun lex s () = L.lex "" s; 51 | 52 | "Lex.lex raises on unclosed comment" 53 | assert lex "(* (*\n *)" raisesExact L.Lex (L.UnclosedComment, pos (1, 1, 2, 4)); 54 | 55 | app 56 | (fn s => 57 | "Lex.lex raises on invalid reserved word '" ^ s ^ "'" 58 | assert lex s raisesExact L.Lex (L.BadWord s, pos (1, 1, 1, 1 + size s))) 59 | [ "abstype", "andalso", "as", "case", "datatype", "do", "else", "exception" 60 | , "fn", "fun", "handle" , "if", "infix", "infixr", "nonfix", "of", "op" 61 | , "orelse", "raise", "rec", "sig", "struct", "then", "type", "val", "with" 62 | , "withtype", "while" 63 | ]; 64 | 65 | app 66 | (fn c => 67 | "Lex.lex raises on bad char '" ^ str c ^ "'" 68 | assert lex (str c) raisesExact L.Lex (L.BadChar c, pos (1, 1, 1, 2))) 69 | [#"@", #",", #":", #"[", #"{", #"}", #"]", #"\\"]; 70 | 71 | "Lex.lex raises on unclosed before new line string" 72 | assert lex "\"abc\n\"" raisesExact L.Lex (L.UnclosedString, pos (1, 1, 1, 5)); 73 | 74 | "Lex.lex raises on unclosed string" 75 | assert lex "\"abc" raisesExact L.Lex (L.UnclosedString, pos (1, 1, 1, 4)); 76 | -------------------------------------------------------------------------------- /src/lib/build.sml: -------------------------------------------------------------------------------- 1 | let 2 | open OS.FileSys OS.Path PolyML 3 | 4 | val baseDir = 5 | case getUseFileName () of 6 | NONE => raise Fail "Invalid usage; import with use" 7 | | SOME d => dir d 8 | 9 | val (strNames, sigNames, funNames) = 10 | let 11 | fun doDir (d, p, q, strs, sigs, funs) = 12 | case readDir d of 13 | NONE => 14 | (case q of 15 | [] => (strs, sigs, funs) 16 | | p'::q => 17 | let 18 | val (d, p) = (openDir p', p') handle _ => (d, p) 19 | in 20 | doDir (d, p, q, strs, sigs, funs) 21 | end) 22 | | SOME e => doDir 23 | (if (isDir o concat) (p, e) then 24 | (d, p, concat (p, e)::q, e::strs, sigs, funs) 25 | else 26 | case splitBaseExt e of 27 | { base = "PolyMLB", ... } => (d, p, q, strs, sigs, funs) 28 | | { base = "build", ... } => (d, p, q, strs, sigs, funs) 29 | | { base = "ml_bind", ... } => (d, p, q, strs, sigs, funs) 30 | | { base, ext = SOME "sml" } => (d, p, q, base::strs, sigs, funs) 31 | | { base, ext = SOME "sig" } => (d, p, q, strs, base::sigs, funs) 32 | | { base, ext = SOME "fun" } => (d, p, q, strs, sigs, base::funs) 33 | | _ => (d, p, q, strs, sigs, funs)) 34 | in 35 | doDir 36 | ( openDir (if baseDir = "" then "." else baseDir) 37 | , baseDir, [], [], [], [] 38 | ) 39 | end 40 | handle e => raise Fail ("Could not fetch files, got: " ^ exnMessage e) 41 | 42 | fun getOld f = List.mapPartial 43 | (fn s => case f globalNameSpace s of SOME z => SOME (s, z) | NONE => NONE) 44 | 45 | val oldStrs = getOld #lookupStruct strNames 46 | val oldSigs = getOld #lookupSig sigNames 47 | val oldFuns = getOld #lookupFunct funNames 48 | 49 | val oldSuffixes = !suffixes 50 | 51 | val err : exn option ref = ref NONE 52 | in 53 | (* "" is necessary to match directories *) 54 | suffixes := ["", ".sml", ".sig", ".fun"]; 55 | (make o concat) (baseDir, "PolyMLB") handle e => err := SOME e; 56 | (* forget top level declarations *) 57 | app (fn (f, l) => app f l) 58 | [ (Compiler.forgetStructure, strNames) 59 | , (Compiler.forgetSignature, sigNames) 60 | , (Compiler.forgetFunctor, funNames) 61 | ]; 62 | (* restore old env *) 63 | app (#enterStruct globalNameSpace) oldStrs; 64 | app (#enterSig globalNameSpace) oldSigs; 65 | app (#enterFunct globalNameSpace) oldFuns; 66 | suffixes := oldSuffixes; 67 | case !err of SOME e => Exception.reraise e | _ => () 68 | end 69 | -------------------------------------------------------------------------------- /src/lib/Ann.sml: -------------------------------------------------------------------------------- 1 | structure Ann : 2 | sig 3 | datatype t = 4 | (* Whether debug info should be included in the compiled code *) 5 | Debug of bool 6 | (* Completely ignore all enclosed declarations *) 7 | | Discard 8 | (* Ignore files with a matching base name *) 9 | | IgnoreFiles of string list 10 | (* Open the global namespace; only recognised if prefixed with `poly:` *) 11 | | ImportAll 12 | 13 | datatype res = 14 | Ann of t 15 | | BadArg of string 16 | | MissingArg 17 | | UnexpectedArg 18 | | Unrecognized 19 | 20 | (* will match regardless of the value *) 21 | val exists : t -> t list -> bool 22 | 23 | val parse : string -> res 24 | 25 | val parseName : string -> t option 26 | end = 27 | struct 28 | structure O = Option 29 | structure S = String 30 | structure SS = Substring 31 | 32 | datatype t = 33 | Debug of bool 34 | | Discard 35 | | IgnoreFiles of string list 36 | | ImportAll 37 | 38 | datatype res = 39 | Ann of t 40 | | BadArg of string 41 | | MissingArg 42 | | UnexpectedArg 43 | | Unrecognized 44 | 45 | fun chk (Debug _) (Debug _) = true 46 | | chk Discard Discard = true 47 | | chk (IgnoreFiles _) (IgnoreFiles _) = true 48 | | chk ImportAll ImportAll = true 49 | | chk _ _ = false 50 | 51 | fun exists a = List.exists (chk a) 52 | 53 | val trimWS = SS.dropr Char.isSpace o SS.dropl Char.isSpace 54 | 55 | fun prefix s = 56 | let 57 | val (p, a) = SS.splitl (fn c => c <> #":") s 58 | in 59 | if SS.size p = SS.size s then 60 | ("", SS.string s) 61 | else 62 | (SS.string p, (SS.string o SS.triml 1) a) 63 | end 64 | 65 | fun arg v = 66 | let 67 | val v = SS.string (trimWS v) 68 | in 69 | if size v = 0 then NONE else SOME v 70 | end 71 | 72 | fun parse s = 73 | let 74 | val (a, v) = 75 | SS.splitl (not o Char.isSpace) ((trimWS o SS.full) s) 76 | val (p, a) = prefix a 77 | val v = arg v 78 | in 79 | if size p > 0 andalso p <> "poly" then 80 | Unrecognized 81 | else if (p, a, v) = ("poly", "importAll", NONE) then 82 | Ann ImportAll 83 | else 84 | case (a, v) of 85 | ("debug", NONE) => Ann (Debug true) 86 | | ("debug", SOME v) => 87 | (case Bool.fromString v of SOME b => Ann (Debug b) | _ => BadArg v) 88 | | ("discard", NONE) => Ann Discard 89 | | ("discard", _) => UnexpectedArg 90 | | ("ignoreFiles", v) => 91 | (case O.map (S.tokens (fn c => c = #",")) v of 92 | SOME [] => MissingArg 93 | | SOME l => Ann (IgnoreFiles l) 94 | | _ => MissingArg) 95 | | _ => Unrecognized 96 | end 97 | 98 | fun parseName s = 99 | case s of 100 | "debug" => SOME (Debug true) 101 | | "discard" => SOME Discard 102 | | "ignoreFiles" => SOME (IgnoreFiles []) 103 | | _ => NONE 104 | end 105 | -------------------------------------------------------------------------------- /test/sml/dag.sml: -------------------------------------------------------------------------------- 1 | structure A = PolyMLB.Ann 2 | structure D = PolyMLB.Dag 3 | 4 | datatype z = datatype PolyMLB.Basis.dec 5 | datatype z = datatype PolyMLB.Basis.exp 6 | 7 | val process = D.process { logger = NONE, reduce = true } 8 | 9 | local 10 | val b1 = [BasisFile "b2", BasisFile "b3"] 11 | val b2 = [BasisFile "b3"] 12 | val b3 = [BasisFile "b4"] 13 | val b4 = [BasisFile "b1"] 14 | 15 | fun b "b1" = b1 16 | | b "b2" = b2 17 | | b "b3" = b3 18 | | b "b4" = b4 19 | | b _ = raise Fail "" 20 | in 21 | val _ = 22 | "Dag.process raises on cycle and returns ordered cycle" 23 | assert 24 | (fn () => process b "b1") 25 | raisesExact 26 | D.Dag (D.Cycle ["b1", "b2", "b3", "b4"]) 27 | end 28 | 29 | local 30 | structure A = Array 31 | val a = A.tabulate (4, fn _ => 0) 32 | fun ++ i = A.update (a, i, A.sub (a, i) + 1) 33 | 34 | val b1 = [BasisFile "b2", BasisFile "b3", BasisFile "b4"] 35 | val b2 = [BasisFile "b3", BasisFile "b4"] 36 | val b3 = [BasisFile "b4"] 37 | val b4 = [] 38 | 39 | fun b "b1" = (++0; b1) 40 | | b "b2" = (++1; b2) 41 | | b "b3" = (++2; b3) 42 | | b "b4" = (++3; b4) 43 | | b _ = raise Fail "" 44 | in 45 | val _ = 46 | "Dag.process calls the MLB callback exactly once per MLB" 47 | assert 48 | process b "b1" 49 | is 50 | (fn _ => A.foldl (fn (r, b) => b andalso r = 1) true a) 51 | end 52 | 53 | local 54 | val b = ref true 55 | in 56 | val _ = 57 | "Dag.process respects Discard annotations" 58 | assert 59 | process 60 | (fn "b" => [Ann ([A.Discard], [BasisFile "foo"])] 61 | | _ => (b := false; [])) 62 | "b" 63 | is 64 | (fn _ => !b) 65 | end 66 | 67 | local 68 | val b = ref true 69 | in 70 | val _ = 71 | "Dag.process respects IgnoreFiles annotations" 72 | assert 73 | process 74 | (fn "b" => [Ann ([A.IgnoreFiles ["foo"]], [BasisFile "foo"])] 75 | | _ => (b := false; [])) 76 | "b" 77 | is 78 | (fn _ => !b) 79 | end 80 | 81 | local 82 | (* input: 83 | digraph G { 84 | b1 -> b2; 85 | b1 -> b3; 86 | b2 -> b3; 87 | b2 -> b5; 88 | b2 -> b4; 89 | b4 -> b5; 90 | } 91 | *) 92 | val b1 = [BasisFile "b2", BasisFile "b3"] 93 | val b2 = [BasisFile "b3", BasisFile "b4", BasisFile "b5"] 94 | val b3 = [] 95 | val b4 = [BasisFile "b5"] 96 | val b5 = [] 97 | 98 | fun b "b1" = b1 99 | | b "b2" = b2 100 | | b "b3" = b3 101 | | b "b4" = b4 102 | | b "b5" = b5 103 | | b _ = raise Fail "" 104 | 105 | (* reduced output: 106 | digraph G { 107 | b1 -> b2; 108 | b2 -> b3; 109 | b2 -> b4; 110 | b4 -> b5; 111 | } 112 | *) 113 | 114 | val fl = Vector.fromList 115 | in 116 | val _ = 117 | "Dag.process reduces input graph" 118 | assert 119 | (#root o #dag o process b) "b1" 120 | eq 121 | D.N (0, fl 122 | [ D.N (1, fl 123 | [ D.N (2, fl []) 124 | , D.N (3, fl [D.N (4, fl [])]) 125 | ]) 126 | ]) 127 | end 128 | -------------------------------------------------------------------------------- /src/lib/ThreadPools/ThreadPool.fun: -------------------------------------------------------------------------------- 1 | (* Simple bounded threadpool implementation with centralized task queue. 2 | * If, when submitting a new task, the thread count is less than the max, then 3 | * fork immediately; otherwise, add to the queue. Upon task completion, threads 4 | * pop the queue and go again, until the queue is empty. 5 | * If a task fails (i.e raises an exception), threads are sent an interrupt and 6 | * will not process further tasks. 7 | *) 8 | functor ThreadPool (Q : 9 | sig 10 | include QUEUE where type outc = unit -> unit 11 | val conv : inc -> outc 12 | end) :> 13 | sig 14 | type t 15 | val new : int -> t 16 | val submit : t * Q.inc -> unit 17 | (* Blocks until all threads have terminated; either because the task queue 18 | * is empty or a task has failed, in which case the corresponding exn is 19 | * returned. 20 | *) 21 | val wait : t -> exn option 22 | end = 23 | struct 24 | structure A = Array 25 | structure C = Thread.ConditionVar 26 | structure M = Thread.Mutex 27 | structure T = Thread.Thread 28 | 29 | fun index a = 30 | let 31 | val i = ref 0 32 | in 33 | while !i < A.length a andalso (Option.isSome o A.sub) (a, !i) do 34 | i := !i + 1; 35 | !i 36 | end 37 | 38 | type t = 39 | { max : int 40 | , cur : int ref 41 | , threads : T.thread option array 42 | , q : Q.t 43 | , m : M.mutex 44 | , exit : C.conditionVar 45 | , err : exn option ref 46 | } 47 | 48 | fun new i = 49 | { max = i 50 | , cur = ref 0 51 | , threads = A.tabulate (i, fn _ => NONE) 52 | , q = Q.new () 53 | , m = M.mutex () 54 | , exit = C.conditionVar () 55 | , err = ref NONE 56 | } 57 | 58 | fun run (i, f, { cur, threads, m, q, exit, err, ... } : t) = 59 | let 60 | val ok = ref true 61 | fun call f = 62 | (T.testInterrupt (); f ()) 63 | handle 64 | T.Interrupt => ok := false 65 | | e => 66 | ( ok := false 67 | ; M.lock m 68 | ; if (not o Option.isSome o !) err then 69 | ( err := SOME e 70 | ; M.unlock m 71 | ; A.app (fn SOME t => T.interrupt t | _ => ()) threads 72 | ) 73 | else 74 | M.unlock m 75 | ) 76 | in 77 | call f; 78 | while !ok do 79 | case Q.deq q of 80 | SOME f => call f 81 | | NONE => ok := false; 82 | M.lock m; 83 | A.update (threads, i, NONE); 84 | cur := !cur - 1; 85 | M.unlock m; 86 | C.signal exit 87 | end 88 | 89 | fun submit (t as { max, cur, threads, q, m, err, ... } : t, f) = 90 | if (M.lock m; Option.isSome (!err)) then 91 | M.unlock m 92 | else if !cur = max then 93 | (M.unlock m; Q.enq (q, f)) 94 | else 95 | let 96 | val i = index threads 97 | in 98 | cur := !cur + 1; 99 | A.update 100 | (threads, i, (SOME o T.fork) (fn () => run (i, Q.conv f, t), [])); 101 | M.unlock m 102 | end 103 | 104 | fun wait ({ cur, m, exit, err, ... } : t) = 105 | ( M.lock m 106 | ; while !cur > 0 do 107 | C.wait (exit, m) 108 | ; M.unlock m 109 | ; !err before err := NONE 110 | ) 111 | end 112 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | PolyMLB 2 | ======= 3 | 4 | PolyMLB is a complete implementation of the ML Basis system for Poly/ML. 5 | Although primarily implemented as a library, it also offers an executable 6 | wrapper (polymlb) for regular usage. 7 | 8 | 9 | ## Building and installing 10 | 11 | Building requires Poly/ML and its accompanying script polyc. 12 | 13 | $ make all 14 | 15 | Installing polymlb as well as the Standard ML library files: 16 | 17 | $ make install 18 | 19 | Note that the default location for Standard ML libraries is set when building; 20 | its value is that of `SML_LIB`, which defaults to `$(LIBDIR)/polymlb`. 21 | 22 | 23 | ## Usage 24 | 25 | This only covers simple polymlb usage. More detailed information is available 26 | in the `polymlb(1)` man page. For the library, see LIBRARY. 27 | 28 | The following compiles and links `t.mlb`, producing an executable `t`: 29 | 30 | $ polymlb t.mlb 31 | 32 | polymlb operates on MLB files only and exits if the given file does not have 33 | the `.mlb` extension. The given MLB file is compiled and exported to an object 34 | file, which is then linked to the polyml library by invoking polyc. Although 35 | the default behavior is to export a function called `main`, a different name 36 | may be provided and will be used as root and entry point if it is of the correct 37 | type (`unit -> unit`). 38 | 39 | polymlb options include: 40 | 41 | - `-ignore-call-main`: ignore files called `call-main.sml`; 42 | - `-ignore-main`: ignore files called `main.sml`; 43 | - `-jobs `: maximum number of jobs; 44 | - `-main `: root function to export; 45 | - `-mlb-path-map `: additional MLB path map; 46 | - `-mlb-path-var ' '`: additional MLB path var; 47 | - `-o`, `-output`: name of the output file; 48 | - `-polyc `: polyc executable; 49 | - `-sml-lib`: print the resolved value of `SML_LIB`. 50 | 51 | 52 | ## ML Basis 53 | 54 | If the libraries were correctly installed, then the following are available: 55 | 56 | - `$(SML_LIB)/basis/basis.mlb`: the Standard ML Basis library as implemented by 57 | Poly/ML; 58 | - `$(SML_LIB)/basis/poly.mlb`: the Poly/ML library extensions, such as the 59 | `PolyML` or the `Thread` structures; 60 | - `$(SML_LIB)/polymlb/polymlb.mlb`: the PolyMLB library. 61 | 62 | PolyMLB implements several annotations: 63 | 64 | - `debug {true|false}`: whether debugging information should be included in the 65 | compiled code; 66 | - `discard`: enclosed declarations are completely ignored; 67 | - `ignoreFiles file1,file2,...`: files with a matching basename are ignored. 68 | 69 | An optional `poly:` prefix is recognized; others (e.g `mlton:`) will cause the 70 | annotation to be ignored. 71 | 72 | Do note that annotations do not affect imported MLB files; i.e the following 73 | does not work: 74 | 75 | $ cat a.mlb 76 | main.sml 77 | $ cat b.mlb 78 | ann 79 | "ignoreFiles main.sml" 80 | in 81 | a.mlb 82 | end 83 | 84 | As for path variables, only `SML_LIB` is initially defined. 85 | 86 | 87 | ## License 88 | 89 | BSD 2-clause 90 | 91 | 92 | ## References 93 | 94 | Poly/ML: 95 | 96 | - https://polyml.org 97 | - https://polyml.org/documentation/Reference/Basis.html 98 | - https://github.com/polyml/polyml 99 | 100 | ML Basis: 101 | 102 | - http://mlton.org/MLBasis 103 | - http://mlton.org/MLBasis.attachments/mlb-formal.pdf 104 | 105 | Standard ML Basis Library: 106 | 107 | - https://smlfamily.github.io/Basis/ 108 | -------------------------------------------------------------------------------- /test/sml/parse.sml: -------------------------------------------------------------------------------- 1 | structure L = PolyMLB.Lex 2 | structure P = PolyMLB.Parse 3 | structure E = P.Element 4 | 5 | datatype z = datatype P.dec_kind 6 | datatype z = datatype P.exp_kind 7 | 8 | fun mapi f l = 9 | let 10 | fun mapi' (i, []) = [] 11 | | mapi' (i, x::xs) = f (x, i) :: mapi' (i + 1, xs) 12 | in 13 | mapi' (1, l) 14 | end 15 | 16 | fun pos i = 17 | L.makePos { startLine = i, startCol = i, endLine = i, endCol = i } 18 | 19 | fun t (tk, i) = (tk, pos i) 20 | 21 | fun p (z : 'a, i, j) : 'a * PolyML.location = 22 | ( z 23 | , { file = "", startLine = i, startPosition = i, endLine = j, endPosition = j } 24 | ) 25 | 26 | fun p' (z, i) = p (z, i, i) 27 | 28 | fun ` l = map p l 29 | fun `` l = map p' l; 30 | 31 | app 32 | (fn (n, l, r) => 33 | "Parse.parse parses " ^ n ^ " declarations correctly" 34 | assert P.parse "" (mapi t l, { start = pos 0, eof = pos (length l) }) eq r) 35 | [ ( "annotation" 36 | , [L.Ann, L.String "foo", L.String "bar", L.In, L.End] 37 | , `[(Ann (["foo", "bar"], []), 1, 5)] 38 | ) 39 | , ( "single basis" 40 | , [L.Basis, L.Symbol "foo", L.Eq, L.Symbol "bar"] 41 | , `[(Basis [("foo", p' (Id "bar", 4))], 1, 4)] 42 | ) 43 | , ( "and basis" 44 | , [ L.Basis, L.Symbol "foo", L.Eq, L.Symbol "bar", L.And, L.Symbol "baz" 45 | , L.Eq, L.Symbol "qux" 46 | ] 47 | , `[(Basis [("foo", p' (Id "bar", 4)), ("baz", p' (Id "qux", 8))], 1, 8)] 48 | ) 49 | , ( "file" 50 | , [L.Symbol "foo.sml", L.String "foo bar.sml"] 51 | , ``[(File "foo.sml", 1), (File "foo bar.sml", 2)] 52 | ) 53 | , ( "empty local/in" 54 | , [L.Local, L.In, L.End] 55 | , `[(Local ([], []), 1, 3)] 56 | ) 57 | , ( "local/in" 58 | , [L.Local, L.Symbol "foo", L.Symbol "bar", L.In, L.Symbol "baz", L.End] 59 | , `[(Local (``[(File "foo", 2), (File "bar", 3)], ``[(File "baz", 5)]), 1, 6)] 60 | ) 61 | , ( "open" 62 | , [L.Open, L.Symbol "foo", L.Symbol "bar"] 63 | , `[(Open ["foo", "bar"], 1, 3)] 64 | ) 65 | , ( "functor, signature and structure bindings" 66 | , [ L.Functor, L.Symbol "f1", L.Signature, L.Symbol "s1", L.Eq, L.Symbol "s2" 67 | , L.Structure, L.Symbol "s1", L.And, L.Symbol "s2", L.Eq, L.Symbol "s3" 68 | ] 69 | , `[ (Functor [("f1", "f1")], 1, 2), (Signature [("s1", "s2")], 3, 6) 70 | , (Structure [("s1", "s1"), ("s2", "s3")], 7, 12) 71 | ] 72 | ) 73 | , ( "semi colon separated" 74 | , [ L.Semi, L.Semi, L.Open, L.Symbol "foo", L.Symbol "bar", L.Semi 75 | , L.Symbol "baz", L.Semi, L.Semi 76 | ] 77 | , `[(Open ["foo", "bar"], 3, 5), (File "baz", 7, 7)] 78 | ) 79 | ]; 80 | 81 | app 82 | (fn (n, l, r) => 83 | "Parse.parse parses " ^ n ^ " expressions correctly" 84 | assert 85 | P.parse "" 86 | ( mapi t ([L.Basis, L.Symbol "b", L.Eq] @ l) 87 | , { start = pos 0, eof = pos (length l) } 88 | ) 89 | eq 90 | `[(Basis [("b", r)], 1, 3 + length l)]) 91 | [ ( "empty bas" 92 | , [L.Bas, L.End] 93 | , p (Bas [], 4, 5) 94 | ) 95 | , ( "bas" 96 | , [L.Bas, L.Symbol "foo", L.Symbol "bar", L.End] 97 | , p (Bas (``[(File "foo", 5), (File "bar", 6)]), 4, 7) 98 | ) 99 | , ( "id" 100 | , [L.Symbol "foo"] 101 | , p' (Id "foo", 4) 102 | ) 103 | , ( "empty let/in" 104 | , [L.Let, L.In, L.Symbol "foo", L.End] 105 | , p (Let ([], p' (Id "foo", 6)), 4, 7) 106 | ) 107 | , ( "let/in" 108 | , [L.Let, L.Symbol "foo", L.Symbol "bar", L.In, L.Symbol "baz", L.End] 109 | , p (Let (``[(File "foo", 5), (File "bar", 6)], p' (Id "baz", 8)), 4, 9) 110 | ) 111 | ] 112 | -------------------------------------------------------------------------------- /test/sml/basis.sml: -------------------------------------------------------------------------------- 1 | structure A = PolyMLB.Ann 2 | structure B = PolyMLB.Basis 3 | structure H = HashArray 4 | structure P = PolyMLB.Parse 5 | 6 | val pmap : string H.hash = H.hash 1 7 | 8 | val loc = 9 | { file = "" 10 | , startLine = 0, startPosition = 0 11 | , endLine = 0, endPosition = 0 12 | } 13 | 14 | fun fromParse p () = B.fromParse 15 | { disabledAnns = [], pathMap = pmap, path = "/", exts = NONE, logger = NONE } 16 | p; 17 | 18 | "Basis.fromParse raises on duplicate bind" 19 | assert 20 | fromParse [(P.Structure [("foo", "bar"), ("foo", "baz")], loc)] 21 | raisesExact 22 | B.Validation (B.DuplicateBind, "foo", loc); 23 | 24 | "Basis.fromParse raises on invalid file extension" 25 | assert 26 | fromParse [(P.File "foo.bar", loc)] 27 | raisesExact 28 | B.Validation (B.Extension, "foo.bar", loc); 29 | 30 | "Basis.fromParse raises on missing file extension" 31 | assert 32 | fromParse [(P.File "foo", loc)] 33 | raisesExact 34 | B.Validation (B.Extension, "foo", loc); 35 | 36 | "Basis.fromParse raises on unbound path variable" 37 | assert 38 | fromParse [(P.File "$(FOO).sml", loc)] 39 | raisesExact 40 | B.Validation (B.UnboundVariable, "FOO", loc); 41 | 42 | fun fromParse p = B.fromParse 43 | { disabledAnns = [], pathMap = pmap, path = "/", exts = NONE, logger = NONE } 44 | p; 45 | 46 | "Basis.fromParse valid" 47 | assert 48 | fromParse 49 | [ (P.Local 50 | ( [(P.Basis [("b1", (P.Id "b2", loc))], loc)] 51 | , [(P.File "foo.sml", loc), (P.Functor [("f1", "f2")], loc)] 52 | ), loc) 53 | , (P.File "bar.mlb", loc) 54 | ] 55 | eq 56 | [ B.Local 57 | ( [B.Basis ("b1", B.Id "b2")] 58 | , [B.SourceFile "/foo.sml", B.Functor ("f1", "f2")] 59 | ) 60 | , B.BasisFile "/bar.mlb" 61 | ]; 62 | 63 | "Basis.fromParse removes unknown annotations" 64 | assert 65 | fromParse [(P.Ann (["foo", "debug true", "bar:baz"], []), loc)] 66 | eq 67 | [B.Ann ([A.Debug true], [])]; 68 | 69 | "Basis.fromParse removes Discard annotated declarations" 70 | assert 71 | fromParse [(P.Ann (["discard"], [(P.File "foo.sml", loc)]), loc)] 72 | eq 73 | []; 74 | 75 | "Basis.fromParse inlines public declarations in case of empty local" 76 | assert 77 | fromParse 78 | [ (P.Local ([], [(P.File "foo.sml", loc), (P.File "bar.sml", loc)]), loc) 79 | , (P.File "baz.sml", loc) 80 | ] 81 | eq 82 | [B.SourceFile "/foo.sml", B.SourceFile "/bar.sml", B.SourceFile "/baz.sml"]; 83 | 84 | "Basis.fromParse removes empty local/in" 85 | assert 86 | fromParse 87 | [(P.File "foo.sml", loc), (P.Local ([], []), loc), (P.File "bar.sml", loc)] 88 | eq 89 | [B.SourceFile "/foo.sml", B.SourceFile "/bar.sml"]; 90 | 91 | "Basis.fromParse inlines expression part in case of empty let" 92 | assert 93 | fromParse 94 | [ (P.Basis [("b", (P.Let ([], (P.Id "foo", loc)), loc))], loc) 95 | , (P.File "bar.sml", loc) 96 | ] 97 | eq 98 | [B.Basis ("b", B.Id "foo"), B.SourceFile "/bar.sml"]; 99 | 100 | "Basis.fromParse removes files matching an enclosing IgnoreFiles" 101 | assert 102 | fromParse 103 | [(P.Ann 104 | ( ["ignoreFiles foo.sml"] 105 | , [(P.File "foo.sml", loc), (P.File "dir/foo.sml", loc)] 106 | ), loc)] 107 | eq 108 | [B.Ann ([A.IgnoreFiles ["foo.sml"]], [])]; 109 | 110 | "Basis.fromParse splits Open declarations" 111 | assert 112 | fromParse [(P.Open ["s1", "s2"], loc)] 113 | eq 114 | [B.Open "s1", B.Open "s2"]; 115 | 116 | "Basis.fromParse splits and bindings" 117 | assert 118 | fromParse [(P.Structure [("s1", "s1"), ("s2", "s2")], loc)] 119 | eq 120 | [B.Structure ("s1", "s1"), B.Structure ("s2", "s2")]; 121 | 122 | fun fromParse l p = B.fromParse 123 | { disabledAnns = l, pathMap = pmap, path = "/", exts = NONE, logger = NONE } 124 | p; 125 | 126 | "Basis.fromParse removes disabled annotations" 127 | assert 128 | fromParse [A.Debug true] [(P.Ann (["debug true"], []), loc)] 129 | eq 130 | [] 131 | -------------------------------------------------------------------------------- /src/lib/PolyMLB.sml: -------------------------------------------------------------------------------- 1 | structure PolyMLB : 2 | sig 3 | datatype opt = 4 | AnnDefaults of Ann.t list 5 | | Concurrency of { depsFirst : bool, jobs : int } 6 | (* dummy values can be used; the anns will be completely disabled *) 7 | | DisabledAnns of Ann.t list 8 | | Logger of Log.logger 9 | (* in addition to the default path map *) 10 | | PathMap of string HashArray.hash 11 | | Preprocess of { bas : Basis.t, path : string, root : bool } -> Basis.t 12 | 13 | type opts = opt list 14 | 15 | (* Default path map *) 16 | val pathMap : string HashArray.hash 17 | 18 | (* Compile the given basis and return the resulting namespace. 19 | * May raise one of the following: 20 | * - Lex.Lex; 21 | * - Parse.Parse; 22 | * - Basis.Validation; 23 | * - Dag.Dag; 24 | * - Compile.Compile; 25 | * - IO.Io. 26 | *) 27 | val compile : opts -> string -> NameSpace.t 28 | 29 | (* Compile and import the content of the basis in the global namespace. 30 | * See `compile` for errors. 31 | *) 32 | val import : opts -> string -> unit 33 | 34 | (* Compile and import an mlb file, much like the top level `use`. *) 35 | val use : string -> unit 36 | end = 37 | struct 38 | structure H = HashArray 39 | structure OSF = OS.FileSys 40 | structure OSP = OS.Path 41 | 42 | datatype opt = 43 | AnnDefaults of Ann.t list 44 | | Concurrency of { depsFirst : bool, jobs : int } 45 | | DisabledAnns of Ann.t list 46 | | Logger of Log.logger 47 | | PathMap of string HashArray.hash 48 | | Preprocess of { bas : Basis.t, path : string, root : bool } -> Basis.t 49 | 50 | type opts = opt list 51 | 52 | (* http://mlton.org/MLBasisPathMap 53 | * https://github.com/MLton/mlton/blob/master/mlton/control/control-flags.sml#L1636 54 | * - int, word and real can be deduced from precision / wordSize / radix 55 | * - target_arch from PolyML.architecture () 56 | * - target_os from ? 57 | * there is LibrarySupport.getOSType but it is not available 58 | * val getOSCall: unit -> int = RunCall.rtsCallFast0 "PolyGetOSType" 59 | * val getOS: int = getOSCall() -> 0 for Posix, 1 -> Windows 60 | *) 61 | val pathMap : string H.hash = H.hash 10 62 | 63 | fun readFile p = 64 | let 65 | val s = TextIO.openIn p 66 | in 67 | TextIO.inputAll s before TextIO.closeIn s 68 | end 69 | 70 | local 71 | fun find f l v = 72 | let 73 | fun fd [] = NONE 74 | | fd (x::xs) = case f x of NONE => fd xs | z => z 75 | in 76 | Option.getOpt (fd l, v) 77 | end 78 | 79 | fun pp { bas : Basis.t, path = _ : string, root = _ : bool } = bas 80 | in 81 | fun doOpts opts = 82 | let 83 | fun fd f v = find f opts v 84 | in 85 | { anns = fd (fn AnnDefaults l => SOME l | _ => NONE) [] 86 | , conc = fd (fn Concurrency z => SOME z | _ => NONE) 87 | { depsFirst = false, jobs = 1 } 88 | , dAnns = fd (fn DisabledAnns l => SOME l | _ => NONE) [] 89 | , logger = fd (fn Logger l => SOME (SOME l) | _ => NONE) NONE 90 | , pathMap = fd (fn PathMap m => SOME m | _ => NONE) (H.hash 1) 91 | , preproc = fd (fn Preprocess f => SOME f | _ => NONE) pp 92 | } 93 | end 94 | end 95 | 96 | fun doBasis f opts src = 97 | let 98 | val opts as { conc, logger, ... } = doOpts opts 99 | val copts = 100 | { depsFirst = #depsFirst conc, jobs = #jobs conc, logger = logger } 101 | 102 | val src = OSF.fullPath src 103 | handle e => 104 | ( case logger of 105 | SOME { print, ... } => print (Log.Error, fn () => exnMessage e) 106 | | _ => () 107 | ; PolyML.Exception.reraise e 108 | ) 109 | 110 | val pathMap = 111 | let 112 | val h : string H.hash = H.hash 10 113 | in 114 | H.fold (fn (k, v, _) => H.update (h, k, v)) () pathMap; 115 | H.fold (fn (k, v, _) => H.update (h, k, v)) () (#pathMap opts); 116 | h 117 | end 118 | 119 | fun convOpts p = 120 | { disabledAnns = #dAnns opts 121 | , exts = NONE 122 | , logger = logger 123 | , pathMap = pathMap 124 | , path = OSP.dir p 125 | } 126 | 127 | fun mkBas p = 128 | ( (fn b => 129 | if p = src then 130 | #preproc opts { bas = b, path = p, root = true } 131 | else 132 | #preproc opts { bas = b, path = p, root = false }) 133 | o Basis.fromParse (convOpts p) 134 | o Parse.parse p 135 | o Lex.lex p 136 | o readFile 137 | ) p 138 | in 139 | ( f copts 140 | o Dag.process { logger = logger, reduce = true } mkBas 141 | ) src 142 | handle e => 143 | ( Log.log logger Log.Error 144 | (fn fmt => 145 | case e of 146 | Lex.Lex z => Lex.errToString fmt z 147 | | Parse.Parse z => Parse.errToString fmt z 148 | | Basis.Validation z => Basis.errToString fmt z 149 | | Dag.Dag z => Dag.errToString fmt z 150 | | Compile.Compile z => Compile.errToString fmt z 151 | | _ => exnMessage e) 152 | ; PolyML.Exception.reraise e 153 | ) 154 | end 155 | 156 | fun compile opts = doBasis Compile.compile opts 157 | 158 | fun import opts src = 159 | NameSpace.import { src = compile opts src, dst = NameSpace.global } 160 | 161 | local 162 | fun fmt p = OSP.mkRelative { path = p, relativeTo = (OSF.getDir ()) } 163 | fun log (Log.Warn, m) = print ("warning: " ^ m () ^ "\n") 164 | | log (Log.Error, m) = print ("error: " ^ m () ^ "\n") 165 | | log _ = () 166 | in 167 | fun use s = 168 | NameSpace.import 169 | { src = compile [Logger { pathFmt = fmt, print = log }] s 170 | , dst = NameSpace.global 171 | } 172 | handle _ => raise Fail "Static errors" 173 | end 174 | end 175 | 176 | 177 | structure PolyMLB = 178 | struct 179 | structure Ann = Ann 180 | structure Basis = Basis 181 | structure Compile = Compile 182 | structure Dag = Dag 183 | structure Lex = Lex 184 | structure Log = Log 185 | structure NameSpace = NameSpace 186 | structure Parse = Parse 187 | structure Path = Path 188 | open PolyMLB 189 | end 190 | -------------------------------------------------------------------------------- /polymlb.1: -------------------------------------------------------------------------------- 1 | .Dd September 24, 2025 2 | .Dt POLYMLB 1 3 | .Os 4 | .Sh NAME 5 | .Nm polymlb 6 | .Nd ML Basis implementation for Poly/ML 7 | .Sh SYNOPSYS 8 | .Nm polymlb 9 | .Op OPTIONS 10 | .Op -- 11 | .Ar FILE 12 | .Sh DESCRIPTION 13 | .Nm 14 | is a complete implementation of the ML Basis system for Poly/ML. 15 | The argument 16 | .Ar FILE 17 | is an ML Basis file which is compiled and exported using the PolyML.export 18 | function, then linked with the Poly/ML library by invoking 19 | .Xr polyc 1 20 | on the resulting object file. The root function to export is expected to 21 | be a top level value that matches the following spec: 22 | .Bd -literal -compact 23 | val main : unit -> unit 24 | .Ed 25 | .Sh OPTIONS 26 | .Bl -tag -width Ds 27 | .It Fl ann Ar ann 28 | Wrap 29 | .Ar FILE 30 | with the given annotation, in addition to those from 31 | .Fl default-ann . 32 | Use multiple times for multiple annotations. See 33 | .Sx ANNOTATIONS . 34 | .It Fl c, Fl compile 35 | Compile but do not link. 36 | .It Fl default-ann Ar ann 37 | Set default value for the given annotation; i.e wrap all MLB files with 38 | .Ar ann . 39 | See 40 | .Sx ANNOTATIONS . 41 | .It Fl deps-first 42 | Compile MLB files only after their dependencies. See 43 | .Sx ELABORATION . 44 | .It Fl disable-ann Ar ann 45 | Globally disable 46 | .Ar ann . 47 | .It Fl h, Fl help 48 | Print help usage and exit. 49 | .It Fl info 50 | Print useful information, such as the default value of 51 | .Pa SML_LIB 52 | and the version of the Poly/ML compiler, and exit. 53 | .It Fl ignore-call-main 54 | Ignore files with a base name of 55 | .Pa call-main.sml . 56 | This is equivalent to 57 | .Fl ann 58 | \&'ignoreFiles call-main.sml\'. 59 | .It Fl ignore-main 60 | Ignore files with a base name of 61 | .Pa main.sml . 62 | This is equivalent to 63 | .Fl ann 64 | \&'ignoreFiles main.sml\'. 65 | .It Fl jobs Ar n 66 | Set the maximum number of jobs, with 0 meaning unbounded. See 67 | .Sx ELABORATION . 68 | .It Fl mlb-path-map Ar file 69 | Source additional MLB path variables from 70 | .Ar file . 71 | Each line consists of two whitespace separated tokens, with the first one 72 | being the variable name and the second its value. Multiple uses are allowed, 73 | with later definitions taking precedence over earlier ones. See 74 | .Sx VARIABLES . 75 | .It Fl mlb-path-var Ar 'name\ value' 76 | Define an additional MLB path variable, replacing any existing variable 77 | with the same name. Multiple uses are allowed, with later definitions 78 | taking precedence over earlier ones. See 79 | .Sx VARIABLES . 80 | .It Fl main Ar name 81 | The fully qualified name of the root function to be passed to PolyML.export. 82 | It must be of type 83 | .Vt unit\ ->\ unit . 84 | .It Fl o, Fl output Ar file 85 | Specify the output file. If only exporting to an object file, then 86 | .Ar file 87 | will be appended an ".o" extension if it does not have one. 88 | .It Fl polyc Ar polyc 89 | Link using 90 | .Ar polyc 91 | instead of "polyc". 92 | .It Fl q, Fl quiet 93 | Silence warnings. This is equivalent to 94 | .Fl verbose 95 | 1. 96 | .It Fl Q, Fl reallyquiet 97 | Silence errors. This is equivalent to 98 | .Fl verbose 99 | 0. 100 | .It Fl sml-lib 101 | Print the resolved value of 102 | .Pa SML_LIB 103 | and exit. This takes into account all additional variables defined through 104 | .Fl mlb-path-map 105 | and 106 | .Fl mlb-path-var . 107 | If an unbound variable identifier prevents resolving the value of 108 | .Pa SML_LIB , 109 | it will be printed on stderr. 110 | .It Fl v, Fl verbose Ar n 111 | Set the verbosity level for logging. 112 | .Ar n 113 | must be either a positive integer or 0, which silences all logging. Default 114 | is 2 (log only errors and warnings). 115 | .It Fl V, Fl version 116 | Print PolyMLB and Poly/ML version and exit. 117 | .Sh ML BASIS 118 | .Ss ELABORATION 119 | An MLB file is always elaborated sequentially and a single time, with the result 120 | being cached for subsequent reuses, though there is no guarantee that 121 | elaboration is done atomically. By default, an MLB graph (the given root MLB 122 | file and all transitively reachable MLB files) is evaluated sequentially in 123 | encounter order. 124 | .Pp 125 | If 126 | .Ic -deps-first 127 | is specified, an MLB file will start elaboration after all its dependencies 128 | have completed. If a 129 | .Ic -jobs 130 | argument is given, then up to that many MLB files may be processed in parallel. 131 | .Pp 132 | If either dependencies first or parallelism is enabled, the actual elaboration 133 | order is undefined. 134 | .Pp 135 | Elaboration is aborted on the first error. If other MLB files are being 136 | elaborated when aborting, these are only stopped when they reach a break 137 | point, which is before processing any MLB declaration. Errors that happen 138 | after the one that caused elaboration to abort are discarded. 139 | .Ss LIBRARIES 140 | The following libraries are available under 141 | .Pa $(SML_LIB) : 142 | .Bl -tag -width "poly/single-assignment.mlb" -offset indent -compact 143 | .It Pa basis/basis.mlb 144 | Standard ML Basis library 145 | .It Pa basis/poly.mlb 146 | All Poly/ML library extensions 147 | .It Pa poly/asn1.mlb 148 | Asn1 :> ASN1 149 | .It Pa poly/foreign.mlb 150 | Foreign :> FOREIGN 151 | .It Pa poly/hash-array.mlb 152 | HashArray 153 | .It Pa poly/net6.mlb 154 | Net6HostDB, INet6Sock :> INET6_SOCK 155 | .It Pa poly/polyml.mlb 156 | PolyML 157 | .It Pa poly/runcall.mlb 158 | RunCall 159 | .It Pa poly/signal.mlb 160 | Signal :> SIGNAL 161 | .It Pa poly/single-assignment.mlb 162 | SingleAssignment 163 | .It Pa poly/sml90.mlb 164 | SML90 165 | .It Pa poly/thread.mlb 166 | Thread :> THREAD, ThreadLib 167 | .It Pa poly/universal.mlb 168 | Universal, UniversalArray 169 | .It Pa poly/weak.mlb 170 | Weak :> WEAK 171 | .It Pa polymlb/polymlb.mlb 172 | PolyMLB library 173 | .Ss ANNOTATIONS 174 | The following annotations are recognized, with an optional 175 | .Cm poly: 176 | prefix: 177 | .Bl -tag -width "ignoreFiles f1,f2..." -offset indent -compact 178 | .It Cm debug {true|false} 179 | enable debug information 180 | .It Cm discard 181 | ignore enclosed declarations 182 | .It Cm ignoreFiles f1,f2... 183 | ignore files with a matching basename. 184 | .Ss VARIABLES 185 | The only variable set by default is 186 | .Pa SML_LIB . 187 | Its raw value can be printed using 188 | .Cm -info 189 | and its resolved value with 190 | .Cm -sml-lib . 191 | .Sh SEE ALSO 192 | .Xr poly 1 , 193 | .Xr polyc 1 194 | .Pp 195 | The Poly/ML 196 | .Lk https://polyml.org "website" , 197 | the ML Basis 198 | .Lk http://mlton.org/MLBasis "documentation" 199 | and its 200 | .Lk http://mlton.org/MLBasis.attachments/mlb-formal.pdf "formal specification" . 201 | .Pp 202 | The documentation for the 203 | .Lk https://smlfamily.github.io/Basis/ "Standard ML Basis library" 204 | and the 205 | .Lk https://polyml.org/documentation/Reference/Basis.html "Poly/ML library extensions" . 206 | -------------------------------------------------------------------------------- /src/lib/Basis.sml: -------------------------------------------------------------------------------- 1 | structure Basis : 2 | sig 3 | (* mirrors the MLB grammar except for repeating rules e.g `dec := `, 4 | * for which lists are used instead, and ` and `, which are made as 5 | * as many separate declarations. As a consequence, ` and `dec`> bindings 6 | * are assumed to be correct, i.e invalid bindings such as 7 | * `structure Foo = Bar and Foo = Baz` are to be checked earlier (i.e in 8 | * `fromParse`). 9 | * Notes: 10 | * - file paths are absolute and without variables 11 | *) 12 | datatype dec = 13 | Basis of string * exp 14 | | BasisFile of string 15 | | SourceFile of string 16 | | Ann of Ann.t list * dec list 17 | | Local of dec list * dec list 18 | | Open of string 19 | | Structure of string * string 20 | | Signature of string * string 21 | | Functor of string * string 22 | 23 | and exp = 24 | Bas of dec list 25 | | Id of string 26 | | Let of dec list * exp 27 | 28 | type t = dec list 29 | 30 | type opts = 31 | { disabledAnns : Ann.t list 32 | (* for SML source files only, replaces default. 33 | * ["sml", "ml", "ML", "sig", "fun"] 34 | *) 35 | , exts : string list option 36 | , logger : Log.logger option 37 | , pathMap : string HashArray.hash 38 | (* absolute path to a directory from which to resolve relative paths *) 39 | , path : string 40 | } 41 | 42 | datatype err_kind = DuplicateBind | Extension | UnboundVariable 43 | 44 | type err = err_kind * string * PolyML.location 45 | 46 | exception Validation of err 47 | 48 | val errToString : (string -> string) -> err -> string 49 | 50 | (* Validate parse results and convert to their Basis counterpart. 51 | * Will propagate exceptions that were raised during validation. 52 | * The following operations are performed: 53 | * - invalid annotatons are removed and the declarations they contained are 54 | * inlined; 55 | * - declarations annotated with `Discard` are discarded; 56 | * - files whose name is to be ignored are discarded; 57 | * - paths are resolved and validated (variables and extensions); 58 | * - duplicate binds are checked; 59 | * - operation lists are inlined, e.g `open bas1 bas2` or 60 | * `structure S1 = S2 and S3 = S4` become two disctint declarations; 61 | * - completely empty local/in ([], []) are discard; 62 | * - public declarations of a local/in with empty local are inlined; 63 | * - the expression of a let/in with an empty let is inlined. 64 | *) 65 | val fromParse : opts -> Parse.t -> t 66 | end = 67 | struct 68 | structure CV = CharVector 69 | structure H = HashArray 70 | structure L = List 71 | structure P = Parse 72 | structure S = String 73 | 74 | datatype dec = 75 | Basis of string * exp 76 | | BasisFile of string 77 | | SourceFile of string 78 | | Ann of Ann.t list * dec list 79 | | Local of dec list * dec list 80 | | Open of string 81 | | Structure of string * string 82 | | Signature of string * string 83 | | Functor of string * string 84 | 85 | and exp = 86 | Bas of dec list 87 | | Id of string 88 | | Let of dec list * exp 89 | 90 | type t = dec list 91 | 92 | type opts = 93 | { disabledAnns : Ann.t list 94 | , exts : string list option 95 | , logger : Log.logger option 96 | , pathMap : string HashArray.hash 97 | , path : string 98 | } 99 | 100 | datatype err_kind = DuplicateBind | Extension | UnboundVariable 101 | 102 | type err = err_kind * string * PolyML.location 103 | 104 | exception Validation of err 105 | 106 | fun errToString fmt (kind, s, at) = 107 | concat 108 | [ Log.locFmt fmt at, ": error: " 109 | , case kind of 110 | DuplicateBind => "rebound identifier" 111 | | Extension => "invalid file extension" 112 | | UnboundVariable => "unbound path var" 113 | , ": '", s, "'" 114 | ] 115 | 116 | datatype FileType = MLB | SML 117 | 118 | local 119 | val baseExts = ["sml", "ml", "ML", "fun", "sig"] 120 | in 121 | fun ftype (s, exts, loc) = 122 | case OS.Path.ext s of 123 | NONE => raise Validation (Extension, s, loc) 124 | | SOME "mlb" => MLB 125 | | SOME e => 126 | if L.exists (fn e' => e' = e) (getOpt (exts, baseExts)) then 127 | SML 128 | else 129 | raise Validation (Extension, s, loc) 130 | end 131 | 132 | fun process (m, exts, ignored, p) (s, loc) = 133 | let 134 | val s' = OS.Path.file s 135 | in 136 | if L.exists (fn x => x = s') ignored then 137 | NONE 138 | else 139 | let 140 | val t = ftype (s, exts, loc) 141 | val path = 142 | case Path.process m s of 143 | Path.Path p => p 144 | | Path.Unbound v => raise Validation (UnboundVariable, v, loc) 145 | in 146 | SOME (t, OS.Path.mkAbsolute { path = path, relativeTo = p }) 147 | end 148 | end 149 | 150 | fun mapCheck (f, l, loc) = 151 | #2 (L.foldl 152 | (fn ((x1, x2), (xs, r)) => 153 | if L.exists (fn x' => x' = x1) xs then 154 | raise Validation (DuplicateBind, x1, loc) 155 | else 156 | (x1::xs, f (x1, x2) :: r)) 157 | ([], []) l) 158 | 159 | fun badAnn log (loc, a, r) = Log.log log Log.Warn 160 | (fn fmt => concat 161 | (Log.locFmt fmt loc :: ": " :: 162 | (case r of 163 | Ann.BadArg z => ["bad argument '", z, "' for ann '", a, "'"] 164 | | Ann.MissingArg => ["missing argument for ann '", a, "'"] 165 | | Ann.UnexpectedArg => ["unexpected arg for ann '", a, "'"] 166 | | Ann.Unrecognized => ["unrecognized ann '", a, "'"] 167 | | Ann.Ann _ => raise Fail "Basis.badAnn: impossible"))) 168 | 169 | fun annCheck (xs, dis, cb, loc) = 170 | let 171 | fun f ([], r, p) = (L.rev r, p) 172 | | f (x::xs, r, p) = 173 | case Ann.parse x of 174 | Ann.Ann a => 175 | if Ann.exists a dis then 176 | f (xs, r, p) 177 | else 178 | (case a of 179 | Ann.IgnoreFiles l => f (xs, a::r, l @ p) 180 | | _ => f (xs, a::r, p)) 181 | | z => (cb (loc, x, z); f (xs, r, p)) 182 | in 183 | f (xs, [], []) 184 | end 185 | 186 | fun fromParse { disabledAnns, logger, pathMap, path, exts } = 187 | let 188 | fun conv ignored ds = 189 | let 190 | val path = process (pathMap, exts, ignored, path) 191 | 192 | fun dec ((P.Basis l, loc), ds) = 193 | mapCheck (fn (s, e) => Basis (s, exp e), l, loc) @ ds 194 | | dec ((P.File p, loc), ds) = 195 | (case path (p, loc) of 196 | NONE => ds 197 | | SOME (MLB, p) => BasisFile p :: ds 198 | | SOME (SML, p) => SourceFile p :: ds) 199 | | dec ((P.Ann (l, ds'), loc), ds) = 200 | (case annCheck (l, disabledAnns, badAnn logger, loc) of 201 | ([], _) => L.foldl dec ds ds' 202 | | (l, p) => 203 | if Ann.exists Ann.Discard l then 204 | ds 205 | else 206 | Ann (l, conv (p @ ignored) ds') :: ds) 207 | | dec ((P.Local (ds1, ds2), _), ds) = 208 | (case (conv ignored ds1, conv ignored ds2) of 209 | ([], []) => ds 210 | | ([], l2) => L.revAppend (l2, ds) 211 | | (l1, l2) => Local (l1, l2) :: ds) 212 | | dec ((P.Open l, _), ds) = 213 | foldl (fn (s, l) => Open s :: l) [] l @ ds 214 | | dec ((P.Structure l, loc), ds) = 215 | mapCheck (Structure, l, loc) @ ds 216 | | dec ((P.Signature l, loc), ds) = 217 | mapCheck (Signature, l, loc) @ ds 218 | | dec ((P.Functor l, loc), ds) = 219 | mapCheck (Functor, l, loc) @ ds 220 | 221 | and exp (P.Bas ds, _) = 222 | Bas (conv ignored ds) 223 | | exp (P.Id s, _) = 224 | Id s 225 | | exp (P.Let (ds, e), _) = 226 | case conv ignored ds of 227 | [] => exp e 228 | | l => Let (l, exp e) 229 | in 230 | L.rev (L.foldl dec [] ds) 231 | end 232 | in 233 | conv [] 234 | end 235 | end 236 | -------------------------------------------------------------------------------- /LIBRARY: -------------------------------------------------------------------------------- 1 | PolyMLB 2 | ======= 3 | 4 | ## Simple usage 5 | 6 | The PolyMLB library's main API is the `PolyMLB` structure, which offers the 7 | following functions: 8 | 9 | - `compile`: compile an ML Basis file and return the resulting namespace; 10 | - `import`: compile an ML Basis file and import it into the global namespace; 11 | - `use`: like import but with signature and behavior similar to the top level 12 | function `use`. 13 | 14 | The behavior of both `compile` and `import` can be customized through the passed 15 | in options and raises on error. On the other hand, `use` does not take in has 16 | type `string -> unit`; in case of error, it prints the error to stdout and 17 | raises Fail. 18 | 19 | The library can be imported by calling `use` with the `build.sml` file in 20 | `src/lib`, though SML_LIB is not set by default. Once it has been successfully 21 | compiled, MLB based libraries may be imported by making use of the above 22 | functions. Default path variables are stored in the `PolyMLB.pathMap` map, which 23 | is publicly accessible and modifiable. 24 | 25 | > PolyML.use "path/to/polymlb/sources/build.sml"; 26 | > HashArray.update (PolyMLB.pathMap, "SML_LIB", "path/to/libraries"); 27 | > PolyMLB.use "path/to/lib.mlb"; 28 | 29 | If PolyMLB was installed through `make install`, then it is available at 30 | `$SML_LIB/polymlb`. As an example, the following can be used to start a 31 | Poly/ML REPL with PolyMLB: 32 | 33 | $ SML_LIB=$(polymlb -sml-lib) 34 | $ poly -i --eval \ 35 | "PolyML.use \"$SML_LIB/polymlb/build.sml\"; 36 | HashArray.update (PolyMLB.pathMap, \"SML_LIB\", \"$SML_LIB\");" 37 | 38 | The lower level components are included in the PolyMLB structure for convenience 39 | and "just in case" but are not stable and must be used with care in order to 40 | avoid catastrophic failure. 41 | 42 | 43 | ## Implementation overview 44 | 45 | The exposed inner modules are as follows: 46 | 47 | - Ann, annotations utilities; 48 | - Basis, mlb validation and conversion from parse results; 49 | - Compile, mlb compilation; 50 | - Dag, mlb graph processing and validation; 51 | - Lex, mlb lexing utilities; 52 | - Log, logging utilities; 53 | - NameSpace, result of mlb compilation; 54 | - Parse, mlb parsing; 55 | - Path, path validation. 56 | 57 | The library is mostly designed as a two-stage process. The first one is the Dag 58 | module, in charge of traversing and checking the entire MLB graph. The second 59 | is Compile, which elaborates a graph; it completely trusts its input and expects 60 | that there is no missing dependency, cycle, etc. 61 | 62 | The general error policy is to raise an exception and let it propagate. The 63 | PolyMLB structure is in fact only glue code for the different components with 64 | some error handling. 65 | 66 | 67 | Compilation works with namespaces (`NameSpace.t`), which are representations 68 | of a 'basis' as described in [1]: 69 | 70 | > [A] basis is a collection, but of more kinds of objects: types, values, 71 | > structures, fixities, signatures, functors, and other bases. 72 | 73 | The concrete implementation is simply a `PolyML.NameSpace.nameSpace` [2] 74 | augmented with similar operations for bases (i.e operating on `NameSpace.t`). 75 | Compiling an MLB file thus returns a namespace which contains its public exposed 76 | symbols. 77 | 78 | [1]: http://mlton.org/MLBasisSyntaxAndSemantics 79 | [2]: https://polyml.org/documentation/Reference/PolyMLNameSpace.html 80 | 81 | 82 | ## Details 83 | 84 | ### Builtin libraries 85 | 86 | Due to the Basis library and the Poly/ML extensions being baked in the compiler, 87 | support for these is hacked in with prefilled namespaces derived from the global 88 | namespace and a hardcoded list of structure and signature names from Poly/ML 89 | extensions. In order to avoid special casing every module to check whether paths 90 | refer to either of these libraries, valid mlb files are provided, although they 91 | only contain an open directive for the corresponding namespace. 92 | 93 | Since elaboration starts in an empty environment, these namespaces are at first 94 | not available. A special `poly:importAll` annotation is used, which has the 95 | effect of making the entirety of the global namespace available to its enclosed 96 | declarations. Thus the SML Basis mlb is simply: 97 | 98 | ann 99 | "poly:importAll" 100 | in 101 | open BasisLib 102 | end 103 | 104 | ### Elaboration order 105 | 106 | Each mlb file is elaborated only once and its resulting namespace reused when 107 | referenced again. On the other hand, SML source files are compilated everytime 108 | they are referenced, even in the same mlb file. When exactly an mlb file is 109 | compiled depends on the options passed to the Compile module. 110 | 111 | The default elaboration scheme is purely sequential and compiles mlb files as 112 | they are encountered, starting from the root mlb. E.g the following mlb files 113 | 114 | $ cat a.mlb 115 | local 116 | $(SML_LIB)/basis/basis.mlb 117 | in 118 | a.sml 119 | end 120 | $ cat b.mlb 121 | local 122 | $(SML_LIB)/basis/basis.mlb 123 | a.sml 124 | in 125 | b.sml 126 | end 127 | $ cat root.mlb 128 | local 129 | $(SML_LIB)/basis/basis.mlb 130 | b.mlb 131 | c.sml 132 | a.mlb 133 | in 134 | main.sml 135 | end 136 | 137 | are compiled in this order: 138 | 139 | 1. root.mlb 140 | 1. basis.mlb 141 | 2. b.mlb 142 | 1. a.sml 143 | 2. b.sml 144 | 3. c.sml 145 | 4. a.mlb 146 | 1. a.sml 147 | 5. main.sml 148 | 149 | It is possible to force all "dependencies" of an mlb file to be fully elaborated 150 | before said mlb file is processed. The above mlb files could then be compiled as 151 | follows: 152 | 153 | 1. basis.mlb 154 | 2. b.mlb 155 | 1. a.sml 156 | 2. b.sml 157 | 3. a.mlb 158 | 1. a.sml 159 | 4. root.mlb 160 | 1. c.sml 161 | 2. main.sml 162 | 163 | Note that elaboration order is only guaranteed in the default case (encounter 164 | order); if forcing dependencies first, the order in which independent mlb files 165 | are processed is undefined. E.g here a.mlb could be processed before b.mlb. 166 | 167 | ### Parallel compilation 168 | 169 | Parallel compilation works at the mlb level. In this example, a.mlb and b.mlb 170 | may be processed at the same time. Elaboration of a single mlb file is always 171 | sequential, regardless of the given options. 172 | 173 | If the 'dependencies first' option is not set, then the elaboration of an mlb 174 | file may be started before its dependencies have completed; then when reaching 175 | a import directive that references an mlb which has yet to start or is 176 | elaborating, the current elaboration is simply parked until the dependency is 177 | ready and the processing thread switches to another job. 178 | 179 | A possible parallel elaboration trace for root.mlb could look like this, if for 180 | some reason compiling a.mlb took longer than b.mlb: 181 | 182 | 1. start root.mlb 183 | 2. start basis.mlb 184 | 3. start a.mlb 185 | 4. start b.mlb 186 | 5. complete basis.mlb 187 | 6. check root.mlb for basis.mlb; continue 188 | 7. check root.mlb for b.mlb; park 189 | 8. complete b.mlb 190 | 9. resume root.mlb 191 | 10. compile c.sml 192 | 11. check root.mlb for a.mlb; park 193 | 12. complete a.mlb 194 | 13. resume root.mlb 195 | 14. compile main.sml 196 | 15. complete root.mlb 197 | 198 | The order in which mlb files are elaborated, started or resumed is undefined 199 | and depends on a number of different factors, such as dependency order, thread 200 | count, etc. The only guarantee is that of the dependencies first option. 201 | 202 | Although it may seem that allowing an mlb file to start only after its mlb 203 | dependencies are elaborated limits parallelism, most mlb files likely look like 204 | the following: 205 | 206 | local 207 | $(SML_BASIS)/basis/basis.mlb 208 | dep1.mlb 209 | ... 210 | source1.sml 211 | ... 212 | in 213 | source2.sml 214 | ... 215 | end 216 | 217 | in which case there is at best very little to be gained from concurrent 218 | elaboration since the actual time consuming part of the process is compiling 219 | SML source files, which may only happen after all dependencies are completely 220 | finished due to the sequential nature of within-mlb elaboration. 221 | 222 | ### Errors and cancellation 223 | 224 | Elaboration is completely aborted when an error is encountered; which, assuming 225 | the given data is correct, means the error happened either when compiling SML 226 | source files or in a rebinding / open MLB directive such as `structure S1 = S2`. 227 | If this is the former, then it may be due to an I/O error, an ill-formed program 228 | that did not compile or top level code that failed in a way or another. 229 | 230 | In the case of parallel compilation, all processing threads are interrupted 231 | synchronously, i.e when they reach a suitable break point. Such a break point 232 | is one of: 233 | 234 | - before starting a new job; 235 | - after completing a job (e.g after completing or parking an mlb file); 236 | - before each declaration in an mlb file. 237 | 238 | Finer grained constructs, such as SML compilation, are never interrupted (at 239 | least not by the library itself), i.e if an error happens while an SML file is 240 | being compiled, then it will be entirely compiled and its top level executed 241 | before the thread actually exits. 242 | 243 | Further errors that happen during the timeframe between the first error and all 244 | threads exiting are discarded and only the original one is reported. 245 | -------------------------------------------------------------------------------- /src/lib/Lex.sml: -------------------------------------------------------------------------------- 1 | structure Lex :> 2 | sig 3 | datatype token = 4 | String of string 5 | | Symbol of string 6 | | And 7 | | Ann 8 | | Bas 9 | | Basis 10 | | End 11 | | Eq 12 | | Functor 13 | | In 14 | | Let 15 | | Local 16 | | Open 17 | | Semi 18 | | Signature 19 | | Structure 20 | 21 | val toString : token -> string 22 | 23 | eqtype position 24 | 25 | val makePos : { startLine : int, startCol : int, endLine : int, endCol : int } 26 | -> position 27 | val joinPos : position * position -> position 28 | val toPolyLoc : string * position -> PolyML.location 29 | 30 | type t = (token * position) list * { start : position, eof : position } 31 | 32 | datatype err_kind = 33 | BadChar of char 34 | | BadWord of string 35 | | UnclosedComment 36 | | UnclosedString 37 | 38 | type err = err_kind * PolyML.location 39 | 40 | exception Lex of err 41 | 42 | val errToString : (string -> string) -> err -> string 43 | 44 | (* raises Lex in case of 45 | * - unclosed comment 46 | * - unclosed string 47 | * - invalid string char 48 | * - bad reserved word 49 | *) 50 | val lex : string -> string -> t 51 | end = 52 | struct 53 | structure C = Char 54 | structure S = String 55 | structure SS = Substring 56 | structure V = Vector 57 | 58 | datatype token = 59 | String of string 60 | | Symbol of string 61 | | And 62 | | Ann 63 | | Bas 64 | | Basis 65 | | End 66 | | Eq 67 | | Functor 68 | | In 69 | | Let 70 | | Local 71 | | Open 72 | | Semi 73 | | Signature 74 | | Structure 75 | 76 | fun toString t = 77 | case t of 78 | String "" => "string" 79 | | String s => "string \"" ^ s ^ "\"" 80 | | Symbol "" => "symbol" 81 | | Symbol s => "symbol \"" ^ s ^ "\"" 82 | | And => "and" 83 | | Ann => "ann" 84 | | Bas => "bas" 85 | | Basis => "basis" 86 | | End => "end" 87 | | Eq => "=" 88 | | Functor => "functor" 89 | | In => "in" 90 | | Let => "let" 91 | | Local => "local" 92 | | Open => "open" 93 | | Semi => ";" 94 | | Signature => "signature" 95 | | Structure => "structure" 96 | 97 | (* Positions are packed in a single 64 bit word, where each line or column is 98 | * represented with 16 bit. This assumes that {files,columns} are no longer 99 | * than 65536 {lines,characters}. The storing order is [start line, start col, 100 | * end line, end col], from the msb to the lsb. 101 | *) 102 | type position = Word64.word 103 | 104 | local 105 | val `& = Word64.andb 106 | val `| = Word64.orb 107 | val << = Word64.<< 108 | val >> = Word64.>> 109 | 110 | infix 8 `& `| `^ << >> 111 | 112 | val toi = Word64.toInt 113 | val tow = Word64.fromInt 114 | 115 | val max = toi (0w1 << 0w16) 116 | 117 | fun chkdw i = 118 | if i >= max then 119 | raise Fail ("Lex.mkPos: too large: " ^ Int.toString i) 120 | else 121 | tow i 122 | 123 | val slineMask = (0w1 << 0w16 - 0w1) << 0w48 124 | val scolMask = (0w1 << 0w16 - 0w1) << 0w32 125 | val elineMask = (0w1 << 0w16 - 0w1) << 0w16 126 | val ecolMask = 0w1 << 0w16 - 0w1 127 | 128 | val sMask = (0w1 << 0w32 - 0w1) << 0w32 129 | val eMask = 0w1 << 0w32 - 0w1 130 | in 131 | fun mkPos (l, c, l', c') = 132 | (chkdw l << 0w48) `| (chkdw c << 0w32) `| (chkdw l' << 0w16) `| chkdw c' 133 | 134 | fun joinPos (w1, w2) = 135 | Word64.min (w1 `& sMask, w2 `& sMask) 136 | `| Word64.max (w1 `& eMask, w2 `& eMask) 137 | 138 | fun unpackStart w = 139 | (toi ((w `& slineMask) >> 0w48), toi ((w `& scolMask) >> 0w32)) 140 | 141 | fun toPolyLoc (s, w) = 142 | { file = s 143 | , startLine = toi ((w `& slineMask) >> 0w48) 144 | , startPosition = toi ((w `& scolMask) >> 0w32) 145 | , endLine = toi ((w `& elineMask) >> 0w16) 146 | , endPosition = toi (w `& ecolMask) 147 | } 148 | end 149 | 150 | fun makePos { startLine, startCol, endLine, endCol } = 151 | mkPos (startLine, startCol, endLine, endCol) 152 | 153 | fun polyLoc (s, l, c, l', c') = 154 | { file = s 155 | , startLine = l, startPosition = c 156 | , endLine = l', endPosition = c' 157 | } 158 | 159 | datatype err_kind = 160 | BadChar of char 161 | | BadWord of string 162 | | UnclosedComment 163 | | UnclosedString 164 | 165 | type err = err_kind * PolyML.location 166 | 167 | exception Lex of err 168 | 169 | fun errToString fmt (e, at) = 170 | concat 171 | [ Log.locFmt fmt at 172 | , ": error: invalid token: " 173 | , case e of 174 | BadChar c => "bad character '" ^ Char.toString c ^ "'" 175 | | BadWord w => "reserved word not allowed here '" ^ w ^ "'" 176 | | UnclosedComment => "unclosed comment" 177 | | UnclosedString => "unclosed string" 178 | ] 179 | 180 | type t = (token * position) list * { start : position, eof : position } 181 | 182 | fun skip { name, line, col, src, res } = 183 | let 184 | fun ok i = i < SS.size src 185 | fun sub i = SS.sub (src, i) 186 | 187 | fun comment (s, l, c, i) = 188 | if not (ok i) then 189 | let 190 | val (l', c') = hd s 191 | in 192 | raise Lex (UnclosedComment, polyLoc (name, l', c', l, c)) 193 | end 194 | else 195 | case sub i of 196 | #"(" => 197 | if ok (i + 1) andalso sub (i + 1) = #"*" then 198 | comment ((l, c)::s, l, c + 2, i + 2) 199 | else 200 | comment (s, l, c + 1, i + 1) 201 | | #"*" => 202 | if ok (i + 1) andalso sub (i + 1) = #")" then 203 | case s of 204 | [] => raise Fail "Lex.skip.comment: impossible" 205 | | [_] => (l, c + 2, i + 2) 206 | | _::s => comment (s, l, c + 2, i + 2) 207 | else 208 | comment (s, l, c + 1, i + 1) 209 | | #"\n" => comment (s, l + 1, 1, i + 1) 210 | | _ => comment (s, l, c + 1, i + 1) 211 | 212 | fun skip' (l, c, i) = 213 | if not (ok i) then 214 | (l, c, i) 215 | else if sub i = #"\n" then 216 | skip' (l + 1, 0, i + 1) 217 | else if C.isSpace (sub i) then 218 | skip' (l, c + 1, i + 1) 219 | else if sub i = #"(" andalso ok (i + 1) andalso sub (i + 1) = #"*" then 220 | (skip' o comment) ([(l, c)], l, c + 2, i + 2) 221 | else 222 | (l, c, i) 223 | 224 | val (line, col, ofs) = skip' (line, col, 0) 225 | in 226 | { line = line, col = col, src = SS.triml ofs src, res = res } 227 | end 228 | 229 | local 230 | val S = SS.full 231 | in 232 | val keywords = (V.fromList o map (fn t => (S (toString t), t))) 233 | [ And, Ann, Bas, Basis, End, Eq, Functor, In, Let, Local, Open, Semi 234 | , Signature, Structure 235 | ] 236 | 237 | val badSymbols = (V.fromList o map S) 238 | [ "abstype", "andalso", "as", "case", "datatype", "do", "else" 239 | , "exception", "fn", "fun", "handle" , "if", "infix", "infixr", "nonfix" 240 | , "of", "op", "orelse", "raise", "rec", "sig", "struct", "then", "type" 241 | , "val", "with", "withtype", "while" 242 | ] 243 | end 244 | 245 | fun ssEq a b = SS.size a = SS.size b andalso SS.compare (a, b) = EQUAL 246 | 247 | fun reserved w = 248 | let 249 | fun find i = 250 | if i = V.length keywords then 251 | NONE 252 | else 253 | let 254 | val (kw, t) = V.sub (keywords, i) 255 | in 256 | if ssEq w kw then SOME t else find (i + 1) 257 | end 258 | in 259 | find 0 260 | end 261 | 262 | fun string (name, line, col, src) = 263 | let 264 | val sz = SS.size src 265 | 266 | fun read (l, c, i) = 267 | if i = sz then 268 | NONE 269 | else if SS.sub (src, i) = #"\n" then 270 | SOME (SS.sub (src, i), (l + 1, 1, i + 1)) 271 | else 272 | SOME (SS.sub (src, i), (l, c + 1, i + 1)) 273 | 274 | fun scan (l, c, i, res) = 275 | if i = sz then 276 | raise Lex (UnclosedString, polyLoc (name, line, col, l, c - 1)) 277 | else if SS.sub (src, i) = #"\"" then 278 | (l, c + 1, i + 1, res) 279 | else 280 | case C.scan read (l, c, i) of 281 | SOME (ch, (l, c, i)) => scan (l, c, i, ch::res) 282 | | NONE => 283 | raise Lex 284 | (if SS.sub (src, i) = #"\n" then 285 | (UnclosedString, polyLoc (name, line, col, l, c)) 286 | else 287 | ((BadChar o SS.sub) (src, i), polyLoc (name, l, c, l, c + 1))) 288 | 289 | val (l, c, i, res) = scan (line, col + 1, 0, []) 290 | in 291 | (implode (rev res), l, c, SS.triml i src) 292 | end 293 | 294 | val isGoodChar = 295 | fn #"$" => true 296 | | #"(" => true 297 | | #")" => true 298 | | #"." => true 299 | | #"/" => true 300 | | #"-" => true 301 | | #"_" => true 302 | | #"'" => true 303 | | c => Char.isAlphaNum c 304 | 305 | fun word (col, src) = 306 | let 307 | fun f i = 308 | if i < SS.size src andalso (isGoodChar o SS.sub) (src, i) then 309 | f (i + 1) 310 | else 311 | i 312 | 313 | val i = 314 | if SS.sub (src, 0) = #"=" orelse SS.sub (src, 0) = #";" then 315 | 1 316 | else 317 | f 0 318 | val (w, rest) = SS.splitAt (src, i) 319 | in 320 | (w, col + i, rest) 321 | end 322 | 323 | fun tokenize (state as { name, ... }) = 324 | let 325 | val { line, col, src, res } = skip state 326 | in 327 | if SS.size src = 0 then 328 | let 329 | val l = rev res 330 | val eof = mkPos (line, col, line, col) 331 | val start = case l of 332 | [] => eof 333 | | (_, p)::_ => 334 | let 335 | val (l, c) = unpackStart p 336 | in 337 | mkPos (l, c, l, c) 338 | end 339 | in 340 | (l, { start = start, eof = eof }) 341 | end 342 | else if SS.sub (src, 0) = #"\"" then 343 | let 344 | val (w, l, c, src) = string (name, line, col, SS.triml 1 src) 345 | val loc = mkPos (line, col, l, c) 346 | in 347 | tokenize 348 | { name = name 349 | , line = l 350 | , col = c 351 | , src = src 352 | , res = (String w, loc) :: res 353 | } 354 | end 355 | else 356 | let 357 | val (w, c, src) = word (col, src) 358 | val l = line 359 | val loc = mkPos (line, col, l, c) 360 | in 361 | if SS.size w = 0 then 362 | raise Lex 363 | ((BadChar o SS.sub) (src, 0), polyLoc (name, l, c, l, c + 1)) 364 | else 365 | (); 366 | case reserved w of 367 | SOME t => 368 | tokenize 369 | { name = name 370 | , line = l 371 | , col = c 372 | , src = src 373 | , res = (t, loc)::res 374 | } 375 | | NONE => 376 | if V.exists (ssEq w) badSymbols then 377 | raise Lex (BadWord (SS.string w), toPolyLoc (name, loc)) 378 | else 379 | tokenize 380 | { name = name 381 | , line = l 382 | , col = c 383 | , src = src 384 | , res = (Symbol (SS.string w), loc) :: res 385 | } 386 | end 387 | end 388 | 389 | fun lex n s = 390 | tokenize { name = n, line = 1, col = 1, src = SS.full s, res = [] } 391 | end 392 | -------------------------------------------------------------------------------- /src/millet/stub.sml: -------------------------------------------------------------------------------- 1 | structure HashArray :> 2 | sig 3 | type 'a hash 4 | val hash : int -> 'a hash 5 | val update : 'a hash * string * 'a -> unit 6 | val sub : 'a hash * string -> 'a option 7 | val delete : 'a hash * string -> unit 8 | val fold : (string * 'a * 'b -> 'b) -> 'b -> 'a hash -> 'b 9 | end = 10 | struct 11 | end 12 | 13 | structure Universal :> 14 | sig 15 | type universal 16 | type 'a tag 17 | val tag : unit -> 'a tag 18 | val tagInject : 'a tag -> 'a -> universal 19 | val tagIs : 'a tag -> universal -> bool 20 | val tagProject : 'a tag -> universal -> 'a 21 | end = 22 | struct 23 | end 24 | 25 | structure PolyML : 26 | sig 27 | type location = 28 | { file : string 29 | , startLine : int, endLine : int 30 | , startPosition : int, endPosition : int 31 | } 32 | 33 | structure Exception : 34 | sig 35 | val exceptionLocation : exn -> location option 36 | val raiseWithLocation : exn * location -> 'a 37 | val reraise : exn -> 'a 38 | 39 | val traceException : (unit -> 'a) * (string list * exn -> 'a) -> 'a 40 | val exception_trace : (unit -> 'a) -> 'a 41 | end 42 | 43 | datatype context = 44 | ContextLocation of location 45 | | ContextProperty of string * string 46 | 47 | datatype pretty = 48 | PrettyBlock of int * bool * context list * pretty list 49 | | PrettyBreak of int * int 50 | | PrettyLineBreak 51 | | PrettyString of string 52 | | PrettyStringWithWidth of string * int 53 | 54 | val prettyPrint : (string -> unit) * int -> pretty -> unit 55 | 56 | type typeExpression 57 | 58 | datatype ptProperties = 59 | PTbreakPoint of bool ref 60 | | PTcompletions of string list 61 | | PTdeclaredAt of location 62 | | PTdefId of int 63 | | PTfirstChild of unit -> location * ptProperties list 64 | | PTnextSibling of unit -> location * ptProperties list 65 | | PTopenedAt of location 66 | | PTparent of unit -> location * ptProperties list 67 | | PTpreviousSibling of unit -> location * ptProperties list 68 | | PTprint of int -> pretty 69 | | PTreferences of bool * location list 70 | | PTrefId of int 71 | | PTstructureAt of location 72 | | PTtype of typeExpression 73 | 74 | type parseTree = location * ptProperties list 75 | 76 | structure CodeTree : 77 | sig 78 | type codeBinding 79 | type codeTree 80 | type machineWord 81 | end 82 | 83 | structure NameSpace : 84 | sig 85 | type fixity 86 | type functorVal 87 | type signatureVal 88 | type structureVal 89 | type typeConstr 90 | type value 91 | 92 | type nameSpace = 93 | { allFix : unit -> (string * fixity) list 94 | , allFunct : unit -> (string * functorVal) list 95 | , allSig : unit -> (string * signatureVal) list 96 | , allStruct : unit -> (string * structureVal) list 97 | , allType : unit -> (string * typeConstr) list 98 | , allVal : unit -> (string * value) list 99 | , enterFix : string * fixity -> unit 100 | , enterFunct : string * functorVal -> unit 101 | , enterSig : string * signatureVal -> unit 102 | , enterStruct : string * structureVal -> unit 103 | , enterType : string * typeConstr -> unit 104 | , enterVal : string * value -> unit 105 | , lookupFix : string -> fixity option 106 | , lookupFunct : string -> functorVal option 107 | , lookupSig : string -> signatureVal option 108 | , lookupStruct : string -> structureVal option 109 | , lookupType : string -> typeConstr option 110 | , lookupVal : string -> value option 111 | } 112 | 113 | structure Functors : 114 | sig 115 | type functorVal 116 | val code : functorVal -> CodeTree.codetree 117 | val name : functorVal -> string 118 | val print : functorVal * int * nameSpace option -> pretty 119 | val properties : functorVal -> ptProperties list 120 | end where type functorVal = functorVal 121 | structure Infixes : 122 | sig 123 | type fixity 124 | val name : fixity -> string 125 | val print : fixity -> pretty 126 | end where type fixity = fixity 127 | structure Signatures : 128 | sig 129 | type signatureVal 130 | val name : signatureVal -> string 131 | val print : signatureVal * int * nameSpace option -> pretty 132 | val properties : signatureVal -> ptProperties list 133 | end where type signatureVal = signatureVal 134 | structure Structures : 135 | sig 136 | type structureVal 137 | val code : structureVal -> CodeTree.codetree 138 | val contents : structureVal -> nameSpace 139 | val name : structureVal -> string 140 | val print : structureVal * int * nameSpace option -> pretty 141 | val properties : structureVal -> ptProperties list 142 | end where type structureVal = structureVal 143 | structure TypeConstrs : 144 | sig 145 | type typeConstr 146 | val name : typeConstr -> string 147 | val print : typeConstr * int * nameSpace option -> pretty 148 | val properties : typeConstr -> ptProperties list 149 | end where type typeConstr = typeConstr 150 | structure Values : 151 | sig 152 | type typeExpression 153 | type value 154 | val code : value -> CodeTree.codetree 155 | val isConstructor : value -> bool 156 | val isException : value -> bool 157 | val name : value -> string 158 | val print : value * int -> pretty 159 | val printType : typeExpression * int * nameSpace option -> pretty 160 | val printWithType : value * int * nameSpace option -> pretty 161 | val properties : value -> ptProperties list 162 | val typeof : value -> typeExpression 163 | end where type value = value and type typeExpression = typeExpression 164 | 165 | val globalNameSpace : nameSpace 166 | end 167 | 168 | val globalNameSpace : NameSpace.nameSpace 169 | 170 | structure Compiler : 171 | sig 172 | datatype compilerParameters = 173 | CPOutStream of string->unit 174 | | CPNameSpace of NameSpace.nameSpace 175 | | CPErrorMessageProc of 176 | { message : pretty 177 | , hard : bool 178 | , location : location 179 | , context : pretty option 180 | } -> unit 181 | | CPLineNo of unit -> int 182 | | CPLineOffset of unit -> int 183 | | CPFileName of string 184 | | CPPrintInAlphabeticalOrder of bool 185 | | CPResultFun of 186 | { fixes : (string * NameSpace.Infixes.fixity) list 187 | , values : (string * NameSpace.Values.value) list 188 | , structures : (string * NameSpace.Structures.structureVal) list 189 | , signatures : (string * NameSpace.Signatures.signatureVal) list 190 | , functors : (string * NameSpace.Functors.functorVal) list 191 | , types : (string * NameSpace.TypeConstrs.typeConstr) list 192 | } -> unit 193 | | CPCompilerResultFun of 194 | parseTree option * 195 | ( unit -> 196 | { fixes : (string * NameSpace.Infixes.fixity) list 197 | , values : (string * NameSpace.Values.value) list 198 | , structures : (string * NameSpace.Structures.structureVal) list 199 | , signatures : (string * NameSpace.Signatures.signatureVal) list 200 | , functors : (string * NameSpace.Functors.functorVal) list 201 | , types : (string * NameSpace.TypeConstrs.typeConstr) list 202 | } 203 | ) option -> unit -> unit 204 | | CPProfiling of int 205 | | CPTiming of bool 206 | | CPDebug of bool 207 | | CPPrintDepth of unit->int 208 | | CPPrintStream of string->unit 209 | | CPErrorDepth of int 210 | | CPLineLength of int 211 | | CPRootTree of 212 | { parent : (unit -> parseTree) option 213 | , next : (unit -> parseTree) option 214 | , previous : (unit -> parseTree) option 215 | } 216 | (* | CPAllocationProfiling of int *) 217 | | CPDebuggerFunction of 218 | int * NameSpace.Values.value * int * string * string * NameSpace.nameSpace 219 | -> unit 220 | 221 | val compilerVersion : string 222 | val compilerVersionNumber : int 223 | 224 | val printDepth : int ref 225 | val errorDepth : int ref 226 | val lineLength : int ref 227 | 228 | val printInAlphabeticalOrder : bool ref 229 | 230 | val prompt1 : string ref 231 | val prompt2 : string ref 232 | 233 | val reportExhaustiveHandlers : bool ref 234 | val reportUnreferencedIds : bool ref 235 | val reportDiscardFunction : bool ref 236 | val reportDiscardNonUnit : bool ref 237 | 238 | val debug : bool ref 239 | val timing : bool ref 240 | val profiling : int ref 241 | val allocationProfiling : int ref 242 | 243 | val lowlevelOptimise : bool ref 244 | val inlineFunctors : bool ref 245 | val createPrintFunctions : bool ref 246 | val maxInlineSize : int ref 247 | val narrowOverloadFlexRecord : bool ref 248 | val traceCompiler : bool ref 249 | 250 | val parsetree : bool ref 251 | val codetree : bool ref 252 | val codetreeAfterOpt : bool ref 253 | val assemblyCode : bool ref 254 | val pstackTrace : bool ref 255 | 256 | val fixityNames : unit -> string list 257 | val functorNames : unit -> string list 258 | val signatureNames : unit -> string list 259 | val structureNames : unit -> string list 260 | val typeNames : unit -> string list 261 | val valueNames : unit -> string list 262 | 263 | val forgetFixity : string -> unit 264 | val forgetFunctor : string -> unit 265 | val forgetSignature : string -> unit 266 | val forgetStructure : string -> unit 267 | val forgetType : string -> unit 268 | val forgetValue : string -> unit 269 | end 270 | 271 | val compiler : 272 | (unit -> char option) * Compiler.compilerParameters list 273 | -> unit -> unit 274 | 275 | val make : string -> unit 276 | val getUseFileName : unit -> string option 277 | val suffixes : string list ref 278 | val export : string * (unit -> unit) -> unit 279 | end = 280 | struct 281 | end 282 | 283 | signature THREAD = 284 | sig 285 | exception Thread of string 286 | structure Thread : 287 | sig 288 | eqtype thread 289 | datatype threadAttribute = 290 | EnableBroadcastInterrupt of bool 291 | | InterruptState of interruptState 292 | | MaximumMLStack of int option 293 | and interruptState = 294 | InterruptDefer 295 | | InterruptSynch 296 | | InterruptAsynch 297 | | InterruptAsynchOnce 298 | val fork : (unit->unit) * threadAttribute list -> thread 299 | val exit : unit -> unit 300 | val isActive : thread -> bool 301 | val equal : thread * thread -> bool 302 | val self : unit -> thread 303 | exception Interrupt 304 | val interrupt : thread -> unit 305 | val broadcastInterrupt : unit -> unit 306 | val testInterrupt : unit -> unit 307 | val kill : thread -> unit 308 | val getLocal : 'a Universal.tag -> 'a option 309 | and setLocal : 'a Universal.tag * 'a -> unit 310 | val setAttributes : threadAttribute list -> unit 311 | val getAttributes : unit -> threadAttribute list 312 | val numProcessors : unit -> int 313 | and numPhysicalProcessors : unit -> int option 314 | end 315 | structure Mutex : 316 | sig 317 | type mutex 318 | val mutex : unit -> mutex 319 | val lock : mutex -> unit 320 | val unlock : mutex -> unit 321 | val trylock : mutex -> bool 322 | end 323 | structure ConditionVar : 324 | sig 325 | type conditionVar 326 | val conditionVar : unit -> conditionVar 327 | val wait : conditionVar * Mutex.mutex -> unit 328 | val waitUntil : conditionVar * Mutex.mutex * Time.time -> bool 329 | val signal : conditionVar -> unit 330 | val broadcast : conditionVar -> unit 331 | end 332 | end 333 | 334 | structure Thread :> THREAD = 335 | struct 336 | end 337 | 338 | structure ThreadLib : 339 | sig 340 | val protect : Thread.Mutex.mutex -> ('a -> 'b) -> 'a -> 'b 341 | end = 342 | struct 343 | end 344 | -------------------------------------------------------------------------------- /src/lib/Parse.sml: -------------------------------------------------------------------------------- 1 | structure Parse : 2 | sig 3 | (* Stringly typed version of Basis.dec and Basis.exp augmented with location. 4 | * withtype not allowed in signatures, see in struct for cleaner version. 5 | *) 6 | datatype dec_kind = 7 | Ann of string list * (dec_kind * PolyML.location) list 8 | | Basis of (string * (exp_kind * PolyML.location)) list 9 | | File of string 10 | | Functor of (string * string) list 11 | | Local of (dec_kind * PolyML.location) list * (dec_kind * PolyML.location) list 12 | | Open of string list 13 | | Signature of (string * string) list 14 | | Structure of (string * string) list 15 | 16 | and exp_kind = 17 | Bas of (dec_kind * PolyML.location) list 18 | | Id of string 19 | | Let of (dec_kind * PolyML.location) list * (exp_kind * PolyML.location) 20 | 21 | type dec = dec_kind * PolyML.location 22 | type exp = exp_kind * PolyML.location 23 | 24 | structure Element : 25 | sig 26 | datatype t = 27 | Dec | Ann | Basis | File | Functor | Local | Open | Signature | Structure 28 | | Exp | Bas | Id | Let 29 | | Token of Lex.token 30 | | EOF 31 | 32 | val toString : t -> string 33 | end 34 | 35 | type t = dec list 36 | 37 | type err = 38 | { expected : Element.t list 39 | , found : Element.t 40 | , at : PolyML.location 41 | } list 42 | 43 | exception Parse of err 44 | 45 | val errToString : (string -> string) -> err -> string 46 | 47 | val parse : string -> Lex.t -> t 48 | end = 49 | struct 50 | structure L = Lex 51 | 52 | datatype dec_kind = 53 | Ann of string list * dec list 54 | | Basis of (string * exp) list 55 | | File of string 56 | | Functor of (string * string) list 57 | | Local of dec list * dec list 58 | | Open of string list 59 | | Signature of (string * string) list 60 | | Structure of (string * string) list 61 | 62 | and exp_kind = 63 | Bas of dec list 64 | | Id of string 65 | | Let of dec list * exp 66 | 67 | withtype dec = dec_kind * PolyML.location 68 | and exp = exp_kind * PolyML.location 69 | 70 | structure Element = 71 | struct 72 | datatype t = 73 | Dec | Ann | Basis | File | Functor | Local | Open | Signature | Structure 74 | | Exp | Bas | Let 75 | | Id 76 | | Token of Lex.token 77 | | EOF 78 | 79 | fun toString e = 80 | case e of 81 | Dec => "declaration" 82 | | Ann => "annotated declaration" 83 | | Basis => "basis declaration" 84 | | File => "file path" 85 | | Functor => "functor declaration" 86 | | Local => "local/in declaration" 87 | | Open => "open bases" 88 | | Signature => "signature declaration" 89 | | Structure => "structure declaration" 90 | | Exp => "expression" 91 | | Bas => "bas expression" 92 | | Id => "identifier" 93 | | Let => "let/in expression" 94 | | EOF => "EOF" 95 | | Token t => 96 | case t of 97 | L.String _ => L.toString t 98 | | L.Symbol _ => L.toString t 99 | | _ => "'" ^ L.toString t ^ "'" 100 | end 101 | 102 | structure E = Element 103 | 104 | type t = dec list 105 | 106 | type err = 107 | { expected : Element.t list 108 | , found : Element.t 109 | , at : PolyML.location 110 | } list 111 | 112 | exception Parse of err 113 | 114 | fun errToString fmt l = 115 | let 116 | fun str nil = "" 117 | | str [e] = E.toString e 118 | | str [e1, e2] = E.toString e1 ^ " or " ^ E.toString e2 119 | | str e = "one of " ^ String.concatWith ", " (map E.toString e) 120 | fun f ([], r) = r 121 | | f ([{ expected, found, at }], r) = 122 | [ Log.locFmt fmt at, ": error: expected " 123 | , str expected , " but found ", E.toString found, "\n" 124 | ] @ r 125 | | f ({ expected = e, at, ... }::xs, r) = 126 | f (xs, [" parsing ", str e, " at ", Log.locFmt fmt at, "\n"] @ r) 127 | in 128 | (concat o f) (l, []) 129 | end 130 | 131 | local 132 | val isIdChar = 133 | fn #"'" => true 134 | | #"_" => true 135 | | c => Char.isAlphaNum c 136 | 137 | (* todo: mlton only allows $() for path variables 138 | * see: 139 | * https://github.com/MLton/mlton/blob/master/mlton/front-end/mlb.lex#L190 140 | *) 141 | val isPathChar = 142 | fn #"$" => true 143 | | #"(" => true 144 | | #")" => true 145 | | #"." => true 146 | | #"/" => true 147 | | #"-" => true 148 | | #"_" => true 149 | | c => Char.isAlphaNum c 150 | in 151 | fun isId "" = false 152 | | isId s = (Char.isAlpha o String.sub) (s, 0) andalso 153 | CharVector.all isIdChar s 154 | 155 | fun isPath "" = false 156 | | isPath s = CharVector.all isPathChar s 157 | end 158 | 159 | type state = (string * L.position) * (L.token * L.position) list * L.position 160 | 161 | fun getPos (_, (_, l)::_, _) = l 162 | | getPos ((_, l), _, _) = l 163 | 164 | fun getPrevPos (_, _, l) = l 165 | 166 | (* pop next token *) 167 | fun ~ (z, (_, l)::ts, _) = (z, ts, l) 168 | | ~ s = s 169 | 170 | fun == (s1 : state, s2 : state) = 171 | case (#2 s1, #2 s2) of 172 | ([], []) => true 173 | | ((_, l1)::_, (_, l2)::_) => l1 = l2 174 | | _ => false 175 | 176 | infix == 177 | 178 | datatype 'a res = 179 | S of state * 'a * L.position 180 | | F of state * (E.t list * E.t * L.position) list 181 | 182 | fun toExn (((n, _), _, _), l) = 183 | map (fn (e, f, a) => { expected = e, found = f, at = L.toPolyLoc (n, a) }) l 184 | 185 | fun err exp (s as ((_, p), ts, _)) = 186 | case ts of 187 | [] => F (s, [(exp, E.EOF, p)]) 188 | | (t, p)::_ => F (s, [(exp, E.Token t, p)]) 189 | 190 | infix 4 <|> 191 | infix 3 <& <&> &> 192 | infix 2 \ \: 193 | infix 1 194 | infixr $ 195 | 196 | fun f $ x = f x 197 | 198 | (* raise on error *) 199 | fun (p1 e) s = 200 | case p1 s of 201 | z as (S _) => z 202 | | F (_, l) => 203 | let 204 | val x = 205 | case s of 206 | ((_, p), [], _) => (e, E.EOF, p) 207 | | (_, (t, p)::_, _) => (e, E.Token t, p) 208 | in 209 | raise (Parse o toExn) (s, x::l) 210 | end 211 | 212 | (* push error *) 213 | fun (p1 <|> e) s = 214 | case p1 s of 215 | z as (S _) => z 216 | | F (_, l) => 217 | let 218 | val x = 219 | case s of 220 | ((_, p), [], _) => (e, E.EOF, p) 221 | | (_, (t, p)::_, _) => (e, E.Token t, p) 222 | in 223 | F (s, x::l) 224 | end 225 | 226 | (* discard 2nd *) 227 | fun (p1 <& p2) s = 228 | case p1 s of 229 | F z => F z 230 | | S (s, r, l) => 231 | (case p2 s of 232 | F z => F z 233 | | S (s, _, l') => S (s, r, L.joinPos (l, l'))) 234 | 235 | (* discard 1st *) 236 | fun (p1 &> p2) s = 237 | case p1 s of 238 | F z => F z 239 | | S (s, _, l) => 240 | (case p2 s of 241 | F z => F z 242 | | S (s, r, l') => S (s, r, L.joinPos (l, l'))) 243 | 244 | (* combine *) 245 | fun (p1 <&> p2) s = 246 | case p1 s of 247 | F z => F z 248 | | S (s, r, l) => 249 | (case p2 s of 250 | F z => F z 251 | | S (s, r', l') => S (s, (r, r'), L.joinPos (l, l'))) 252 | 253 | (* map *) 254 | fun (p \ f) s = 255 | case p s of 256 | S (s, r, l) => S (s, f r, l) 257 | | F z => F z 258 | 259 | (* map with position *) 260 | fun (p \: f) s = 261 | case p s of 262 | S (s, r, l) => S (s, f (r, L.toPolyLoc ((#1 o #1) s, l)), l) 263 | | F z => F z 264 | 265 | (* maybe, plus and star will propagate failures that accepted at least one 266 | * token, i.e all or nothing. 267 | *) 268 | 269 | fun maybe p s = 270 | case p s of 271 | S (s, r, l) => S (s, SOME r, l) 272 | | F z => if #1 z == s then S (s, NONE, getPrevPos s) else F z 273 | 274 | fun plus p s = 275 | let 276 | fun f (s', rs, l) = 277 | case p s' of 278 | S (s', r, l) => f (s', r::rs, l) 279 | | F z => 280 | if #1 z == s' then S (s', rev rs, L.joinPos (getPos s, l)) else F z 281 | in 282 | case p s of 283 | S (s, r, l) => f (s, [r], l) 284 | | F z => F z 285 | end 286 | 287 | fun star p s = 288 | let 289 | fun f (s', rs, l) = 290 | case p s' of 291 | S (s', r, l) => f (s', r::rs, l) 292 | | F z => 293 | if #1 z == s' then S (s', rev rs, L.joinPos (getPos s, l)) else F z 294 | in 295 | case p s of 296 | S (s, r, l) => f (s, [r], l) 297 | | F z => if #1 z == s then S (s, [], getPrevPos s) else F z 298 | end 299 | 300 | fun skip p s = 301 | let 302 | fun f s' = 303 | case p s' of 304 | S (s', _, _) => f s' 305 | | F z => if #1 z == s' then S (s', (), getPrevPos s) else F z 306 | in 307 | f s 308 | end 309 | 310 | fun ` kw (s as (_, (t, l)::_, _)) = 311 | if kw = t then S (~s, (), l) else err [E.Token kw] s 312 | | ` kw s = err [E.Token kw] s 313 | 314 | fun str s = 315 | case #2 s of 316 | (L.String r, l)::_ => S (~s, r, l) 317 | | _ => err [E.Token (L.String "")] s 318 | 319 | fun id s = 320 | case #2 s of 321 | (L.Symbol r, l)::_ => if isId r then S (~s, r, l) else err [E.Id] s 322 | | _ => err [E.Id] s 323 | 324 | fun binds kw s = 325 | let 326 | fun bind kw = 327 | `kw &> id <&> maybe (`L.Eq &> id) 328 | \ (fn (z, opt) => (z, getOpt (opt, z))) 329 | in 330 | bind kw <&> star (bind L.And) \ op:: $ s 331 | end 332 | 333 | fun basBind s = 334 | let 335 | fun bind kw = `kw &> id <& `L.Eq <&> exp 336 | in 337 | bind L.Basis <&> star (bind L.And) \ Basis o op:: [E.Basis] $ s 338 | end 339 | 340 | and ann s = 341 | `L.Ann &> plus str <& `L.In <|> [E.Token (L.String ""), E.Token L.In] 342 | <&> decs L.End 343 | \ Ann [E.Ann] 344 | $ s 345 | 346 | and file s = 347 | case #2 s of 348 | (L.String r, p)::_ => S (~s, File r, p) 349 | | (L.Symbol r, p)::_ => 350 | if isPath r then S (~s, File r, p) else err [E.File] s 351 | | _ => err [E.File] s 352 | 353 | and funBind s = binds L.Functor \ Functor [E.Functor] $ s 354 | 355 | and localIn s = 356 | `L.Local &> decs L.In <&> decs L.End \ Local [E.Local] $ s 357 | 358 | and openBas s = `L.Open &> plus id \ Open [E.Open] $ s 359 | 360 | and sigBind s = binds L.Signature \ Signature [E.Signature] $ s 361 | 362 | and strBind s = binds L.Structure \ Structure [E.Structure] $ s 363 | 364 | and dec s = 365 | skip (`L.Semi) &> (fn s => 366 | (case #2 s of 367 | [] => err [E.Dec] 368 | | t::_ => 369 | (case t of 370 | (L.Ann, _) => ann 371 | | (L.Basis, _) => basBind 372 | | (L.Functor, _) => funBind 373 | | (L.Local, _) => localIn 374 | | (L.Open, _) => openBas 375 | | (L.Signature, _) => sigBind 376 | | (L.Structure, _) => strBind 377 | | (L.String _, _) => file 378 | | (L.Symbol _, _) => file 379 | | _ => fn _ => F (s, [])) <|> [E.Dec] 380 | \: (fn z => z)) 381 | $ s) <& skip (`L.Semi) 382 | $ s 383 | 384 | and decs kw s = star dec <& `kw <|> [E.Dec, E.Token kw] $ s 385 | 386 | and basExp s = `L.Bas &> decs L.End \ Bas [E.Bas] $ s 387 | 388 | and letIn s = `L.Let &> decs L.In <&> exp <& `L.End \ Let [E.Let] $ s 389 | 390 | and basId s = id \ Id $ s 391 | 392 | and exp s = 393 | (case #2 s of 394 | [] => err [E.Exp] 395 | | t::_ => 396 | (case t of 397 | (L.Bas, _) => basExp 398 | | (L.Let, _) => letIn 399 | | (L.Symbol _, _) => basId 400 | | _ => fn _ => F (s, [])) <|> [E.Exp] 401 | \: (fn z => z)) 402 | $ s 403 | 404 | fun parse name (tokens, { start, eof }) = 405 | case star dec ((name, eof), tokens, start) of 406 | F z => raise Parse (toExn z) 407 | | S (s, r, _) => 408 | (case #2 s of 409 | [] => r 410 | | (t, p)::_ => raise (Parse o toExn) (s, [([E.Dec], E.Token t, p)])) 411 | end 412 | -------------------------------------------------------------------------------- /src/lib/ThreadPools/PrioQueue.fun: -------------------------------------------------------------------------------- 1 | (* Skiplist priority queue from "Skiplist-based concurrent priority queues", 2 | * Itay Lotan and Nir Shavit. 3 | * 4 | * The usual level distribution of 1/2 is used, with a maximum level of 8. 5 | * If needed, this arbitrary limit may be raised simply by modifying the 6 | * maxLevel value. 7 | * This implementation allows for elements with the same priority to be stored 8 | * within the same node upto a certain capacity unless the existing node is 9 | * logically deleted at the time of insertion. If a new element cannot be 10 | * added to any existing node with the corresponding priority, a new node is 11 | * inserted _after_ all other nodes with the same priority. A node is considered 12 | * to be logically deleted when its element count reaches zero. 13 | * Thus dequeueing is simply traversing the lowest level (0) until a non empty 14 | * node is found, then its count is decreased by 1 and the element is retrieved. 15 | * If the updated count is zero, then the node is physically deleted from the 16 | * list. 17 | * Locking as well as capacity checks are implemented with a bitset of size 18 | * usedBits: 19 | * - the low maxLevel bits are used to lock forward pointers 20 | * (level n is considered to be locked if 1 << n is set); 21 | * - the next bit (maxLevel + 1) is the fullLock bit for insertion and deletion; 22 | * - the remaining high bits contain the capacity. 23 | * The capacity is always stored in the high bits, regardless of the word size. 24 | * E.g with usedBits = 31, maxLevel = 8 and a word size of 63, there is a 32 bit 25 | * gap in the middle of the bitset: 26 | * [22 bit capacity | 32 bit empty | 1 bit fullLock | 8 bit level locks] = 63. 27 | * 28 | * see: 29 | * https://people.csail.mit.edu/shanir/publications/Priority_Queues.pdf 30 | * https://dl.acm.org/doi/pdf/10.1145/78973.78977 31 | *) 32 | functor PrioQueue (type elt) :> QUEUE 33 | where type inc = FixedInt.int * elt and type outc = elt = 34 | struct 35 | structure A = Array 36 | structure C = Thread.ConditionVar 37 | structure M = Thread.Mutex 38 | 39 | type inc = FixedInt.int * elt 40 | type outc = elt 41 | 42 | (* The tail node is a regular node that has a piority of Int.minInt; this 43 | * makes the overall code much cleaner since we can just check priorities 44 | * rather than casing each forward pointer 45 | * `case A.sub (a, i) of N _ => ... | _ => ()` 46 | *) 47 | datatype t = 48 | N of 49 | { p : FixedInt.int 50 | , v : elt list ref 51 | , a : t array 52 | , m : M.mutex 53 | , c : C.conditionVar 54 | , w : Word.word ref 55 | } 56 | 57 | infix 8 `& `| `^ << >> 58 | 59 | val usedBits = 31 60 | val maxLevel = 8 61 | val fullLock = maxLevel + 1 62 | val maxItems = Word.<< (0w1, Word.fromInt (usedBits - fullLock)) - 0w1 63 | 64 | (* Threadsafe biased RNG, 1/2 distribution from 1 to maxLevel. 65 | * 66 | * The generator used is pcg16; generator state is thread local. Rather than 67 | * the `while (rng () < 0.5) i++` in Pugh's paper, we generate 16 bits once 68 | * and keep only the low maxLevel bits, discarding the rest. 69 | * 70 | * see: 71 | * http://www.pcg-random.org 72 | * https://github.com/imneme/pcg-c 73 | *) 74 | local 75 | structure T = Thread.Thread 76 | 77 | val op<< = Word16.<< 78 | val op>> = Word16.>> 79 | val op`& = Word16.andb 80 | val op`^ = Word16.xorb 81 | val ~ = Word16.~ 82 | 83 | val mask = (0w1 << Word.fromInt maxLevel) - 0w1 84 | val t : Word16.word ref Universal.tag = Universal.tag () 85 | 86 | local 87 | (* https://www.chessprogramming.org/Population_Count#The_PopCount_routine *) 88 | fun popcnt w = 89 | let 90 | val w = w - ((w >> 0w1) `& 0wx5555) 91 | val w = (w `& 0wx3333) + ((w >> 0w2) `& 0wx3333) 92 | in 93 | (((w + (w >> 0w4)) `& 0wxF0F) * 0wx101) >> 0w8 94 | end 95 | 96 | (* https://www.chessprogramming.org/BitScan#Index_of_LS1B_by_Popcount *) 97 | fun ctz 0w0 = 0w0 98 | | ctz w = popcnt ((w `& ~w) - 0w1) 99 | 100 | (* Since the output size is 8 bits, i.e 256 possible values, we simply use 101 | * a lookup table for ctz. 102 | *) 103 | val counts = Word8Vector.tabulate 104 | ( Word16.toInt mask + 1 105 | , Word8.fromLarge o Word16.toLarge o ctz o Word16.fromInt 106 | ) 107 | in 108 | fun biased w = Word8Vector.sub (counts, Word16.toInt w) 109 | end 110 | 111 | val tow = Word.fromLarge o Word16.toLarge 112 | 113 | (* pcg_oneseq_16_rxs_m_xs_16_random_r *) 114 | fun next (r as ref w) = 115 | let 116 | (* pcg_oneseq_16_step_r *) 117 | val _ = r := w * 0w12829 + 0w47989 118 | (* pcg_output_rxs_m_xs_16_16 *) 119 | val w = ((w >> tow ((w >> 0w13) + 0w3)) `^ w) * 0w62169 120 | in 121 | (w >> 0w11) `^ w 122 | end 123 | 124 | fun new () = 125 | (ref o Word16.fromInt o Int.fromLarge o Time.toMicroseconds o Time.now) () 126 | in 127 | fun rand () = 128 | let 129 | val r = 130 | case T.getLocal t of 131 | SOME r => r 132 | | NONE => let val r = new () in T.setLocal (t, r); r end 133 | in 134 | (Word8.toInt o biased) (next r `& mask) + 1 135 | end 136 | end 137 | 138 | val op`& = Word.andb 139 | val op`| = Word.orb 140 | val op`^ = Word.xorb 141 | val op<< = Word.<< 142 | val op>> = Word.>> 143 | val `~ = Word.notb (* /!\ *) 144 | val ~ = Word.~ (* /!\ *) 145 | 146 | fun new () : t = 147 | let 148 | val tl = 149 | N { p = valOf FixedInt.minInt, v = ref [], a = A.fromList [] 150 | , m = M.mutex (), c = C.conditionVar (), w = ref 0w0 151 | } 152 | in 153 | N { p = valOf FixedInt.maxInt, v = ref [], a = A.array (maxLevel, tl) 154 | , m = M.mutex (), c = C.conditionVar (), w = ref 0w0 155 | } 156 | end 157 | 158 | fun getp (N { p, ... }) = p 159 | fun getv (N { v, ... }) = v 160 | fun getn (N { a, ... }, i) = A.sub (a, i) 161 | 162 | local 163 | val min = valOf FixedInt.minInt 164 | val max = valOf FixedInt.maxInt 165 | in 166 | fun istl (N { p, ... }) = p = min 167 | fun ishd (N { p, ... }) = p = max 168 | end 169 | 170 | local 171 | val wpos = Word.fromInt (Word.wordSize - (usedBits - fullLock)) 172 | val wlm = (0w1 << wpos) - 0w1 173 | in 174 | fun getb w = w `& wlm 175 | fun getc w = w >> wpos 176 | (* overflow warning: callers must check for w > 0 or w < maxItems *) 177 | fun incr w = ((getc w + 0w1) << wpos) + getb w 178 | fun decr w = ((getc w - 0w1) << wpos) + getb w 179 | 180 | fun setDel (N { w, m, ... }) = 181 | if !w >> wpos = 0w0 then 182 | false 183 | else if (M.lock m; !w >> wpos = 0w0) then 184 | (M.unlock m; false) 185 | else 186 | (w := decr (!w); M.unlock m; true) 187 | 188 | fun lock (N { w, m, c, ... }, i) = 189 | let 190 | val w' = 0w1 << Word.fromInt i 191 | in 192 | M.lock m; 193 | while !w `& w' <> 0w0 do 194 | C.wait (c, m); 195 | w := !w `| w'; 196 | M.unlock m 197 | end 198 | 199 | fun unlock (N { w, m, c,... }, i) = 200 | let 201 | val w' = 0w1 << Word.fromInt i 202 | in 203 | M.lock m; 204 | w := !w `& `~w'; 205 | M.unlock m; 206 | C.broadcast c 207 | end 208 | end 209 | 210 | fun getLock { n, p, i } = 211 | let 212 | fun f1 (n1, n2) = if getp n2 < p then n1 else f1 (n2, getn (n1, i)) 213 | 214 | fun f2 (n1, n2) = 215 | if getp n2 < p then 216 | n1 217 | else 218 | (unlock (n1, i); lock (n2, i); f2 (n2, getn (n1, i))) 219 | 220 | val n1 = f1 (n, getn (n, i)) 221 | in 222 | lock (n1, i); 223 | f2 (n1, getn (n1, i)) 224 | end 225 | 226 | local 227 | fun fd (n1, n2, p, i) = 228 | if getp n2 < p then 229 | (n1, n2) 230 | else 231 | fd (n2, getn (n1, i), p, i) 232 | in 233 | fun preds (n, xp) = 234 | let 235 | val b = A.array (maxLevel, n) 236 | fun f (~1, n1, _) = n1 237 | | f (i, n1, n2) = 238 | let 239 | val (n1, n2) = fd (n1, n2, xp, i) 240 | in 241 | A.update (b, i, n1); 242 | f (i - 1, n1, n2) 243 | end 244 | in 245 | (b, f (maxLevel - 1, n, n)) 246 | end 247 | end 248 | 249 | fun link { b, n' as N { a = a', p, ... }, n1 } = 250 | let 251 | val l = A.length a' 252 | fun f i = 253 | if i = l then 254 | () 255 | else 256 | let 257 | val n as N { a, ... } = 258 | case (i, n1) of 259 | (0, SOME z) => z 260 | | _ => getLock { n = A.sub (b, i), p = p, i = i } 261 | in 262 | lock (n', i); 263 | A.update (a', i, A.sub (a, i)); 264 | A.update (a, i, n'); 265 | unlock (n', i); 266 | unlock (n, i); 267 | f (i + 1) 268 | end 269 | in 270 | lock (n', fullLock); 271 | f 0; 272 | unlock (n', fullLock) 273 | end 274 | 275 | fun enq (hd, (xp, xv)) = 276 | let 277 | val (b, n) = preds (hd, xp) 278 | val n1 as N { p, v, w, m, ... } = getLock { n = n, i = 0, p = xp } 279 | in 280 | if p = xp then 281 | let 282 | val w' = (M.lock m; getc (!w)) 283 | in 284 | if w' = 0w0 orelse w' = maxItems then 285 | let 286 | val _ = M.unlock m 287 | val n' = 288 | N { p = xp, v = ref [xv], a = A.array (rand (), hd) 289 | , m = M.mutex (), c = C.conditionVar (), w = ref (incr 0w0) 290 | } 291 | in 292 | link { b = b, n' = n', n1 = SOME n1 } 293 | end 294 | else 295 | ( v := xv :: !v 296 | ; w := incr (!w) 297 | ; M.unlock m 298 | ; unlock (n1, 0) 299 | ) 300 | end 301 | else 302 | let 303 | val n' = 304 | N { p = xp, v = ref [xv], a = A.array (rand (), hd), m = M.mutex () 305 | , c = C.conditionVar (), w = ref (incr 0w0) 306 | } 307 | in 308 | link { b = b, n' = n', n1 = SOME n1 } 309 | end 310 | end 311 | 312 | fun getLock { n, p, i, v } = 313 | let 314 | fun f1 (n1, n2) = 315 | if getp n2 > p orelse (getp n2 = p andalso getv n2 <> v) then 316 | f1 (n2, getn (n1, i)) 317 | else 318 | n1 319 | 320 | fun f2 (n1, n2) = 321 | if getp n2 > p orelse (getp n2 = p andalso getv n2 <> v) then 322 | (unlock (n1, i); lock (n2, i); f2 (n2, getn (n1, i))) 323 | else 324 | n1 325 | 326 | val n1 = f1 (n, getn (n, i)) 327 | in 328 | lock (n1, i); 329 | f2 (n1, getn (n1, i)) 330 | end 331 | 332 | local 333 | fun fd (n1, n2, p, v, i) = 334 | if getp n2 > p orelse (getp n2 = p andalso getv n2 <> v) then 335 | fd (n2, getn (n1, i), p, v, i) 336 | else 337 | (n1, n2) 338 | in 339 | fun preds (n, xp, xv) = 340 | let 341 | val b = A.array (maxLevel, n) 342 | fun f (~1, n1, _) = n1 343 | | f (i, n1, n2) = 344 | let 345 | val (n1, n2) = fd (n1, n2, xp, xv, i) 346 | in 347 | A.update (b, i, n1); 348 | f (i - 1, n1, n2) 349 | end 350 | in 351 | (b, f (maxLevel - 1, n, n)) 352 | end 353 | end 354 | 355 | fun find n = 356 | if istl n then 357 | n 358 | else if setDel n then 359 | n 360 | else 361 | find (getn (n, 0)) 362 | 363 | fun del (b, n as N { a, p, v, ... }) = 364 | let 365 | fun f ~1 = () 366 | | f i = 367 | let 368 | val n' as N { a = a', ... } = 369 | getLock { n = A.sub (b, i), i = i, p = p, v = v } 370 | in 371 | lock (n, i); 372 | A.update (a', i, A.sub (a, i)); 373 | A.update (a, i, n'); 374 | unlock (n, i); 375 | unlock (n', i); 376 | f (i - 1) 377 | end 378 | in 379 | lock (n, fullLock); 380 | f (A.length a - 1); 381 | unlock (n, fullLock) 382 | end 383 | 384 | fun deq hd = 385 | let 386 | val n as N { p, v, m, ... } = (find o getn) (hd, 0) 387 | in 388 | if istl n then 389 | NONE 390 | else 391 | case (M.lock m; !v) of 392 | [] => (M.unlock m; raise Fail "Prio.deq: impossible") 393 | | x::(xs as _::_) => (v := xs; M.unlock m; SOME x) 394 | | [v'] => 395 | let 396 | val _ = v := [] 397 | val _ = M.unlock m 398 | val (b, n) = preds (hd, p, v) 399 | 400 | fun f (n as N { p = p', v = v', ... }) = 401 | if p' = p andalso v = v' then 402 | n 403 | else 404 | (f o getn) (n, 0) 405 | in 406 | del (b, f n); 407 | SOME v' 408 | end 409 | end 410 | end 411 | -------------------------------------------------------------------------------- /src/lib/Dag.sml: -------------------------------------------------------------------------------- 1 | structure Dag : 2 | sig 3 | datatype node = N of int * node vector 4 | 5 | type dag = { root : node, leaves : node vector } 6 | 7 | (* The root basis has an id of 0. *) 8 | type t = 9 | (* potentially reduced *) 10 | { dag : dag 11 | , full : dag 12 | , bases : Basis.t vector 13 | , paths : string vector 14 | (* raises on invalid path *) 15 | , getId : string -> int 16 | } 17 | 18 | datatype err = Cycle of string list 19 | 20 | exception Dag of err 21 | 22 | val errToString : (string -> string) -> err -> string 23 | 24 | type opts = 25 | { logger : Log.logger option 26 | , reduce : bool 27 | } 28 | 29 | (* Traverse and reduce to a minimal equivalent the DAG formed by having the 30 | * given basis as root and all other bases which are transitively reachable 31 | * through basis file imports. 32 | * Declarations annotated with Discard are completely ignored, 33 | * as well as MLB files which match an enclosing IgnoreFiles annotation. 34 | * If a cycle is found, then a Dag exception is raised. 35 | * The given function takes in the absolute path of an mlb file and must 36 | * return its content. 37 | *) 38 | val process : opts -> (string -> Basis.t) -> string -> t 39 | end = 40 | struct 41 | structure A = Array 42 | structure AS = ArraySlice 43 | structure BA = BoolArray 44 | structure H = HashArray 45 | structure L = List 46 | structure V = Vector 47 | 48 | datatype node = N of int * node vector 49 | 50 | type dag = { root : node, leaves : node vector } 51 | 52 | type t = 53 | { dag : dag 54 | , full : dag 55 | , bases : Basis.t vector 56 | , paths : string vector 57 | , getId : string -> int 58 | } 59 | 60 | datatype err = Cycle of string list 61 | 62 | exception Dag of err 63 | 64 | fun errToString fmt (Cycle l) = 65 | concat 66 | ("error: mlb cycle:\n" :: List.concat (map (fn s => [" ", s, "\n"]) l)) 67 | 68 | type opts = 69 | { logger : Log.logger option 70 | , reduce : bool 71 | } 72 | 73 | structure Buffer :> 74 | sig 75 | type 'a t 76 | 77 | val new : int * 'a -> 'a t 78 | val cnt : 'a t -> int 79 | 80 | val add : 'a t * 'a -> unit 81 | val sub : 'a t * int -> 'a 82 | val set : 'a t * int * 'a -> unit 83 | val clear : 'a t -> unit 84 | val addIfAbsent : ('a * 'a -> bool) -> 'a t * 'a -> unit 85 | 86 | val slice : 'a t -> 'a AS.slice 87 | val array : 'a t -> 'a array 88 | val vec : 'a t -> 'a vector 89 | end = 90 | struct 91 | type 'a t = int ref * 'a * 'a array ref 92 | 93 | fun new (i, x) = (ref 0, x, (ref o A.array) (i, x)) 94 | 95 | fun cnt (ref i, _, _) = i 96 | 97 | fun resize ((ri, x, ra as ref a), n) = 98 | let 99 | val a' = A.array (Int.max (A.length a * 2, n), x) 100 | in 101 | AS.copy { src = AS.slice (a, 0, SOME (!ri)), dst = a', di = 0 }; 102 | ra := a'; 103 | () 104 | end 105 | 106 | fun add (t as (ri, _, ra), x) = 107 | ( if !ri = A.length (!ra) then resize (t, 1) else () 108 | ; A.update (!ra, !ri, x) 109 | ; ri := !ri + 1 110 | ) 111 | 112 | fun sub ((_, _, ref a), i) = A.sub (a, i) 113 | 114 | fun set (t as (ri, _, ra), i, x) = 115 | ( if i >= A.length (!ra) then resize (t, i + 1) else () 116 | ; A.update (!ra, i, x) 117 | ; ri := Int.max (!ri, i) + 1 118 | ) 119 | 120 | fun addIfAbsent eq (t as (ref i, _, ref a), x) = 121 | let 122 | fun f j = i <> j andalso (eq (x, A.sub (a, j)) orelse f (j + 1)) 123 | in 124 | if f 0 then 125 | () 126 | else 127 | add (t, x) 128 | end 129 | 130 | fun slice (ref i, _, ref a) = AS.slice (a, 0, SOME i) 131 | 132 | fun array (ref i, _, ref a) = A.tabulate (i, fn j => A.sub (a, j)) 133 | 134 | fun vec z = AS.vector (slice z) 135 | 136 | fun clear (t as (ri, x, _)) = (AS.modify (fn _ => x) (slice t); ri := 0) 137 | end 138 | 139 | structure Set :> 140 | sig 141 | type t 142 | val new : int -> t 143 | val sub : t * int -> bool 144 | val set : t * int -> unit 145 | val del : t * int -> unit 146 | val clear : t -> unit 147 | end = 148 | struct 149 | type t = BA.array 150 | fun new i = BA.array (i, false) 151 | val sub = BA.sub 152 | fun set (a, i) = BA.update (a, i, true) 153 | fun del (a, i) = BA.update (a, i, false) 154 | val clear = BA.modify (fn _ => false) 155 | end 156 | 157 | structure Matrix :> 158 | sig 159 | type t 160 | val new : int -> t 161 | val sub : t * int * int -> bool 162 | val set : t * int * int -> unit 163 | val del : t * int * int -> unit 164 | val clear : t -> unit 165 | end = 166 | struct 167 | (* use BoolArray over BoolArray2 because the latter does not seem to have 168 | * a packed representation 169 | *) 170 | type t = int * BA.array 171 | fun new i = (i, BA.array (i * i, false)) 172 | fun sub ((c, a), i, j) = BA.sub (a, i * c + j) 173 | fun set ((c, a), i, j) = BA.update (a, i * c + j, true) 174 | fun del ((c, a), i, j) = BA.update (a, i * c + j, false) 175 | fun clear (_, a) = BA.modify (fn _ => false) a 176 | end 177 | 178 | structure B = Buffer 179 | structure S = Set 180 | structure M = Matrix 181 | 182 | fun index (l, s) = 183 | let 184 | fun idx ([], _) = ~1 185 | | idx (x::xs, i) = if x = s then i else idx (xs, i + 1) 186 | in 187 | idx (l, 0) 188 | end 189 | 190 | datatype z = datatype Basis.dec 191 | datatype z = datatype Basis.exp 192 | 193 | val baseSize = 10 194 | 195 | (* Depth first so that any cycle found is the first one when reading 196 | * sequentially from the root. 197 | *) 198 | fun traverse (getBas, root) = 199 | let 200 | val bases : Basis.t B.t = B.new (baseSize * 2, []) 201 | val paths : string B.t = B.new (baseSize * 2, "") 202 | val ids : int H.hash = H.hash (baseSize * 2) 203 | val deps = B.new (baseSize, B.new (0, ~1)) 204 | val revs = B.new (baseSize, B.new (0, ~1)) 205 | 206 | fun dec ([], _, _, _) = () 207 | | dec (Basis (_, e) :: ds, id, ps, is) = 208 | (exp (e, id, ps, is); dec (ds, id, ps, is)) 209 | | dec (BasisFile p :: ds, id, ps, is) = 210 | if L.exists (fn p' => p = p') is then 211 | dec (ds, id, ps, is) 212 | else 213 | let 214 | val id' = 215 | case H.sub (ids, p) of 216 | SOME id => 217 | (case index (ps, p) of 218 | ~1 => id 219 | | i => raise (Dag o Cycle) (p :: (rev o L.take) (ps, i))) 220 | | NONE => 221 | let 222 | val ds' = getBas p 223 | val id' = B.cnt bases 224 | in 225 | H.update (ids, p, id'); 226 | B.add (paths, p); 227 | B.add (deps, B.new (id' + 1, ~1)); 228 | B.add (revs, B.new (id' + 1, ~1)); 229 | B.add (bases, ds'); 230 | dec (ds', id', p::ps, []); 231 | id' 232 | end 233 | in 234 | B.addIfAbsent op= (B.sub (deps, id), id'); 235 | B.addIfAbsent op= (B.sub (revs, id'), id); 236 | dec (ds, id, ps, is) 237 | end 238 | | dec (Ann (l, ds') :: ds, id, ps, is) = 239 | ( if Ann.exists Ann.Discard l then 240 | () 241 | else 242 | dec (ds', id, ps, 243 | L.foldl 244 | (fn (Ann.IgnoreFiles f, fs) => f @ fs | (_, fs) => fs) 245 | is l) 246 | ; dec (ds, id, ps, is) 247 | ) 248 | | dec (Local (ds1, ds2) :: ds, id, ps, is) = 249 | (dec (ds1, id, ps, is); dec (ds2, id, ps, is); dec (ds, id, ps, is)) 250 | | dec (_::ds, id, ps, is) = dec (ds, id, ps, is) 251 | 252 | and exp (Bas ds, id, ps, is) = dec (ds, id, ps, is) 253 | | exp (Let (ds, e), id, ps, is) = (dec (ds, id, ps, is); exp (e, id, ps, is)) 254 | | exp (Id _, _, _, _) = () 255 | 256 | val bas = getBas root 257 | in 258 | H.update (ids, root, 0); 259 | B.set (bases, 0, bas); 260 | B.set (paths, 0, root); 261 | B.set (deps, 0, B.new (baseSize, ~1)); 262 | B.set (revs, 0, B.new (baseSize, ~1)); 263 | dec (bas, 0, [root], []); 264 | 265 | { bases = B.vec bases 266 | , paths = B.vec paths 267 | , ids = ids 268 | , deps = deps 269 | , revs = revs 270 | } 271 | end 272 | 273 | (* Hsu's algorithm for transitive reduction; "An algorithm for finding a 274 | * minimal equivalent graph of a digraph", ACM, 22(1):11-16. 275 | * See: 276 | * https://projects.csail.mit.edu/jacm/References/hsu1975:11.html 277 | * https://dl.acm.org/doi/10.1145/321864.321866 278 | * https://stackoverflow.com/a/16357676 279 | *) 280 | local 281 | fun loop n f = 282 | let 283 | fun loop' i = if i = n then () else (f i; loop' (i + 1)) 284 | in 285 | loop' 0 286 | end 287 | in 288 | fun reduce { sz, deps, revs } : unit = 289 | let 290 | val m = M.new sz 291 | val s = S.new sz 292 | 293 | fun init id = 294 | if (not o S.sub) (s, id) then 295 | ( S.set (s, id) 296 | ; (B.clear o B.sub) (revs, id) 297 | ; ( AS.app (fn id' => (M.set (m, id, id'); init id')) 298 | o B.slice 299 | o B.sub 300 | ) (deps, id) 301 | ) 302 | else 303 | () 304 | 305 | fun update id = 306 | if (not o S.sub) (s, id) then 307 | let 308 | val b = B.sub (deps, id) 309 | val l = AS.foldr 310 | (fn (id', ids) => if M.sub (m, id, id') then id'::ids else ids) 311 | [] (B.slice b) 312 | in 313 | S.set (s, id); 314 | B.clear b; 315 | app (fn id' => 316 | ( B.add (b, id') 317 | ; B.add (B.sub (revs, id'), id) 318 | ; update id' 319 | )) l 320 | end 321 | else 322 | () 323 | in 324 | (* construct edge matrix *) 325 | init 0; 326 | S.clear s; 327 | 328 | (* transform edge- into path matrix *) 329 | loop sz (fn i => 330 | loop sz (fn j => 331 | if i = j orelse (not o M.sub) (m, j, i) then 332 | () 333 | else 334 | loop sz (fn k => 335 | if (not o M.sub) (m, j, k) andalso M.sub (m, i, k) then 336 | M.set (m, j, k) 337 | else 338 | ()))); 339 | 340 | (* unset unwanted edges *) 341 | loop sz (fn j => 342 | loop sz (fn i => 343 | if M.sub (m, i, j) then 344 | loop sz (fn k => 345 | if M.sub (m, j, k) then 346 | M.del (m, i, k) 347 | else 348 | ()) 349 | else 350 | ())); 351 | 352 | (* delete from the graph *) 353 | update 0 354 | end 355 | end 356 | 357 | local 358 | val dummy = N (~1, V.fromList []) 359 | fun isDummy (N (i, _)) = i = ~1 360 | in 361 | fun mkDag { sz, deps, revs } : dag = 362 | let 363 | val ndeps = A.array (sz, dummy) 364 | val nrevs = A.array (sz, dummy) 365 | val leaves = B.new (baseSize, ~1) 366 | 367 | fun dep id = 368 | if (not o isDummy o A.sub) (ndeps, id) then 369 | A.sub (ndeps, id) 370 | else 371 | let 372 | val n as N (_, v) = 373 | N ( id 374 | , let 375 | val b = B.sub (deps, id) 376 | in 377 | V.tabulate (B.cnt b, fn i => (dep o B.sub) (b, i)) 378 | end 379 | ) 380 | in 381 | A.update (ndeps, id, n); 382 | if V.length v = 0 then B.add (leaves, id) else (); 383 | n 384 | end 385 | 386 | fun rev id = 387 | if (not o isDummy o A.sub) (nrevs, id) then 388 | A.sub (nrevs, id) 389 | else 390 | let 391 | val n = 392 | N ( id 393 | , let 394 | val b = B.sub (revs, id) 395 | in 396 | V.tabulate (B.cnt b, fn i => (rev o B.sub) (b, i)) 397 | end 398 | ) 399 | in 400 | A.update (nrevs, id, n); 401 | n 402 | end 403 | in 404 | { root = dep 0 405 | , leaves = V.tabulate (B.cnt leaves, fn i => (rev o B.sub) (leaves, i)) 406 | } 407 | end 408 | end 409 | 410 | fun process { logger, reduce = red } f s = 411 | let 412 | val log = Log.log logger Log.Debug 413 | fun parse s = (log (fn fmt => "parsing " ^ fmt s); f s) 414 | 415 | val { bases, paths, ids, deps, revs } = 416 | (log (fn _ => "traversing MLB graph"); traverse (parse, s)) 417 | val bs = { sz = V.length bases, deps = deps, revs = revs } 418 | val full = (log (fn _ => "building MLBgraph"); mkDag bs) 419 | val dag = 420 | if not red then 421 | full 422 | else 423 | ( log (fn _ => "reducing MLB graph") 424 | ; reduce bs 425 | ; log (fn _ => "building reduced MLB graph") 426 | ; mkDag bs 427 | ) 428 | in 429 | { dag = dag 430 | , full = full 431 | , bases = bases 432 | , paths = paths 433 | , getId = fn s => (valOf o H.sub) (ids, s) 434 | } 435 | end 436 | end 437 | -------------------------------------------------------------------------------- /src/lib/NameSpace.sml: -------------------------------------------------------------------------------- 1 | structure NameSpace : 2 | sig 3 | (* A basis namespace; i.e a regular PolyML namespace augmented with bases 4 | * operations. Not threadsafe. 5 | *) 6 | datatype t = N of 7 | { allBas : unit -> (string * t) list 8 | , enterBas : (string * t) -> unit 9 | , lookupBas : string -> t option 10 | } * PolyML.NameSpace.nameSpace 11 | 12 | (* Wrapper over PolyML.globlalNameSpace; can be imported into. *) 13 | val global : t 14 | 15 | (* Read only namespace of the basis library. 16 | * $(SML_LIB)/basis/basis.mlb 17 | *) 18 | val basis : t 19 | 20 | (* Read only namespace of the PolyML extensions (PolyML, Thread, etc). 21 | * $(SML_LIB)/basis/poly.mlb 22 | *) 23 | val poly : t 24 | 25 | (* Read only namespace that contains everything as well as the basis and poly 26 | * namespaces under the names "BasisLib" and "PolyLib". 27 | *) 28 | val all : t 29 | 30 | val empty : unit -> t 31 | 32 | val import : { src : t, dst : t } -> unit 33 | 34 | (* Given a base namespace: 35 | * - reading from loc searches in base if no result 36 | * - writing to loc only writes to loc 37 | * - reading from pub searches in loc (which in turns searches in base) 38 | * - writing to pub also writes to base 39 | *) 40 | val delegates : t -> { loc : t, pub : t } 41 | end = 42 | struct 43 | structure H = HashArray 44 | structure L = List 45 | structure N = PolyML.NameSpace 46 | 47 | datatype t = N of 48 | { allBas : unit -> (string * t) list 49 | , enterBas : (string * t) -> unit 50 | , lookupBas : string -> t option 51 | } * PolyML.NameSpace.nameSpace 52 | 53 | val pgns = PolyML.globalNameSpace 54 | 55 | type 'a fns = 56 | (unit -> (string * 'a) list) 57 | * (string * 'a -> unit) 58 | * (string -> 'a option) 59 | 60 | fun fns () : 'a fns = 61 | let 62 | val h : 'a H.hash = H.hash 20 63 | in 64 | ( fn () => H.fold (fn (s, v, l) => (s, v)::l) [] h 65 | , fn (s, v) => H.update (h, s, v) 66 | , fn s => H.sub (h, s) 67 | ) 68 | end 69 | 70 | val global = 71 | let 72 | val (aBas, eBas, lBas) : t fns = fns () 73 | in 74 | N ({ allBas = aBas, lookupBas = lBas, enterBas = eBas }, pgns) 75 | end 76 | 77 | local 78 | (* Copy over only known basis / poly identifiers; this avoids leaking 79 | * whatever else may be defined at the top level at build time (e.g the 80 | * various PolyMLB substructures). 81 | *) 82 | 83 | (* https://smlfamily.github.io/Basis/top-level-chapter.html#section:4 *) 84 | val basisFixs = 85 | [ "*", "/", "div", "mod", "+", "-", "^", "::", "@", "=", "<>", ">", ">=" 86 | , "<", "<=", ":=", "o", "before" 87 | ] 88 | 89 | (* https://smlfamily.github.io/Basis/overview.html#section:17 *) 90 | val basisFcts = ["ImperativeIO", "PrimIO", "StreamIO"] 91 | 92 | (* https://smlfamily.github.io/Basis/overview.html#section:12 93 | * https://smlfamily.github.io/Basis/overview.html#section:15 94 | *) 95 | val basisSigs = 96 | [ "ARRAY", "ARRAY_SLICE", "BIN_IO", "BOOL", "BYTE", "CHAR", "COMMAND_LINE" 97 | , "DATE", "GENERAL", "IEEE_REAL", "IMPERATIVE_IO", "INTEGER", "IO", "LIST" 98 | , "LIST_PAIR", "MATH", "MONO_ARRAY", "MONO_ARRAY_SLICE", "MONO_VECTOR" 99 | , "MONO_VECTOR_SLICE", "OPTION", "OS", "OS_FILE_SYS", "OS_IO", "OS_PATH" 100 | , "OS_PROCESS", "PRIM_IO" , "REAL", "STREAM_IO", "STRING", "STRING_CVT" 101 | , "SUBSTRING", "TEXT", "TEXT_IO", "TEXT_STREAM_IO", "TIME", "TIMER" 102 | , "VECTOR", "VECTOR_SLICE", "WORD" 103 | ] @ 104 | [ "ARRAY2", "BIT_FLAGS", "GENERIC_SOCK", "INET_SOCK", "INT_INF" 105 | , "MONO_ARRAY2", "NET_HOST_DB", "NET_PROT_DB", "NET_SERV_DB", "PACK_REAL" 106 | , "PACK_WORD", "POSIX", "POSIX_ERROR", "POSIX_FILE_SYS", "POSIX_IO" 107 | , "POSIX_PROC_ENV", "POSIX_PROCESS", "POSIX_SIGNAL", "POSIX_SYS_DB" 108 | , "POSIX_TTY", "SOCKET", "UNIX", "UNIX_SOCK", "WINDOWS" 109 | ] 110 | 111 | (* https://smlfamily.github.io/Basis/overview.html#section:13 112 | * https://smlfamily.github.io/Basis/overview.html#section:16 113 | *) 114 | val basisStrs = 115 | let 116 | fun nStructs i = 117 | let 118 | val i = Int.toString i 119 | val int = "Int" ^ i 120 | val real = "Real" ^ i 121 | val word = "Word" ^ i 122 | in 123 | [ int ^ "Array", int ^ "Array2", int ^ "ArraySlice", int 124 | , int ^ "Vector", int ^ "VectorSlice", "PackWord" ^ i ^ "Big" 125 | , "PackWord" ^ i ^ "Little" , "PackReal" ^ i ^ "Big" 126 | , "PackReal" ^ i ^ "Little", real ^ "Array", real ^ "Array2" 127 | , real ^ "ArraySlice", real, real ^ "Vector", real ^ "VectorSlice" 128 | , word ^ "Array", word ^ "Array2" , word ^ "ArraySlice" 129 | , word ^ "Vector", word ^ "VectorSlice", word 130 | ] 131 | end 132 | in 133 | [ "Array", "ArraySlice", "BinIO", "BinPrimIO", "Bool", "Byte" 134 | , "CharArray", "CharArraySlice", "Char", "CharVector", "CharVectorSlice" 135 | , "CommandLine", "Date", "General", "IEEEReal", "Int", "IO", "LargeInt" 136 | , "LargeReal", "LargeWord", "List", "ListPair", "Math", "Option", "OS" 137 | , "Position", "Real", "StringCvt", "String", "Substring", "TextIO" 138 | , "TextPrimIO", "Text", "Timer", "Time", "VectorSlice", "Vector" 139 | , "Word8Array", "Word8ArraySlice", "Word8Vector", "Word8VectorSlice" 140 | , "Word8", "Word" 141 | ] @ 142 | [ "Array2", "BoolArray", "BoolArray2", "BoolArraySlice", "BoolVector" 143 | , "BoolVectorSlice", "CharArray2", "FixedInt", "GenericSock", "INetSock" 144 | , "IntArray", "IntArray2", "IntArraySlice", "IntVector" 145 | , "IntVectorSlice", "IntInf", "NetHostDB", "NetProtDB", "NetServDB" 146 | , "PackRealBig", "PackRealLittle", "Posix", "RealArray2", "RealArray" 147 | , "RealArraySlice", "RealVector", "RealVectorSlice", "Socket", "SysWord" 148 | , "UnixSock", "Unix", "WideCharArray", "WideCharArray2" 149 | , "WideCharArraySlice", "WideChar", "WideCharVector" 150 | , "WideCharVectorSlice", "WideString", "WideSubstring", "WideTextPrimIO" 151 | , "WideText", "Windows" 152 | ] @ nStructs 8 @ nStructs 16 @ nStructs 32 @ nStructs 63 @ nStructs 64 153 | end 154 | 155 | (* https://smlfamily.github.io/Basis/top-level-chapter.html#section:2 156 | * https://smlfamily.github.io/Basis/top-level-chapter.html#section:3 157 | *) 158 | val basisTyps = 159 | [ "unit", "int", "word", "real", "char", "string", "substring", "exn" 160 | , "array", "vector", "ref", "bool", "option", "order", "list" 161 | ] 162 | 163 | (* https://smlfamily.github.io/Basis/top-level-chapter.html#section:2 *) 164 | val basisVals = 165 | [ "false", "true", "NONE", "SOME", "LESS", "EQUAL", "GREATER", "nil", "::" 166 | ] @ 167 | [ "Bind", "Chr", "Div", "Domain", "Empty", "Fail", "Match", "Option" 168 | , "Overflow", "Size", "Span", "Subscript" 169 | ] @ 170 | [ "!", ":=", "@", "^", "app", "before", "ceil", "chr", "concat" 171 | , "exnMessage", "exnName", "explode", "floor", "foldl", "foldr", "getOpt" 172 | , "hd", "ignore", "implode", "isSome", "length", "map", "not", "null", "o" 173 | , "ord", "print", "real", "ref", "rev", "round", "size", "str" 174 | , "substring", "tl", "trunc", "use", "valOf", "vector" 175 | ] @ 176 | [ "+", "-", "*", "div", "mod", "/", "~", "abs", "<", ">", "<=", ">=" 177 | , "<>", "=" 178 | ] 179 | 180 | (* https://polyml.org/documentation/Reference/Basis.html *) 181 | val polySigs = 182 | [ "ASN1", "FOREIGN", "INET6_SOCK", "SIGNAL", "SML90", "THREAD", "WEAK" 183 | ] 184 | 185 | (* https://polyml.org/documentation/Reference/Basis.html *) 186 | val polyStrs = 187 | [ "Asn1", "Foreign", "HashArray", "INet6Sock", "Net6HostDB", "PolyML" 188 | , "RunCall" ,"Signal", "SingleAssignment", "SML90", "Thread", "ThreadLib" 189 | , "Universal", "UniversalArray", "Weak" 190 | ] 191 | 192 | local 193 | 194 | fun copy f l : 'a fns = 195 | let 196 | val h : 'a H.hash = H.hash (length l * 5 div 4) 197 | fun cp f m k = case f k of SOME v => H.update (m, k, v) | NONE => () 198 | in 199 | app (cp f h) l; 200 | ( fn () => H.fold (fn (s, v, l) => (s, v)::l) [] h 201 | , fn _ => () 202 | , fn s => H.sub (h, s) 203 | ) 204 | end 205 | 206 | fun fromList l : 'a fns = 207 | let 208 | val h : 'a H.hash = H.hash (length l * 5 div 4) 209 | in 210 | app (fn (k, v) => H.update (h, k, v)) l; 211 | ( fn () => H.fold (fn (s, v, l) => (s, v)::l) [] h 212 | , fn _ => () 213 | , fn s => H.sub (h, s) 214 | ) 215 | end 216 | in 217 | fun new (lBas, lFix, lFun, lSig, lStr, lTyp, lVal) = 218 | let 219 | val (aBas, eBas, lBas) = fromList lBas 220 | val (aFix, eFix, lFix) = copy (#lookupFix pgns) lFix 221 | val (aFun, eFun, lFun) = copy (#lookupFunct pgns) lFun 222 | val (aSig, eSig, lSig) = copy (#lookupSig pgns) lSig 223 | val (aStr, eStr, lStr) = copy (#lookupStruct pgns) lStr 224 | val (aTyp, eTyp, lTyp) = copy (#lookupType pgns) lTyp 225 | val (aVal, eVal, lVal) = copy (#lookupVal pgns) lVal 226 | in 227 | N ( 228 | { allBas = aBas, enterBas = eBas, lookupBas = lBas 229 | } 230 | , { allFix = aFix, enterFix = eFix, lookupFix = lFix 231 | , allFunct = aFun, enterFunct = eFun, lookupFunct = lFun 232 | , allSig = aSig, enterSig = eSig, lookupSig = lSig 233 | , allStruct = aStr, enterStruct = eStr, lookupStruct = lStr 234 | , allType = aTyp, enterType = eTyp, lookupType = lTyp 235 | , allVal = aVal, enterVal = eVal, lookupVal = lVal 236 | } 237 | ) 238 | end 239 | end 240 | 241 | val basis = 242 | new ([], basisFixs, basisFcts, basisSigs, basisStrs, basisTyps, basisVals) 243 | 244 | val poly = new ([], [], [], polySigs, polyStrs, [], []) 245 | in 246 | val basis = basis 247 | val poly = poly 248 | val all = 249 | new 250 | ( [("BasisLib", basis), ("PolyLib", poly)], basisFixs, basisFcts 251 | , basisSigs @ polySigs, basisStrs @ polyStrs, basisTyps, basisVals 252 | ) 253 | end 254 | 255 | fun empty () = 256 | let 257 | val (aBas, eBas, lBas) : t fns = fns () 258 | val (aFix, eFix, lFix) : N.Infixes.fixity fns = fns () 259 | val (aFun, eFun, lFun) : N.Functors.functorVal fns = fns () 260 | val (aSig, eSig, lSig) : N.Signatures.signatureVal fns = fns () 261 | val (aStr, eStr, lStr) : N.Structures.structureVal fns = fns () 262 | val (aTyp, eTyp, lTyp) : N.TypeConstrs.typeConstr fns = fns () 263 | val (aVal, eVal, lVal) : N.Values.value fns = fns () 264 | in 265 | N ( 266 | { allBas = aBas, enterBas = eBas, lookupBas = lBas 267 | } 268 | , { allFix = aFix, enterFix = eFix, lookupFix = lFix 269 | , allFunct = aFun, enterFunct = eFun, lookupFunct = lFun 270 | , allSig = aSig, enterSig = eSig, lookupSig = lSig 271 | , allStruct = aStr, enterStruct = eStr, lookupStruct = lStr 272 | , allType = aTyp, enterType = eTyp, lookupType = lTyp 273 | , allVal = aVal, enterVal = eVal, lookupVal = lVal 274 | } 275 | ) 276 | end 277 | 278 | fun import { src = N (bs1, ns1), dst = N (bs2, ns2) } = 279 | ( app (#enterBas bs2) (#allBas bs1 ()) 280 | ; app (#enterFix ns2) (#allFix ns1 ()) 281 | ; app (#enterFunct ns2) (#allFunct ns1 ()) 282 | ; app (#enterSig ns2) (#allSig ns1 ()) 283 | ; app (#enterStruct ns2) (#allStruct ns1 ()) 284 | ; app (#enterType ns2) (#allType ns1 ()) 285 | ; app (#enterVal ns2) (#allVal ns1 ()) 286 | ) 287 | 288 | local 289 | (* lookup delegate, enter delegate, whether to propagate enter *) 290 | (* todo: delegate { lookup : t, enter : t option } *) 291 | fun delegate (N (bs, ns), N (bs', ns'), enter) = 292 | let 293 | fun fns (all, enter, lookup) : 'a fns = 294 | let 295 | val h : 'a H.hash = H.hash 20 296 | in 297 | ( fn () => H.fold (fn (s, v, l) => (s, v)::l) (all ()) h 298 | , case enter of 299 | NONE => (fn (s, v) => H.update (h, s, v)) 300 | | SOME f => (fn (s, v) => (H.update (h, s, v); f (s, v))) 301 | , fn s => case H.sub (h, s) of NONE => lookup s | z => z 302 | ) 303 | end 304 | fun e f = if enter then SOME f else NONE 305 | val (aBas, eBas, lBas) = fns (#allBas bs, e (#enterBas bs'), #lookupBas bs) 306 | val (aFix, eFix, lFix) = fns (#allFix ns, e (#enterFix ns'), #lookupFix ns) 307 | val (aFun, eFun, lFun) = fns (#allFunct ns, e (#enterFunct ns'), #lookupFunct ns) 308 | val (aSig, eSig, lSig) = fns (#allSig ns, e (#enterSig ns'), #lookupSig ns) 309 | val (aStr, eStr, lStr) = fns (#allStruct ns, e (#enterStruct ns'), #lookupStruct ns) 310 | val (aTyp, eTyp, lTyp) = fns (#allType ns, e (#enterType ns'), #lookupType ns) 311 | val (aVal, eVal, lVal) = fns (#allVal ns, e (#enterVal ns'), #lookupVal ns) 312 | in 313 | N ( 314 | { allBas = aBas, enterBas = eBas, lookupBas = lBas 315 | } 316 | , { allFix = aFix, enterFix = eFix, lookupFix = lFix 317 | , allFunct = aFun, enterFunct = eFun, lookupFunct = lFun 318 | , allSig = aSig, enterSig = eSig, lookupSig = lSig 319 | , allStruct = aStr, enterStruct = eStr, lookupStruct = lStr 320 | , allType = aTyp, enterType = eTyp, lookupType = lTyp 321 | , allVal = aVal, enterVal = eVal, lookupVal = lVal 322 | } 323 | ) 324 | end 325 | in 326 | fun delegates ns = 327 | let 328 | val loc = delegate (ns, ns, false) 329 | in 330 | { loc = loc, pub = delegate (loc, ns, true) } 331 | end 332 | end 333 | end 334 | -------------------------------------------------------------------------------- /src/bin/main.sml: -------------------------------------------------------------------------------- 1 | structure H = HashArray 2 | structure P = PolyMLB 3 | structure PC = PolyML.Compiler 4 | structure OSP = OS.Process 5 | structure S = String 6 | structure SS = Substring 7 | structure TIO = TextIO 8 | 9 | datatype cmd = CompileLink | Compile | SmlLib 10 | 11 | type opts = 12 | { cmd : cmd 13 | , defAnns : P.Ann.t list 14 | , depsf : bool 15 | , disAnns : P.Ann.t list 16 | , file : string 17 | , jobs : int 18 | , main : string 19 | , out : string 20 | , pathMap : string H.hash 21 | , polyc : string 22 | , rootAnns : P.Ann.t list 23 | , verbose : int 24 | } 25 | 26 | local 27 | fun f str s = 28 | if S.isSuffix "\n" s then 29 | TIO.output (str, s) 30 | else 31 | TIO.output (str, s ^ "\n") 32 | in 33 | val println = f TIO.stdOut 34 | val eprintln = f TIO.stdErr 35 | fun die "" = OSP.exit OSP.failure 36 | | die msg = (eprintln msg; OSP.exit OSP.failure) 37 | end 38 | 39 | fun success () = OSP.exit OSP.success 40 | 41 | (* todo: PolyML.export automatically adds an extension, which is ".o" on every 42 | * platform except Windows proper (e.g Cygwin results in ".o") 43 | * see: libpolyml/exporter.cpp:780:exportNative 44 | *) 45 | fun objExt () = ".o" 46 | 47 | local 48 | fun usage () = die ("usage: " ^ CommandLine.name () ^ " [OPTIONS] [--] FILE") 49 | 50 | fun help () = 51 | app println 52 | [ "usage: " ^ CommandLine.name () ^ " [OPTIONS] [--] FILE" 53 | , "Compile and link an MLBasis file with Poly/ML." 54 | , "" 55 | , "OPTIONS" 56 | , " -ann Wrap FILE with the given annotation" 57 | , "-c -compile Compile but do not link" 58 | , " -default-ann Set annotation default" 59 | , " -deps-first Ensure MLB files will only be compiled after" 60 | , " their dependencies" 61 | , " -disable-ann Disable the given annotation" 62 | , "-h -help Print help usage" 63 | , " -info Print advanced information" 64 | , " -ignore-call-main Equivalent to -ann 'ignoreFiles call-main.sml'" 65 | , " -ignore-main Equivalent to -ann 'ignoreFiles main.sml'" 66 | , " -jobs Maximum number of jobs to run simultaneously" 67 | , " -mlb-path-map Additional MLB path map" 68 | , " -mlb-path-var ' ' Additional MLB path var" 69 | , " -main Root function to export" 70 | , "-o -output Name of output file" 71 | , " -polyc Polyc executable instead of 'polyc'" 72 | , "-q -quiet Equivalent to -verbose 1" 73 | , "-Q -reallyquiet Equivalent to -verbose 0" 74 | , " -sml-lib Print the resolved value of $(SML_LIB)" 75 | , "-v -verbose Set verbosity level" 76 | , "-V -version Print PolyMLB version" 77 | ] before success () 78 | 79 | val VERSION = 80 | (String.concatWith "." o map Int.toString) 81 | [VERSION_MAJOR, VERSION_MINOR, VERSION_PATCH] 82 | 83 | fun version () = 84 | println ("PolyMLB " ^ VERSION ^ " (Poly/ML " ^ PC.compilerVersion ^ ")") 85 | before success () 86 | 87 | local 88 | val l = getOpt (H.sub (PolyMLB.pathMap, "SML_LIB"), "") 89 | val msg = S.concat 90 | [ "polymlb: ", VERSION 91 | , "\npoly: ", PC.compilerVersion 92 | , "\nSML_LIB: ", if l = "" then "unset" else "\"" ^ l ^ "\"" 93 | ] 94 | in 95 | fun info () = println msg before success () 96 | end 97 | 98 | val d = 99 | { cmd = ref CompileLink 100 | , defAnns = ref ([] : P.Ann.t list) 101 | , depsf = ref false 102 | , disAnns = ref ([] : P.Ann.t list) 103 | , file = ref "" 104 | , jobs = ref 1 105 | , main = ref "main" 106 | , out = ref "" 107 | , pathMap = ref (H.hash 10 : string H.hash) 108 | , polyc = ref "polyc" 109 | , rootAnns = ref ([] : P.Ann.t list) 110 | , verbose = ref 2 111 | } 112 | 113 | fun req s = [] before die ("missing required argument for option " ^ s) 114 | fun inv (s, v) = 115 | [] before die ("invalid value for option " ^ s ^ ": '" ^ v ^ "'") 116 | 117 | fun strs s = 118 | let 119 | val (ss1, ss2) = 120 | SS.splitl 121 | (not o Char.isSpace) 122 | ((SS.dropr Char.isSpace o SS.dropl Char.isSpace o SS.full) s) 123 | in 124 | (SS.string ss1, (SS.string o SS.dropl Char.isSpace) ss2) 125 | end 126 | 127 | fun set ([], s, _, _) = (req s; []) 128 | | set (x::xs, s, f, p) = 129 | (case p x of 130 | NONE => (inv (s, x); []) 131 | | SOME v => (f d := v; xs)) 132 | 133 | fun var [] = req "-mlb-path-var" 134 | | var (x::xs) = 135 | case strs x of 136 | ("", _) => inv ("-mlb-path-var", x) 137 | | (_, "") => inv ("-mlb-path-var", x) 138 | | (k, v) => xs before H.update (!(#pathMap d), k, v) 139 | 140 | fun map [] = req "-mlb-path-map" 141 | | map (x::xs) = 142 | let 143 | val s = TIO.openIn x 144 | handle _ => (inv ("-mlb-path-var", x); TIO.stdIn) 145 | val l = ref 0 146 | fun e () = 147 | die (x ^ ":" ^ Int.toString (!l) ^ ": invalid path map entry") 148 | fun f () = 149 | case (l := !l + 1; TIO.inputLine s) of 150 | NONE => TIO.closeIn s 151 | | SOME l => 152 | (case strs l of 153 | ("", _) => e () 154 | | (_, "") => e () 155 | | (k, v) => H.update (!(#pathMap d), k, v) before f ()) 156 | in 157 | xs before f () before TIO.closeIn s 158 | end 159 | 160 | fun ann (_, s) [] = req s 161 | | ann (field, s) (x::xs) = 162 | case P.Ann.parse x of 163 | P.Ann.Ann a => xs before field d := a :: !(field d) 164 | | _ => inv (s, x) 165 | 166 | fun annName (_, s) [] = req s 167 | | annName (field, s) (x::xs) = 168 | case P.Ann.parseName x of 169 | NONE => inv (s, x) 170 | | SOME a => xs before field d := a :: !(field d) 171 | 172 | fun posInt s = 173 | case Int.fromString s of 174 | NONE => NONE 175 | | SOME i => if i < 0 then NONE else SOME i 176 | in 177 | fun parseArgs () : opts = 178 | let 179 | val l = ref (CommandLine.arguments ()) 180 | 181 | fun f () = 182 | case !l of 183 | [] => () 184 | | (x::xs) => 185 | ( l := xs 186 | ; case x of 187 | "--" => ((#file d := hd xs) handle Empty => usage ()) 188 | | "-ann" => l := ann (#rootAnns, "-ann") xs 189 | | "-c" => #cmd d := Compile 190 | | "-compile" => #cmd d := Compile 191 | | "-default-ann" => l := ann (#defAnns, "default-ann") xs 192 | | "-deps-first" => #depsf d := true 193 | | "-disable-ann" => l := annName (#disAnns, "disable-ann") xs 194 | | "-h" => help () 195 | | "-help" => help () 196 | | "-info" => info () 197 | | "-ignore-call-main" => 198 | #rootAnns d := P.Ann.IgnoreFiles ["call-main.sml"] 199 | :: !(#rootAnns d) 200 | | "-ignore-main" => 201 | #rootAnns d := P.Ann.IgnoreFiles ["main.sml"] 202 | :: !(#rootAnns d) 203 | | "-jobs" => l := set (xs, "-jobs", #jobs, posInt) 204 | | "-main" => l := set (xs, "-main", #main, SOME) 205 | | "-mlb-path-map" => l := map xs 206 | | "-mlb-path-var" => l := var xs 207 | | "-o" => l := set (xs, "-o", #out, SOME) 208 | | "-output" => l := set (xs, "-output", #out, SOME) 209 | | "-polyc" => l := set (xs, "-p", #polyc, SOME) 210 | | "-q" => #verbose d := 1 211 | | "-quiet" => #verbose d := 1 212 | | "-Q" => #verbose d := 0 213 | | "-reallyquiet" => #verbose d := 0 214 | | "-sml-lib" => #cmd d := SmlLib 215 | | "-v" => l := set (xs, "-v", #verbose, posInt) 216 | | "-verbose" => l := set (xs, "-verbose", #verbose, posInt) 217 | | "-V" => version () 218 | | "-version" => version () 219 | | s => 220 | if S.isPrefix "-" s then 221 | die ("invalid option: " ^ x) 222 | else 223 | (#file d := x; raise Fail "") 224 | ; f () 225 | ) 226 | 227 | val _ = f () handle Fail "" => () 228 | 229 | val out = 230 | if !(#out d) = "" then 231 | (OS.Path.base o ! o #file) d 232 | ^ (case !(#cmd d) of 233 | (* ".exe" on windows? *) 234 | CompileLink => "" 235 | | Compile => objExt () 236 | | SmlLib => "") 237 | else 238 | !(#out d) 239 | 240 | val opts as { file, ... } : opts = 241 | { cmd = !(#cmd d) 242 | , defAnns = !(#defAnns d) 243 | , depsf = !(#depsf d) 244 | , disAnns = !(#disAnns d) 245 | , file = !(#file d) 246 | , jobs = !(#jobs d) 247 | , main = !(#main d) 248 | , out = out 249 | , pathMap = !(#pathMap d) 250 | , polyc = !(#polyc d) 251 | , rootAnns = !(#rootAnns d) 252 | , verbose = !(#verbose d) 253 | } 254 | in 255 | if #cmd opts = SmlLib then 256 | opts 257 | else if file = "" then 258 | opts before usage () 259 | else if (not o List.null o !) l then 260 | opts before die "only one input file allowed" 261 | else if not (S.isSuffix ".mlb" file) then 262 | opts before die ("invalid extension: " ^ file) 263 | else 264 | opts 265 | end 266 | end 267 | 268 | local 269 | open OS.FileSys 270 | 271 | fun searchDir (s, p) = 272 | let 273 | fun f d = 274 | case readDir d of 275 | NONE => NONE before closeDir d 276 | | SOME s' => 277 | if s = s' then 278 | (closeDir d; SOME (OS.Path.joinDirFile { dir = p, file = s })) 279 | else 280 | f d 281 | in 282 | f (openDir p) handle _ => NONE 283 | end 284 | 285 | fun searchPath s = 286 | let 287 | fun f [] = NONE 288 | | f (d::ds) = case searchDir (s, d) of NONE => f ds | z => z 289 | in 290 | Option.mapPartial (f o S.tokens (fn c => c = #":")) (OSP.getEnv "PATH") 291 | end 292 | in 293 | fun cmdExists s = 294 | if CharVector.exists (fn c => c = #"/") s then 295 | access (s, [A_EXEC]) 296 | else 297 | case searchPath s of 298 | SOME s => access (s, [A_EXEC]) 299 | | NONE => false 300 | end 301 | 302 | local 303 | structure P = PolyMLB 304 | 305 | fun log v (l, m) = if v >= P.Log.levelToInt l then println (m ()) else () 306 | 307 | fun fmt p = 308 | let 309 | val cwd = OS.FileSys.getDir () 310 | in 311 | if S.isPrefix cwd p then 312 | OS.Path.mkRelative { path = p, relativeTo = cwd } 313 | else 314 | p 315 | end 316 | 317 | fun o2o ({ defAnns, depsf, disAnns, jobs, pathMap, rootAnns, verbose, ... } : opts) = 318 | let 319 | val l = 320 | [ P.PathMap pathMap 321 | , P.Concurrency { depsFirst = depsf, jobs = jobs } 322 | , P.DisabledAnns disAnns 323 | ] 324 | val l = 325 | if verbose = 0 then 326 | l 327 | else 328 | P.Logger { pathFmt = fmt, print = log verbose } :: l 329 | val l = 330 | P.Preprocess 331 | (fn { bas, root = true, ... } => 332 | let 333 | val anns = defAnns @ rootAnns 334 | in 335 | if null anns then bas else [P.Basis.Ann (anns, bas)] 336 | end 337 | | { bas, ... } => 338 | if null defAnns then bas else [P.Basis.Ann (defAnns, bas)]) 339 | :: l 340 | in 341 | l 342 | end 343 | in 344 | fun doCompile (opts as { file, ... } : opts) = 345 | P.compile (o2o opts) file handle _ => (die ""; raise Fail "") 346 | end 347 | 348 | local 349 | fun getVal (ns, id) = 350 | let 351 | fun f (_, []) = NONE 352 | | f (ns, [x]) = #lookupVal ns x 353 | | f (ns, x::xs) = 354 | case #lookupStruct ns x of 355 | NONE => NONE 356 | | SOME s => f (PolyML.NameSpace.Structures.contents s, xs) 357 | in 358 | f (ns, S.tokens (fn c => c = #".") id) 359 | end 360 | 361 | val msg = ref ([] : string list) 362 | fun mkMsg { message, hard, ... } = 363 | if hard then 364 | PolyML.prettyPrint (fn s => msg := s :: !msg, 80) message 365 | else 366 | () 367 | 368 | val exportFn = (valOf o getVal) (PolyML.globalNameSpace, "PolyML.export") 369 | in 370 | fun export (out, root, P.NameSpace.N (_, ns)) = 371 | case getVal (ns, root) of 372 | NONE => 373 | die ("error: cannot export '" ^ root ^ "': value has not been declared") 374 | | SOME mainFn => 375 | let 376 | val str = TIO.openString ("export (\"" ^ out ^ "\", main);") 377 | val P.NameSpace.N (_, ns') = P.NameSpace.empty () 378 | in 379 | #enterVal ns' ("main", mainFn); 380 | #enterVal ns' ("export", exportFn); 381 | PolyML.compiler 382 | ( fn () => TIO.input1 str 383 | , [PC.CPNameSpace ns', PC.CPErrorMessageProc mkMsg] 384 | ) () 385 | end 386 | handle _ => 387 | (die o S.concat) 388 | (["error: cannot export '", root, "': "] @ List.rev (!msg)) 389 | end 390 | 391 | fun compile (opts as { main, out, ... }) = export (out, main, doCompile opts) 392 | 393 | local 394 | fun link (polyc, obj, out) = 395 | if (OSP.isSuccess o OSP.system o S.concatWith " ") [polyc, "-o", out, obj] 396 | then 397 | () 398 | else 399 | die ("error invoking " ^ polyc) 400 | in 401 | fun compileLink (opts as { file, main, out, polyc, ... }) = 402 | if not (cmdExists polyc) then 403 | die ("command not found: " ^ polyc) 404 | else 405 | let 406 | val obj = file ^ objExt () 407 | in 408 | export (obj, main, doCompile opts); 409 | link (polyc, obj, out); 410 | OS.FileSys.remove obj 411 | end 412 | end 413 | 414 | fun printSmlLib ({ pathMap, ... } : opts) = 415 | ( H.fold (fn (k, v, ()) => H.update (PolyMLB.pathMap, k, v)) () pathMap 416 | ; case P.Path.process PolyMLB.pathMap "$(SML_LIB)" of 417 | P.Path.Path s => println s before success () 418 | | P.Path.Unbound v => die ("unbound path var: " ^ v) 419 | ) 420 | 421 | fun main () = 422 | let 423 | val opts as { cmd, ... } = parseArgs () 424 | in 425 | (case cmd of 426 | CompileLink => compileLink 427 | | Compile => compile 428 | | SmlLib => printSmlLib) opts 429 | end 430 | -------------------------------------------------------------------------------- /src/lib/Compile.sml: -------------------------------------------------------------------------------- 1 | structure Compile : 2 | sig 3 | datatype err = 4 | Compilation of string * PolyML.location 5 | | Dependency of string (* depsFirst invariant violated; means bad input *) 6 | | Execution of string * exn 7 | | UnboundId of string 8 | 9 | exception Compile of err 10 | 11 | val errToString : (string -> string) -> err -> string 12 | 13 | type opts = 14 | { depsFirst : bool 15 | , jobs : int 16 | , logger : Log.logger option 17 | } 18 | 19 | (* Resolve and compile a list of declarations in a fresh env, triggering 20 | * side effects from top level declarations. 21 | * Does not handle IO.Io and raises Compile on non IO error. 22 | * single job and depsFirst = false is guaranteed to be encounter order. 23 | * The logger may be called from different threads if multiple jobs. 24 | *) 25 | val compile : opts -> Dag.t -> NameSpace.t 26 | end = 27 | struct 28 | structure A = Array 29 | structure BA = BoolArray 30 | structure D = Dag 31 | structure FTP = ThreadPools.FTP 32 | structure H = HashArray 33 | structure L = Log 34 | structure M = Thread.Mutex 35 | structure NS = NameSpace 36 | structure P = PolyML 37 | structure PC = PolyML.Compiler 38 | structure PTP = ThreadPools.PTP 39 | structure TIO = TextIO 40 | structure TSIO = TIO.StreamIO 41 | structure V = Vector 42 | 43 | datatype err = 44 | Compilation of string * P.location 45 | | Dependency of string 46 | | Execution of string * exn 47 | | UnboundId of string 48 | 49 | exception Compile of err 50 | 51 | fun errToString fmt k = 52 | concat 53 | [ case k of 54 | Compilation (_, at) => Log.locFmt fmt at ^ ": " 55 | | Execution (f, _) => fmt f ^ ": " 56 | | _ => "" 57 | , "error: " 58 | , case k of 59 | Compilation (s, _) => s 60 | | Dependency s => "dependency invariant violated: " ^ s 61 | | Execution (_, e) => "raised during execution: " ^ exnMessage e 62 | | UnboundId s => "unbound id: " ^ s 63 | ] 64 | 65 | type opts = 66 | { depsFirst : bool 67 | , jobs : int 68 | , logger : Log.logger option 69 | } 70 | 71 | fun compileSML log (ns, path, opts) = 72 | let 73 | val msg = ref ([] : string list) 74 | val loc = ref 75 | { file = "" 76 | , startLine = 0, startPosition = 0 77 | , endLine = 0, endPosition = 0 78 | } 79 | 80 | fun msgCb { message, hard, location, ... } = 81 | if hard then 82 | ( P.prettyPrint (fn s => msg := s :: !msg, 80) message 83 | ; loc := location 84 | ) 85 | else 86 | L.log log L.Warn 87 | (fn fmt => 88 | let 89 | val m = ref ([] : string list) 90 | in 91 | P.prettyPrint (fn s => m := s :: !m, 80) message; 92 | concat (L.locFmt fmt location :: ": " :: rev (!m)) 93 | end) 94 | 95 | val s = (ref o TIO.getInstream o TIO.openIn) path 96 | val l = ref 1 97 | 98 | fun getc () = 99 | case TSIO.input1 (!s) of 100 | NONE => NONE 101 | | SOME (c as #"\n", s') => (l := !l + 1; s := s'; SOME c) 102 | | SOME (c, s') => (s := s'; SOME c) 103 | 104 | val opts = 105 | [ PC.CPErrorMessageProc msgCb 106 | , PC.CPLineNo (fn () => !l) 107 | , PC.CPFileName path 108 | , PC.CPNameSpace ns 109 | ] @ opts 110 | in 111 | while (not o TSIO.endOfStream o !) s do 112 | let 113 | val f = P.compiler (getc, opts) 114 | handle _ => 115 | ( TSIO.closeIn (!s) 116 | ; raise 117 | (Compile o Compilation) 118 | ((String.concat o List.rev o !) msg, !loc) 119 | ) 120 | in 121 | f () 122 | handle e => 123 | ( TSIO.closeIn (!s) 124 | ; raise (Compile o Execution) (path, e) 125 | ) 126 | end; 127 | TSIO.closeIn (!s) 128 | end 129 | 130 | fun anns l = 131 | let 132 | fun f (Ann.Debug b, opts) = PC.CPDebug b :: opts 133 | | f (_, opts) = opts 134 | in 135 | List.foldr f [] l 136 | end 137 | 138 | fun isIgnored (l, p) = 139 | let 140 | val p = OS.Path.file p 141 | in 142 | List.exists (fn p' => p' = p) l 143 | end 144 | 145 | (* compileBas elaborates a given Basis.t (= a list of declarations). It also 146 | * takes in a free form argument ('a), typically the basis id in a dag. 147 | * When it encounters a Basis import (BasisFile), it returns the path, the 148 | * free argument as well as a continuation function which takes in a namespace 149 | * and will elaborates the remaining declarations. When it reaches the end, 150 | * it returns the complete namespace. 151 | * This allows to completely delegate the scheduling and MLB caching to 152 | * driver functions, which can process through the dag as needed. 153 | *) 154 | 155 | datatype 'a r = Done of 'a * NS.t | Cont of 'a * string * 'a cont 156 | withtype 'a cont = NS.t -> 'a r 157 | 158 | local 159 | datatype z = datatype Basis.dec 160 | datatype z = datatype Basis.exp 161 | in 162 | fun compileBas log ret ds = 163 | let 164 | (* addendum to the above about compileBas: declaration scopes (e.g 165 | * annotations or local/in) are also implemented with continuations, 166 | * as well as passing the current namespace as argument. 167 | *) 168 | fun elab (opts, ign) (ns as NS.N (bns, pns), ds, cont) = 169 | let 170 | val elab' = elab (opts, ign) 171 | 172 | fun dec ds = 173 | case (Thread.Thread.testInterrupt (); ds) of 174 | [] => cont ns 175 | | Basis (b, e) :: ds => 176 | exp (e, ns, fn ns' => (#enterBas bns (b, ns'); dec ds)) 177 | | BasisFile p :: ds => 178 | if isIgnored (ign, p) then 179 | dec ds 180 | else 181 | Cont (ret, p, fn ns' => 182 | (NS.import { src = ns', dst = ns }; dec ds)) 183 | | SourceFile p :: ds => 184 | if isIgnored (ign, p) then 185 | dec ds 186 | else 187 | ( L.log log L.Trace (fn fmt => "compiling " ^ fmt p) 188 | ; compileSML log (pns, p, opts) 189 | ; dec ds 190 | ) 191 | | Ann (l, ds') :: ds => 192 | if Ann.exists Ann.Discard l then 193 | dec ds 194 | else 195 | let 196 | val ign' = 197 | List.foldl 198 | (fn (Ann.IgnoreFiles f, fs) => f @ fs | (_, fs) => fs) 199 | ign l 200 | 201 | val ns' = 202 | if Ann.exists Ann.ImportAll l then 203 | let 204 | val { loc, pub } = NS.delegates ns 205 | in 206 | NS.import { src = NS.all, dst = loc }; 207 | pub 208 | end 209 | else 210 | ns 211 | in 212 | elab (anns l @ opts, ign') (ns', ds', fn _ => dec ds) 213 | end 214 | | Local (ds1, ds2) :: ds => 215 | let 216 | val { loc, pub } = NS.delegates ns 217 | in 218 | elab' (loc, ds1, fn _ => elab' (pub, ds2, fn _ => dec ds)) 219 | end 220 | | Open b :: ds => 221 | ( case #lookupBas bns b of 222 | NONE => raise Compile (UnboundId b) 223 | | SOME ns' => NS.import { src = ns', dst = ns } 224 | ; dec ds 225 | ) 226 | | Structure (new, old) :: ds => 227 | ( case #lookupStruct pns old of 228 | NONE => raise Compile (UnboundId old) 229 | | SOME s => #enterStruct pns (new, s) 230 | ; dec ds 231 | ) 232 | | Signature (new, old) :: ds => 233 | ( case #lookupSig pns old of 234 | NONE => raise Compile (UnboundId old) 235 | | SOME s => #enterSig pns (new, s) 236 | ; dec ds 237 | ) 238 | | Functor (new, old) :: ds => 239 | ( case #lookupFunct pns old of 240 | NONE => raise Compile (UnboundId old) 241 | | SOME f => #enterFunct pns (new, f) 242 | ; dec ds 243 | ) 244 | 245 | and exp (e, ns as NS.N (bns, _), cont) = 246 | case e of 247 | Bas ds => 248 | let 249 | val ns' = NS.empty () 250 | val { loc, pub } = NS.delegates ns' 251 | in 252 | NS.import { src = ns, dst = loc }; 253 | elab' (pub, ds, fn _ => cont ns') 254 | end 255 | | Id b => 256 | (case #lookupBas bns b of 257 | NONE => raise Compile (UnboundId b) 258 | | SOME ns => cont ns) 259 | | Let (ds, e) => 260 | let 261 | val ns' = NS.empty () 262 | val { loc, pub } = NS.delegates ns' 263 | in 264 | NS.import { src = ns, dst = loc }; 265 | elab' (loc, ds, fn _ => exp (e, pub, fn _ => cont ns')) 266 | end 267 | in 268 | dec ds 269 | end 270 | in 271 | elab ([], []) (NS.empty (), ds, fn ns => Done (ret, ns)) 272 | end 273 | end 274 | 275 | (* All driver functions are passed in a namespace array, which will contain 276 | * the namespaces resulting from MLB elaboration and is indexed by dag ids. 277 | *) 278 | 279 | structure NameSpaceArray :> 280 | sig 281 | type t 282 | (* whether to make threadsafe *) 283 | val new : Dag.t * bool -> t 284 | val sub : t * int -> NS.t 285 | val sub' : t * string -> NS.t 286 | val get : t * int -> NS.t option 287 | val set : t * int * NS.t -> unit 288 | end = 289 | struct 290 | type t = 291 | { a : NS.t option array 292 | , m : M.mutex option 293 | , paths : string vector 294 | , getId : (string -> int) 295 | } 296 | 297 | fun new ({ paths, getId, ... } : Dag.t, b) = 298 | { m = if b then (SOME o M.mutex) () else NONE 299 | , a = A.array (V.length paths, NONE) 300 | , paths = paths 301 | , getId = getId 302 | } 303 | 304 | (* double checked locking? *) 305 | val lock = Option.app M.lock 306 | val unlock = Option.app M.unlock 307 | 308 | fun sub ({ a, m, paths, ... } : t, i) = 309 | case (lock m; A.sub (a, i) before unlock m) of 310 | NONE => raise (Compile o Dependency o V.sub) (paths, i) 311 | | SOME ns => ns 312 | 313 | fun sub' (t, s) = sub (t, #getId t s) 314 | 315 | fun get ({ a, m, ... } : t, i) = (lock m; A.sub (a, i) before unlock m) 316 | 317 | fun set ({ a, m, paths, ... } : t, i, ns) = 318 | if (lock m; (isSome o A.sub) (a, i)) then 319 | ( unlock m 320 | ; raise Fail 321 | ("Compile.NameSpaceArray.set: illegal set for " ^ V.sub (paths, i)) 322 | ) 323 | else 324 | A.update (a, i, SOME ns) before unlock m 325 | end 326 | 327 | structure NSA = NameSpaceArray 328 | 329 | fun logElab log p = L.log log L.Info (fn fmt => "elaborating " ^ fmt p) 330 | 331 | (* Driver functions. *) 332 | 333 | fun serialDeps (log, nsa, { dag = { root, ... }, bases, paths, ... } : D.t) = 334 | let 335 | fun cont (Done (id, ns)) = NSA.set (nsa, id, ns) 336 | | cont (Cont (_, p, f)) = (cont o f o NSA.sub') (nsa, p) 337 | 338 | fun comp (D.N (id, deps)) = 339 | if (isSome o NSA.get) (nsa, id) then 340 | () 341 | else 342 | ( V.app comp deps 343 | ; (logElab log o V.sub) (paths, id) 344 | ; (cont o compileBas log id o V.sub) (bases, id) 345 | ) 346 | in 347 | comp root; 348 | NSA.sub (nsa, 0) 349 | end 350 | 351 | fun serialEncounter (log, nsa, { bases, paths, getId, ... } : D.t) = 352 | let 353 | fun cont (Done (id, ns)) = ns before NSA.set (nsa, id, ns) 354 | | cont (Cont (_, p, f)) = 355 | let 356 | val id = getId p 357 | in 358 | case NSA.get (nsa, id) of 359 | SOME ns => cont (f ns) 360 | | NONE => 361 | ( logElab log p 362 | ; (cont o f o cont o compileBas log id o V.sub) (bases, id) 363 | ) 364 | end 365 | in 366 | (logElab log o V.sub) (paths, 0); 367 | (cont o compileBas log 0 o V.sub) (bases, 0) 368 | end 369 | 370 | fun parDeps jobs (log, nsa, { dag = { root, leaves }, bases, paths, ... } : D.t) = 371 | let 372 | val started = BA.array (V.length bases, false) 373 | val counts = A.tabulate (V.length bases, fn _ => (M.mutex (), ref ~1)) 374 | val tp = FTP.new jobs 375 | 376 | fun doCounts (D.N (id, deps)) = 377 | let 378 | val (_, r) = A.sub (counts, id) 379 | in 380 | if !r > ~1 then () else (r := V.length deps; V.app doCounts deps) 381 | end 382 | 383 | fun cont (Done (id, ns)) = NSA.set (nsa, id, ns) 384 | | cont (Cont (_, p, f)) = (cont o f o NSA.sub') (nsa, p) 385 | 386 | fun elab id = 387 | ( (logElab log o V.sub) (paths, id) 388 | ; (cont o compileBas log id o V.sub) (bases, id) 389 | ) 390 | 391 | fun postComp (n as D.N (id, _)) = 392 | let 393 | val (m, r) = A.sub (counts, id) 394 | in 395 | M.lock m; 396 | r := !r - 1; 397 | if !r = 0 before M.unlock m then 398 | FTP.submit (tp, fn () => comp n) 399 | else 400 | () 401 | end 402 | 403 | (* no lock on started since it's only accessed from the original thread *) 404 | and comp (D.N (id, revs)) = 405 | if BA.sub (started, id) then 406 | () 407 | else 408 | ( BA.update (started, id, true) 409 | ; FTP.submit (tp, fn () => (elab id; V.app postComp revs)) 410 | ) 411 | in 412 | doCounts root; 413 | V.app comp leaves; 414 | case FTP.wait tp of 415 | NONE => NSA.sub (nsa, 0) 416 | | SOME e => PolyML.Exception.reraise e 417 | end 418 | 419 | fun parConc jobs (log, nsa, { dag = { root, leaves }, bases, paths, getId, ... } : D.t) = 420 | let 421 | type c = FixedInt.int * (FixedInt.int * int) cont 422 | val m = M.mutex () 423 | val conts = A.tabulate (V.length bases, fn _ => ([] : c list)) 424 | val prios = A.array (V.length bases, ~1 : FixedInt.int) 425 | val tp = PTP.new jobs 426 | 427 | fun doPrio i (D.N (id, deps)) = 428 | let 429 | val j = A.sub (prios, id) 430 | in 431 | if j < i then 432 | ( A.update (prios, id, i) 433 | ; if j = ~1 then V.app (doPrio (i + 1)) deps else () 434 | ) 435 | else 436 | () 437 | end 438 | 439 | fun cont (Done ((_, id), ns)) = (NSA.set (nsa, id, ns); postComp (id, ns)) 440 | | cont (Cont ((prio, _), p, f)) = 441 | let 442 | val id = getId p 443 | in 444 | case NSA.get (nsa, id) of 445 | SOME ns => cont (f ns) 446 | | NONE => 447 | ( M.lock m 448 | ; A.update (conts, id, (prio, f) :: A.sub (conts, id)) 449 | ; M.unlock m 450 | ) 451 | end 452 | 453 | and postComp (id, ns) = 454 | app 455 | (fn (prio, f) => PTP.submit (tp, (prio, fn () => cont (f ns)))) 456 | (A.sub (conts, id)) 457 | 458 | fun elab (prio, id) = 459 | ( (logElab log o V.sub) (paths, id) 460 | ; (cont o compileBas log (prio, id) o V.sub) (bases, id) 461 | ) 462 | 463 | (* no lock on prios since it's only accessed from the original thread *) 464 | fun comp (D.N (id, revs)) = 465 | case A.sub (prios, id) of 466 | ~1 => () 467 | | prio => 468 | ( A.update (prios, id, ~1) 469 | ; PTP.submit (tp, (prio, fn () => elab (prio, id))) 470 | ; V.app comp revs 471 | ) 472 | in 473 | doPrio 0 root; 474 | V.app comp leaves; 475 | case PTP.wait tp of 476 | NONE => NSA.sub (nsa, 0) 477 | | SOME e => PolyML.Exception.reraise e 478 | end 479 | 480 | fun numJobs j = 481 | if j <= 0 then 482 | Thread.Thread.numProcessors () 483 | else 484 | Int.min (j, Thread.Thread.numProcessors ()) 485 | 486 | fun compile { depsFirst, jobs, logger } dag = 487 | let 488 | val jobs = numJobs jobs 489 | in 490 | (case (jobs, depsFirst) of 491 | (1, true) => serialDeps 492 | | (1, _) => serialEncounter 493 | | (n, true) => parDeps n 494 | | (n, _) => parConc n) (logger, NSA.new (dag, jobs > 1), dag) 495 | end 496 | end 497 | --------------------------------------------------------------------------------