diff --git a/.builds/freebsd.yml b/.builds/freebsd.yml index fede2621..61150c65 100644 --- a/.builds/freebsd.yml +++ b/.builds/freebsd.yml @@ -9,4 +9,3 @@ tasks: gmake gmake test sudo gmake install - gmake test-install diff --git a/.builds/linux.yml b/.builds/linux.yml index 8dadd2b2..d81dd958 100644 --- a/.builds/linux.yml +++ b/.builds/linux.yml @@ -19,5 +19,3 @@ tasks: ninja ninja test sudo ninja install - sudo jpm --verbose install circlet - sudo jpm --verbose install spork diff --git a/.builds/openbsd.yml b/.builds/openbsd.yml index f2fc3733..c55cd119 100644 --- a/.builds/openbsd.yml +++ b/.builds/openbsd.yml @@ -29,5 +29,4 @@ tasks: ninja ninja test doas ninja install - doas jpm --verbose install circlet diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml new file mode 100644 index 00000000..f4fa04d6 --- /dev/null +++ b/.github/workflows/release.yml @@ -0,0 +1,35 @@ +name: Release + +on: + push: + tags: + - "v*.*.*" + +jobs: + + release: + name: Build release binaries + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ ubuntu-latest, macos-latest ] + steps: + - name: Checkout the repository + uses: actions/checkout@master + - name: Set the version + run: echo "version=${GITHUB_REF/refs\/tags\//}" >> $GITHUB_ENV + - name: Set the platform + run: echo "platform=$(tr '[A-Z]' '[a-z]' <<< $RUNNER_OS)" >> $GITHUB_ENV + - name: Compile the project + run: make clean && make + - name: Build the artifact + run: JANET_DIST_DIR=janet-${{ env.version }}-${{ env.platform }} make build/janet-${{ env.version }}-${{ env.platform }}-x64.tar.gz + - name: Draft the release + uses: softprops/action-gh-release@v1 + with: + draft: true + files: | + build/*.gz + build/janet.h + build/c/janet.c + build/c/shell.c diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml new file mode 100644 index 00000000..71819468 --- /dev/null +++ b/.github/workflows/test.yml @@ -0,0 +1,34 @@ +name: Test + +on: [push, pull_request] + +jobs: + + test-posix: + name: Build and test on POSIX systems + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ ubuntu-latest, macos-latest ] + steps: + - name: Checkout the repository + uses: actions/checkout@master + - name: Compile the project + run: make clean && make + - name: Test the project + run: make test + + test-windows: + name: Build and test on Windows + runs-on: windows-latest + steps: + - name: Checkout the repository + uses: actions/checkout@master + - name: Setup MSVC + uses: ilammy/msvc-dev-cmd@v1 + - name: Build the project + shell: cmd + run: build_win + - name: Test the project + shell: cmd + run: build_win test diff --git a/.gitignore b/.gitignore index 74d8433c..23e0a889 100644 --- a/.gitignore +++ b/.gitignore @@ -32,8 +32,9 @@ lockfile.janet # Local directory for testing local -# Common test file I use. +# Common test files I use. temp.janet +scratch.janet # Emscripten *.bc diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 2fd759a1..00000000 --- a/.travis.yml +++ /dev/null @@ -1,25 +0,0 @@ -language: c -script: -- make -- make test -- sudo make install -- make test-install -- JANET_DIST_DIR=janet-${TRAVIS_TAG}-${TRAVIS_OS_NAME} make build/janet-${TRAVIS_TAG}-${TRAVIS_OS_NAME}.tar.gz -compiler: -- clang -- gcc -os: -- linux -- osx -before_deploy: -deploy: - provider: releases - api_key: - secure: JSqAOTH1jmfVlbOuPO3BbY1BhPq+ddiBNPCxuAyKHoVwfO4eNAmq9COI+UwCMWY3dg+YlspufRwkHj//B7QQ6hPbSsKu+Mapu6gr/CAE/jxbfO/E98LkIkUwbGjplwtzw2kiBkHN/Bu6J5X76cwo4D8nwQ1JIcV3nWtoG87t7H4W0R4AYQkbLGAPylgUFr11YMPx2cRBBqCdLAGIrny7kQ/0cRBfkN81R/gUJv/q3OjmUvY7sALXp7mFdZb75QPSilKIDuVUU5hLvPYTeRl6cWI/M+m5SmGZx1rjv5S9Qaw070XoNyt9JAADtbOUnADKvDguDZIP1FCuT1Gb+cnJPzrvk6+OBU9s8UjCTFtgV+LKlhmRZcwV5YQBE94PKRMJNC6VvIWM7UeQ8Zhm1jmQS6ONNWbuoUAlkZP57NtDQa2x0GT2wkubNSQKlaY+6/gwTD9KAJIzaZG7HYXH7b+4g7VbccCyhDAtDZtXgrOIS4WAkNc8rWezRO4H0qHMyON9aCEb0eTE8hWIufbx6ymG4gUxnYO+AkrEYMCwQvU6lS8BsevkaMTVtSShqlQtJ9FRlmJA3MA2ONyqzQXJENqRydyVbpFrKSv+0HbMyhEc5BoKbt0QcTh/slouNV4eASNar/GKN7aP8XKGUeMwIoCcRpP+3ehmwX9SUw7Ah5S42pA= - file: build/janet-${TRAVIS_TAG}-${TRAVIS_OS_NAME}.tar.gz - draft: true - skip_cleanup: true - on: - tags: true - repo: janet-lang/janet - condition: "$CC = clang" diff --git a/CHANGELOG.md b/CHANGELOG.md index b30f81ea..b6891e27 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,9 +2,74 @@ All notable changes to this project will be documented in this file. ## ??? - Unreleased +- Deadlocked channels will no longer exit early - instead they will hang, which is more intuitive. + +## 1.18.1 - 2021-10-16 +- Fix some documentation typos +- Fix - Set pipes passed to subprocess to blocking mode. +- Fix `-r` switch in repl. + +## 1.18.0 - 2021-10-10 +- Allow `ev/cancel` to work on already scheduled fibers. +- Fix bugs with ev/ module. +- Add optional `base` argument to scan-number +- Add `-i` flag to janet binary to make it easier to run image files from the command line +- Remove `thread/` module. +- Add `(number ...)` pattern to peg for more efficient number parsing using Janet's + scan-number function without immediate string creation. + +## 1.17.2 - 2021-09-18 +- Remove include of windows.h from janet.h. This caused issues on certain projects. +- Fix formatting in doc-format to better handle special characters in signatures. +- Fix some marshalling bugs. +- Add optional Makefile target to install jpm as well. +- Supervisor channels in threads will no longer include a wasteful copy of the fiber in every + message across a thread. +- Allow passing a closure to `ev/thread` as well as a whole fiber. +- Allow passing a closure directly to `ev/go` to spawn fibers on the event loop. + +## 1.17.1 - 2021-08-29 +- Fix docstring typos +- Add `make install-jpm-git` to make jpm co-install simpler if using the Makefile. +- Fix bugs with starting ev/threads and fiber marshaling. + +## 1.17.0 - 2021-08-21 +- Add the `-E` flag for one-liners with the `short-fn` syntax for argument passing. +- Add support for threaded abstract types. Threaded abstract types can easily be shared between threads. +- Deprecate the `thread` library. Use threaded channels and ev instead. +- Channels can now be marshalled. +- Add the ability to close channels with `ev/chan-close` (or `:close`). +- Add threaded channels with `ev/thread-chan`. +- Add `JANET_FN` and `JANET_REG` macros to more easily define C functions that export their source mapping information. +- Add `janet_interpreter_interupt` and `janet_loop1_interrupt` to interrupt the interpreter while running. +- Add `table/clear` +- Add build option to disable the threading library without disabling all threads. +- Remove JPM from the main Janet distribution. Instead, JPM must be installed + separately like any other package. +- Fix issue with `ev/go` when called with an initial value and supervisor. +- Add the C API functions `janet_vm_save` and `janet_vm_load` to allow +saving and restoring the entire VM state. + +## 1.16.1 - 2021-06-09 +- Add `maclintf` - a utility for adding linting messages when inside macros. +- Print source code of offending line on compiler warnings and errors. +- Fix some issues with linting and re-add missing `make docs`. +- Allow controlling linting with dynamic bindings `:lint-warn`, `:lint-error`, and `:lint-levels`. +- Add `-w` and `-x` command line flags to the `janet` binary to set linting thresholds. + linting thresholds are as follows: + - :none - will never be trigger. + - :relaxed - will only trigger on `:relaxed` lints. + - :normal - will trigger on `:relaxed` and `:normal` lints. + - :strict - will trigger on `:strict`, `:normal`, and `:relaxed` lints. This will catch the most issues + but can be distracting. + +## 1.16.0 - 2021-05-30 +- Add color documentation to the `doc` macro - enable/disable with `(dyn :doc-color)`. +- Remove simpler HTML docs from distribution - use website or built-in documentation instead. +- Add compiler warnings and deprecation levels. - Add `as-macro` to make using macros within quasiquote easier to do hygienically. - Expose `JANET_OUT_OF_MEMORY` as part of the Janet API. -- Add `native-deps` option to `decalre-native` in `jpm`. This lets native libraries link to other +- Add `native-deps` option to `declare-native` in `jpm`. This lets native libraries link to other native libraries when building with jpm. - Remove the `tarray` module. The functionality of typed arrays will be moved to an external module that can be installed via `jpm`. diff --git a/LICENSE b/LICENSE index 90add8f1..1ae1c981 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2020 Calvin Rose and contributors +Copyright (c) 2021 Calvin Rose and contributors Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in diff --git a/Makefile b/Makefile index d3a1a80c..ef30d701 100644 --- a/Makefile +++ b/Makefile @@ -36,6 +36,7 @@ JANET_PATH?=$(LIBDIR)/janet JANET_MANPATH?=$(PREFIX)/share/man/man1/ JANET_PKG_CONFIG_PATH?=$(LIBDIR)/pkgconfig JANET_DIST_DIR?=janet-dist +JPM_TAG?=master DEBUGGER=gdb SONAME_SETTER=-Wl,-soname, @@ -61,11 +62,18 @@ ifeq ($(UNAME), Darwin) else ifeq ($(UNAME), Linux) CLIBS:=$(CLIBS) -lrt -ldl endif + # For other unix likes, add flags here! ifeq ($(UNAME), Haiku) LDCONFIG:=true LDFLAGS=-Wl,--export-dynamic endif +# For Android (termux) +ifeq ($(UNAME), Linux) # uname on Darwin doesn't recognise -o +ifeq ($(shell uname -o), Android) + CLIBS:=$(CLIBS) -landroid-spawn +endif +endif $(shell mkdir -p build/core build/c build/boot) all: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.h @@ -113,12 +121,12 @@ JANET_CORE_SOURCES=src/core/abstract.c \ src/core/regalloc.c \ src/core/run.c \ src/core/specials.c \ + src/core/state.c \ src/core/string.c \ src/core/strtod.c \ src/core/struct.c \ src/core/symcache.c \ src/core/table.c \ - src/core/thread.c \ src/core/tuple.c \ src/core/util.c \ src/core/value.c \ @@ -157,7 +165,7 @@ build/c/janet.c: build/janet_boot src/boot/boot.janet ##### Amalgamation ##### ######################## -SONAME=libjanet.so.1.16 +SONAME=libjanet.so.1.18 build/c/shell.c: src/mainclient/shell.c cp $< $@ @@ -205,12 +213,10 @@ valgrind: $(JANET_TARGET) test: $(JANET_TARGET) $(TEST_PROGRAMS) for f in test/suite*.janet; do ./$(JANET_TARGET) "$$f" || exit; done for f in examples/*.janet; do ./$(JANET_TARGET) -k "$$f"; done - ./$(JANET_TARGET) -k jpm valtest: $(JANET_TARGET) $(TEST_PROGRAMS) for f in test/suite*.janet; do $(VALGRIND_COMMAND) ./$(JANET_TARGET) "$$f" || exit; done for f in examples/*.janet; do ./$(JANET_TARGET) -k "$$f"; done - $(VALGRIND_COMMAND) ./$(JANET_TARGET) -k jpm callgrind: $(JANET_TARGET) for f in test/suite*.janet; do valgrind --tool=callgrind ./$(JANET_TARGET) "$$f" || exit; done @@ -223,30 +229,33 @@ dist: build/janet-dist.tar.gz build/janet-%.tar.gz: $(JANET_TARGET) \ build/janet.h \ - jpm.1 janet.1 LICENSE CONTRIBUTING.md $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) \ - README.md build/c/janet.c build/c/shell.c jpm + janet.1 LICENSE CONTRIBUTING.md $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) \ + README.md build/c/janet.c build/c/shell.c mkdir -p build/$(JANET_DIST_DIR)/bin cp $(JANET_TARGET) build/$(JANET_DIST_DIR)/bin/ - cp jpm build/$(JANET_DIST_DIR)/bin/ mkdir -p build/$(JANET_DIST_DIR)/include cp build/janet.h build/$(JANET_DIST_DIR)/include/ mkdir -p build/$(JANET_DIST_DIR)/lib/ cp $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/$(JANET_DIST_DIR)/lib/ mkdir -p build/$(JANET_DIST_DIR)/man/man1/ - cp janet.1 jpm.1 build/$(JANET_DIST_DIR)/man/man1/ mkdir -p build/$(JANET_DIST_DIR)/src/ cp build/c/janet.c build/c/shell.c build/$(JANET_DIST_DIR)/src/ cp CONTRIBUTING.md LICENSE README.md build/$(JANET_DIST_DIR)/ cd build && tar -czvf ../$@ ./$(JANET_DIST_DIR) +######################### +##### Documentation ##### +######################### + +docs: build/doc.html + +build/doc.html: $(JANET_TARGET) tools/gendoc.janet + $(JANET_TARGET) tools/gendoc.janet > build/doc.html + ######################## ##### Installation ##### ######################## -build/jpm: jpm $(JANET_TARGET) - $(JANET_TARGET) tools/patch-jpm.janet jpm build/jpm "--libpath=$(LIBDIR)" "--headerpath=$(INCLUDEDIR)/janet" "--binpath=$(BINDIR)" - chmod +x build/jpm - .INTERMEDIATE: build/janet.pc build/janet.pc: $(JANET_TARGET) echo 'prefix=$(PREFIX)' > $@ @@ -262,7 +271,7 @@ build/janet.pc: $(JANET_TARGET) echo 'Libs: -L$${libdir} -ljanet' >> $@ echo 'Libs.private: $(CLIBS)' >> $@ -install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc build/jpm build/janet.h +install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc build/janet.h mkdir -p '$(DESTDIR)$(BINDIR)' cp $(JANET_TARGET) '$(DESTDIR)$(BINDIR)/janet' mkdir -p '$(DESTDIR)$(INCLUDEDIR)/janet' @@ -273,22 +282,30 @@ install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc cp $(JANET_STATIC_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.a' ln -sf $(SONAME) '$(DESTDIR)$(LIBDIR)/libjanet.so' ln -sf libjanet.so.$(shell $(JANET_TARGET) -e '(print janet/version)') $(DESTDIR)$(LIBDIR)/$(SONAME) - cp -rf build/jpm '$(DESTDIR)$(BINDIR)' mkdir -p '$(DESTDIR)$(JANET_MANPATH)' cp janet.1 '$(DESTDIR)$(JANET_MANPATH)' - cp jpm.1 '$(DESTDIR)$(JANET_MANPATH)' mkdir -p '$(DESTDIR)$(JANET_PKG_CONFIG_PATH)' cp build/janet.pc '$(DESTDIR)$(JANET_PKG_CONFIG_PATH)/janet.pc' [ -z '$(DESTDIR)' ] && $(LDCONFIG) || true +install-jpm-git: $(JANET_TARGET) + mkdir -p build + rm -rf build/jpm + git clone --depth=1 --branch='$(JPM_TAG)' https://github.com/janet-lang/jpm.git build/jpm + cd build/jpm && PREFIX='$(PREFIX)' \ + DESTDIR=$(DESTDIR) \ + JANET_MANPATH='$(JANET_MANPATH)' \ + JANET_HEADERPATH='$(INCLUDEDIR)/janet' \ + JANET_BINPATH='$(BINDIR)' \ + JANET_LIBPATH='$(LIBDIR)' \ + ../../$(JANET_TARGET) ./bootstrap.janet + uninstall: -rm '$(DESTDIR)$(BINDIR)/janet' - -rm '$(DESTDIR)$(BINDIR)/jpm' -rm -rf '$(DESTDIR)$(INCLUDEDIR)/janet' -rm -rf '$(DESTDIR)$(LIBDIR)'/libjanet.* -rm '$(DESTDIR)$(JANET_PKG_CONFIG_PATH)/janet.pc' -rm '$(DESTDIR)$(JANET_MANPATH)/janet.1' - -rm '$(DESTDIR)$(JANET_MANPATH)/jpm.1' # -rm -rf '$(DESTDIR)$(JANET_PATH)'/* - err on the side of correctness here ################# @@ -311,18 +328,7 @@ clean: -rm -rf test/install/build test/install/modpath test-install: - cd test/install \ - && rm -rf build .cache .manifests \ - && jpm --verbose build \ - && jpm --verbose test \ - && build/testexec \ - && jpm --verbose quickbin testexec.janet build/testexec2 \ - && build/testexec2 \ - && mkdir -p modpath \ - && jpm --verbose --testdeps --modpath=./modpath install https://github.com/janet-lang/json.git - cd test/install && jpm --verbose --test --modpath=./modpath install https://github.com/janet-lang/jhydro.git - cd test/install && jpm --verbose --test --modpath=./modpath install https://github.com/janet-lang/path.git - cd test/install && jpm --verbose --test --modpath=./modpath install https://github.com/janet-lang/argparse.git + echo "JPM has been removed from default install." help: @echo diff --git a/README.md b/README.md index 582ca17f..bb87f9db 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,9 @@ [![Join the chat](https://badges.gitter.im/janet-language/community.svg)](https://gitter.im/janet-language/community)   [![Appveyor Status](https://ci.appveyor.com/api/projects/status/bjraxrxexmt3sxyv/branch/master?svg=true)](https://ci.appveyor.com/project/bakpakin/janet/branch/master) -[![Build Status](https://travis-ci.org/janet-lang/janet.svg?branch=master)](https://travis-ci.org/janet-lang/janet) [![builds.sr.ht status](https://builds.sr.ht/~bakpakin/janet/commits/freebsd.yml.svg)](https://builds.sr.ht/~bakpakin/janet/commits/freebsd.yml?) [![builds.sr.ht status](https://builds.sr.ht/~bakpakin/janet/commits/openbsd.yml.svg)](https://builds.sr.ht/~bakpakin/janet/commits/openbsd.yml?) +[![Actions Status](https://github.com/janet-lang/janet/actions/workflows/test.yml/badge.svg)](https://github.com/janet-lang/janet/actions/workflows/test.yml) Janet logo @@ -30,6 +30,7 @@ Lua, but smaller than GNU Guile or Python. ## Features +* Configurable at build time - turn features on or off for a smaller or more featureful build * Minimal setup - one binary and you are good to go! * First-class closures * Garbage collection @@ -39,6 +40,8 @@ Lua, but smaller than GNU Guile or Python. * Mutable and immutable hashtables (table/struct) * Mutable and immutable strings (buffer/string) * Macros +* Multithreading +* Per-thread event loop for efficient evented IO * Byte code interpreter with an assembly interface, as well as bytecode verification * Tail call Optimization * Direct interop with C via abstract types and C functions @@ -211,7 +214,7 @@ Options are: -- : Stop handling options ``` -If installed, you can also run `man janet` and `man jpm` to get usage information. +If installed, you can also run `man janet` to get usage information. ## Embedding @@ -238,23 +241,19 @@ Gitter provides Matrix and irc bridges as well. ## FAQ -### Why is my terminal spitting out junk when I run the REPL? - -Make sure your terminal supports ANSI escape codes. Most modern terminals will -support these, but some older terminals, Windows consoles, or embedded terminals -will not. If your terminal does not support ANSI escape codes, run the REPL with -the `-n` flag, which disables color output. You can also try the `-s` if further issues -ensue. - ### Where is (favorite feature from other language)? It may exist, it may not. If you want to propose major language features, go ahead and open an issue, but they will likely by closed as "will not implement". Often, such features make one usecase simpler at the expense of 5 others by making the language more complicated. -### Where is the example code? +### Is there a language spec? -In the examples directory. +There is not currently a spec besides the documentation at https://janet-lang.org. + +### Is this Scheme/Common Lisp? Where are the cons cells? + +Nope. There are no cons cells here. ### Is this a Clojure port? @@ -266,14 +265,35 @@ Internally, Janet is not at all like Clojure. No. They are immutable arrays and hash tables. Don't try and use them like Clojure's vectors and maps, instead they work well as table keys or other identifiers. +### Can I do Object Oriented programming with Janet? + +To some extent, yes. However, it is not the recommended method of abstraction, and performance may suffer. +That said, tables can be used to make mutable objects with inheritance and polymorphism, where object +methods are implemeted with keywords. + +``` +(def Car @{:honk (fn [self msg] (print "car " self " goes " msg)) }) +(def my-car (table/setproto @{} Car)) +(:honk my-car "Beep!") +``` + ### Why can't we add (feature from Clojure) into the core? Usually, one of a few reasons: - Often, it already exists in a different form and the Clojure port would be redundant. - Clojure programs often generate a lot of garbage and rely on the JVM to clean it up. - Janet does not run on the JVM. We admittedly have a much more primitive GC. + Janet does not run on the JVM, and has a more primitive garbage collector. - We want to keep the Janet core small. With Lisps, usually a feature can be added as a library - without feeling "bolted on", especially when compared to ALGOL like languages. + without feeling "bolted on", especially when compared to ALGOL like languages. Adding features + to the core also makes it a bit more difficult keep Janet maximally portable. + +### Why is my terminal spitting out junk when I run the REPL? + +Make sure your terminal supports ANSI escape codes. Most modern terminals will +support these, but some older terminals, Windows consoles, or embedded terminals +will not. If your terminal does not support ANSI escape codes, run the REPL with +the `-n` flag, which disables color output. You can also try the `-s` if further issues +ensue. ## Why is it called "Janet"? diff --git a/appveyor.yml b/appveyor.yml index c0ee8e3f..b8895246 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -20,10 +20,6 @@ init: install: - set JANET_BUILD=%appveyor_repo_commit:~0,7% - build_win all - - refreshenv - # We need to reload vcvars after refreshing - - call "C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvarsall.bat" %platform% - - build_win test-install - set janet_outname=%appveyor_repo_tag_name% - if "%janet_outname%"=="" set /P janet_outname=> janet/version (peg/match ''(* :d+ `.` :d+ `.` :d+)) first print)" > build\version.txt janet.exe -e "(print (os/arch))" > build\arch.txt @@ -147,34 +150,6 @@ FOR %%a in (janet-*-windows-*-installer.msi) DO ( ) exit /b 0 -@rem Test the installation. -:TESTINSTALL -pushd test\install -call jpm clean -@if errorlevel 1 goto :TESTINSTALLFAIL -call jpm test -@if errorlevel 1 goto :TESTINSTALLFAIL -call jpm --verbose --modpath=. install https://github.com/janet-lang/json.git -@if errorlevel 1 goto :TESTINSTALLFAIL -call build\testexec -@if errorlevel 1 goto :TESTINSTALLFAIL -call jpm --verbose quickbin testexec.janet build\testexec2.exe -@if errorlevel 1 goto :TESTINSTALLFAIL -call build\testexec2.exe -@if errorlevel 1 goto :TESTINSTALLFAIL -call jpm --verbose --test --modpath=. install https://github.com/janet-lang/jhydro.git -@if errorlevel 1 goto :TESTINSTALLFAIL -call jpm --verbose --test --modpath=. install https://github.com/janet-lang/path.git -@if errorlevel 1 goto :TESTINSTALLFAIL -call jpm --verbose --test --modpath=. install https://github.com/janet-lang/argparse.git -@if errorlevel 1 goto :TESTINSTALLFAIL -popd -exit /b 0 - -:TESTINSTALLFAIL -popd -goto :TESTFAIL - @rem build, test, dist, install. Useful for local dev. :ALL call %0 build diff --git a/examples/evsleep.janet b/examples/evsleep.janet index 9ceeef0c..b2b0ea89 100644 --- a/examples/evsleep.janet +++ b/examples/evsleep.janet @@ -10,3 +10,13 @@ (ev/call worker :b 5) (ev/sleep 0.3) (ev/call worker :c 12) + +(defn worker2 + [name] + (repeat 10 + (ev/sleep 0.2) + (print name " working"))) + +(ev/go worker2 :bob) +(ev/go worker2 :joe) +(ev/go worker2 :sally) diff --git a/examples/threaded-channels.janet b/examples/threaded-channels.janet new file mode 100644 index 00000000..c4e1bc1d --- /dev/null +++ b/examples/threaded-channels.janet @@ -0,0 +1,22 @@ +(def chan (ev/thread-chan 10)) + +(ev/spawn + (ev/sleep 0) + (print "started fiber!") + (ev/give chan (math/random)) + (ev/give chan (math/random)) + (ev/give chan (math/random)) + (ev/sleep 0.5) + (for i 0 10 + (print "giving to channel...") + (ev/give chan (math/random)) + (ev/sleep 1)) + (print "finished fiber!") + (:close chan)) + +(ev/do-thread + (print "started thread!") + (ev/sleep 1) + (while (def x (do (print "taking from channel...") (ev/take chan))) + (print "got " x " from thread!")) + (print "finished thread!")) diff --git a/examples/threads.janet b/examples/threads.janet deleted file mode 100644 index ca40e166..00000000 --- a/examples/threads.janet +++ /dev/null @@ -1,68 +0,0 @@ -(defn worker-main - "Sends 11 messages back to parent" - [parent] - (def name (thread/receive)) - (def interval (thread/receive)) - (for i 0 10 - (os/sleep interval) - (:send parent (string/format "thread %s wakeup no. %d" name i))) - (:send parent name)) - -(defn make-worker - [name interval] - (-> (thread/new worker-main) - (:send name) - (:send interval))) - -(def bob (make-worker "bob" 0.02)) -(def joe (make-worker "joe" 0.03)) -(def sam (make-worker "sam" 0.05)) - -# Receive out of order -(for i 0 33 - (print (thread/receive))) - -# -# Recursive Thread Tree - should pause for a bit, and then print a cool zigzag. -# - -(def rng (math/rng (os/cryptorand 16))) - -(defn choose [& xs] - (in xs (:int rng (length xs)))) - -(defn worker-tree - [parent] - (def name (thread/receive)) - (def depth (thread/receive)) - (if (< depth 5) - (do - (defn subtree [] - (-> (thread/new worker-tree) - (:send (string name "/" (choose "bob" "marley" "harry" "suki" "anna" "yu"))) - (:send (inc depth)))) - (let [l (subtree) - r (subtree) - lrep (thread/receive) - rrep (thread/receive)] - (:send parent [name ;lrep ;rrep]))) - (do - (:send parent [name])))) - -(-> (thread/new worker-tree) (:send "adam") (:send 0)) -(def lines (thread/receive)) -(map print lines) - -# -# Receive timeout -# - -(def slow (make-worker "slow-loras" 0.5)) -(for i 0 50 - (try - (let [msg (thread/receive 0.1)] - (print "\n" msg)) - ([err] (prin ".") (:flush stdout)))) - -(print "\ndone timing, timeouts ending.") -(try (while true (print (thread/receive))) ([err] (print "done"))) diff --git a/janet.1 b/janet.1 index 1a9d5faa..2bb8560a 100644 --- a/janet.1 +++ b/janet.1 @@ -3,11 +3,14 @@ janet \- run the Janet language abstract machine .SH SYNOPSIS .B janet -[\fB\-hvsrpnqk\fR] +[\fB\-hvsrpnqik\fR] [\fB\-e\fR \fISOURCE\fR] +[\fB\-E\fR \fISOURCE ...ARGUMENTS\fR] [\fB\-l\fR \fIMODULE\fR] [\fB\-m\fR \fIPATH\fR] [\fB\-c\fR \fIMODULE JIMAGE\fR] +[\fB\-w\fR \fILEVEL\fR] +[\fB\-x\fR \fILEVEL\fR] [\fB\-\-\fR] .BR script .BR args ... @@ -160,6 +163,11 @@ Read raw input from stdin and forgo prompt history and other readline-like featu Execute a string of Janet source. Source code is executed in the order it is encountered, so earlier arguments are executed before later ones. +.TP +.BR \-E\ code arguments +Execute a single Janet expression as a Janet short-fn, passing the remaining command line arguments to the expression. This allows +more concise one-liners with command line arguments. + .TP .BR \-d Enable debug mode. On all terminating signals as well the debug signal, this will @@ -205,12 +213,28 @@ Precompiles Janet source code into an image, a binary dump that can be efficient Source should be a path to the Janet module to compile, and output should be the file path of resulting image. Output should usually end with the .jimage extension. +.TP +.BR \-i +When this flag is passed, a script passed to the interpreter will be treated as a janet image file +rather than a janet source file. + .TP .BR \-l\ lib Import a Janet module before running a script or repl. Multiple files can be loaded in this manner, and exports from each file will be made available to the script or repl. - +.TP +.BR \-w\ level +Set the warning linting level for Janet. +This linting level should be one of :relaxed, :none, :strict, :normal, or a +Janet number. Any linting message that is of a greater lint level than this setting will be displayed as +a warning, but not stop compilation or execution. +.TP +.BR \-x\ level +Set the error linting level for Janet. +This linting level should be one of :relaxed, :none, :strict, :normal, or a +Janet number. Any linting message that is of a greater lint level will cause a compilation error +and stop compilation. .TP .BR \-\- Stop parsing command line arguments. All arguments after this one will be considered file names diff --git a/jpm b/jpm deleted file mode 100755 index 2ce568a5..00000000 --- a/jpm +++ /dev/null @@ -1,1479 +0,0 @@ -#!/usr/bin/env janet - -# CLI tool for building janet projects. - -# -# Basic Path Settings -# - -# Allow changing the behavior via an environment variable -(def- host-os (keyword (string/ascii-lower (os/getenv "JPM_OS_WHICH" (os/which))))) -(defn- define-utils - [] - (def is-win (= host-os :windows)) - (defglobal 'is-win is-win) - (defglobal 'is-mac (= host-os :macos)) - (def sep (if is-win "\\" "/")) - (defglobal 'sep sep) - (defglobal 'objext (if is-win ".obj" ".o")) - (defglobal 'modext (if is-win ".dll" ".so")) - (defglobal 'statext (if is-win ".static.lib" ".a")) - (defglobal 'absprefix (if is-win "C:\\" "/"))) - -(define-utils) - -# -# Defaults -# - -###START### - -# Overriden on some installs. -# To configure this script, replace the code between -# the START and END comments and define a function -# (install-paths) that gives the the default paths -# to use. Trailing directory separator not expected. -# -# Example. -# -# (defn- install-paths [] -# {:headerpath "/usr/local/include/janet" -# :libpath "/usr/local/lib/janet" -# :binpath "/usr/local/bin" -# - -(def- exe-dir - "Directory containing jpm script" - (do - (def exe (dyn :current-file)) - (def i (last (string/find-all sep exe))) - (slice exe 0 i))) - -(defn- try-real [path] - "If os/realpath fails just use normal path." - (try (os/realpath path) ([_] path))) - -(defn- install-paths [] - {:headerpath (try-real (string exe-dir "/../include/janet")) - :libpath (try-real (string exe-dir "/../lib")) - :binpath exe-dir}) - -# If janetconf.h has been modified such that core janet functions and macros require -# linking to external libraries, modify this. -# -# Example - (def- extra-lflags ["-lmimalloc"]) - -###END### - -# Redefine utils in case the above section is overriden on some installs. -(define-utils) - -(compwhen (not (dyn 'extra-lflags)) - (def- extra-lflags [])) - -# Default based on janet binary location -(def JANET_HEADERPATH (or (os/getenv "JANET_HEADERPATH") - (get (install-paths) :headerpath))) -(def JANET_LIBPATH (or (os/getenv "JANET_LIBPATH") - (get (install-paths) :libpath))) -# We want setting JANET_PATH to contain installed binaries. However, it is convenient -# to have globally installed binaries got to the same place as jpm itself, which is on -# the $PATH. -(def JANET_BINPATH (or (os/getenv "JANET_BINPATH") - (if-let [mp (os/getenv "JANET_MODPATH")] (string mp "/bin")) - (if-let [mp (os/getenv "JANET_PATH")] (string mp "/bin")) - (get (install-paths) :binpath))) - -# modpath should only be derived from the syspath being used or an environment variable. -(def JANET_MODPATH (or (os/getenv "JANET_MODPATH") (dyn :syspath))) - -# -# Utilities -# - -(defn find-manifest-dir - "Get the path to the directory containing manifests for installed - packages." - [] - (string (dyn :modpath JANET_MODPATH) sep ".manifests")) - -(defn find-manifest - "Get the full path of a manifest file given a package name." - [name] - (string (find-manifest-dir) sep name ".jdn")) - -(defn find-cache - "Return the path to the global cache." - [] - (def path (dyn :modpath JANET_MODPATH)) - (string path sep ".cache")) - -(defn rm - "Remove a directory and all sub directories." - [path] - (case (os/lstat path :mode) - :directory (do - (each subpath (os/dir path) - (rm (string path sep subpath))) - (os/rmdir path)) - nil nil # do nothing if file does not exist - # Default, try to remove - (os/rm path))) - -(defn- rimraf - "Hard delete directory tree" - [path] - (if is-win - # windows get rid of read-only files - (when (os/stat path :mode) - (os/shell (string `rmdir /S /Q "` path `"`))) - (rm path))) - -(defn clear-cache - "Clear the global git cache." - [] - (def cache (find-cache)) - (print "clearing cache " cache "...") - (rimraf cache)) - -(defn clear-manifest - "Clear the global installation manifest." - [] - (def manifest (find-manifest-dir)) - (print "clearing manifests " manifest "...") - (rimraf manifest)) - -(def- default-pkglist - (or (os/getenv "JANET_PKGLIST") "https://github.com/janet-lang/pkgs.git")) - -(defn- pslurp - "Like slurp, but with file/popen instead file/open. Also trims output" - [cmd] - (string/trim (with [f (file/popen cmd)] (:read f :all)))) - -(def- path-splitter - "split paths on / and \\." - (peg/compile ~(any (* '(any (if-not (set `\/`) 1)) (+ (set `\/`) -1))))) - -(defn create-dirs - "Create all directories needed for a file (mkdir -p)." - [dest] - (def segs (peg/match path-splitter dest)) - (for i 1 (length segs) - (def path (string/join (slice segs 0 i) sep)) - (unless (empty? path) (os/mkdir path)))) - -(def- filepath-replacer - "Convert url with potential bad characters into a file path element." - (peg/compile ~(% (any (+ (/ '(set "<>:\"/\\|?*") "_") '1))))) - -(def- entry-replacer - "Convert url with potential bad characters into an entry-name" - (peg/compile ~(% (any (+ '(range "AZ" "az" "09" "__") (/ '1 ,|(string "_" ($ 0) "_"))))))) - -(defn entry-replace - "Escape special characters in the entry-name" - [name] - (get (peg/match entry-replacer name) 0)) - -(defn filepath-replace - "Remove special characters from a string or path - to make it into a path segment." - [repo] - (get (peg/match filepath-replacer repo) 0)) - -(defn shell - "Do a shell command" - [& args] - (if (dyn :verbose) - (print ;(interpose " " args))) - (os/execute args :px)) - -(defn copy - "Copy a file or directory recursively from one location to another." - [src dest] - (print "copying " src " to " dest "...") - (if is-win - (let [end (last (peg/match path-splitter src)) - isdir (= (os/stat src :mode) :directory)] - (shell "C:\\Windows\\System32\\xcopy.exe" - (string/replace "/" "\\" src) (string/replace "/" "\\" (if isdir (string dest "\\" end) dest)) - "/y" "/s" "/e" "/i")) - (shell "cp" "-rf" src dest))) - -(defn mkdir - "Create a directory if it doesn't exist. If it does exist, do nothing. - If we can't create it, give a friendly error. Return true if created, false if - existing. Throw an error if we can't create it." - [dir] - (os/mkdir dir)) - -(defn- abspath - "Create an absolute path. Does not resolve . and .. (useful for - generating entries in install manifest file)." - [path] - (if (if is-win - (peg/match '(+ "\\" (* (range "AZ" "az") ":\\")) path) - (string/has-prefix? "/" path)) - path - (string (os/cwd) sep path))) - -# -# Rule Engine -# - -(defn- getrules [] - (if-let [rules (dyn :rules)] rules (setdyn :rules @{}))) - -(defn- gettarget [target] - (def item ((getrules) target)) - (unless item (error (string "No rule for target " target))) - item) - -(defn add-dep - "Add a dependency to an existing rule. Useful for extending phony - rules or extending the dependency graph of existing rules." - [target dep] - (def [deps] (gettarget target)) - (unless (find |(= dep $) deps) - (array/push deps dep))) - -(defn- add-thunk - [target more &opt phony] - (def item (gettarget target)) - (def [_ thunks pthunks] item) - (array/push (if phony pthunks thunks) more) - item) - -(defn- rule-impl - [target deps thunk &opt phony] - (def rules (getrules)) - (unless (rules target) (put rules target @[(array/slice deps) @[] @[]])) - (each d deps (add-dep target d)) - (add-thunk target thunk phony)) - -(defmacro rule - "Add a rule to the rule graph." - [target deps & body] - ~(,rule-impl ,target ,deps (fn [] ,;body))) - -(defmacro phony - "Add a phony rule to the rule graph. A phony rule will run every time - (it is always considered out of date). Phony rules are good for defining - user facing tasks." - [target deps & body] - ~(,rule-impl ,target ,deps (fn [] nil ,;body) true)) - -(defmacro sh-rule - "Add a rule that invokes a shell command, and fails if the command returns non-zero." - [target deps & body] - ~(,rule-impl ,target ,deps (fn [] (,assert (,zero? (,os/shell (,string ,;body))))))) - -(defmacro sh-phony - "Add a phony rule that invokes a shell command, and fails if the command returns non-zero." - [target deps & body] - ~(,rule-impl ,target ,deps (fn [] (,assert (,zero? (,os/shell (,string ,;body))))) true)) - -(defmacro add-body - "Add recipe code to an existing rule. This makes existing rules do more but - does not modify the dependency graph." - [target & body] - ~(,add-thunk ,target (fn [] ,;body))) - -(defn- needs-build - [dest src] - (let [mod-dest (os/stat dest :modified) - mod-src (os/stat src :modified)] - (< mod-dest mod-src))) - -(defn- needs-build-some - [dest sources] - (def f (file/open dest)) - (if (not f) (break true)) - (file/close f) - (some (partial needs-build dest) sources)) - -(defn do-rule - "Evaluate a given rule." - [target] - (def item ((getrules) target)) - (unless item - (if (os/stat target :mode) - (break target) - (error (string "No rule for file " target " found.")))) - (def [deps thunks phony] item) - (def realdeps (seq [dep :in deps :let [x (do-rule dep)] :when x] x)) - (each thunk phony (thunk)) - (unless (empty? thunks) - (when (needs-build-some target realdeps) - (each thunk thunks (thunk)) - target))) - -# -# Importing a file -# - -(def- _env (fiber/getenv (fiber/current))) - -(defn- proto-flatten - [into x] - (when x - (proto-flatten into (table/getproto x)) - (merge-into into x)) - into) - -(defn make-jpm-env - "Build an environment table with jpm functions preloaded." - [&opt no-deps] - (def env (make-env)) - (put env :jpm-no-deps no-deps) - (loop [k :keys _env :when (symbol? k)] - (unless ((_env k) :private) (put env k (_env k)))) - env) - -(defn require-jpm - "Require a jpm file project file. This is different from a normal require - in that code is loaded in the jpm environment." - [path &opt no-deps] - (unless (os/stat path :mode) - (error (string "cannot open " path))) - (def env (make-jpm-env no-deps)) - (def currenv (proto-flatten @{} (fiber/getenv (fiber/current)))) - (loop [k :keys currenv :when (keyword? k)] - (put env k (currenv k))) - (dofile path :env env :exit true) - env) - -(defn import-rules - "Import another file that defines more rules. This ruleset - is merged into the current ruleset." - [path &opt no-deps] - (def env (require-jpm path no-deps)) - (when-let [rules (env :rules)] (merge-into (getrules) rules)) - env) - -(defmacro post-deps - "Run code at the top level if jpm dependencies are installed. Build - code that imports dependencies should be wrapped with this macro, as project.janet - needs to be able to run successfully even without dependencies installed." - [& body] - (unless (dyn :jpm-no-deps) - ~',(reduce |(eval $1) nil body))) - -# -# C Compilation -# - -(def default-compiler (or (os/getenv "CC") (if is-win "cl.exe" "cc"))) -(def default-cpp-compiler (or (os/getenv "CXX") (if is-win "cl.exe" "c++"))) -(def default-linker (or (os/getenv "CC") (if is-win "link.exe" "cc"))) -(def default-cpp-linker (or (os/getenv "CXX") (if is-win "link.exe" "c++"))) -(def default-archiver (or (os/getenv "AR") (if is-win "lib.exe" "ar"))) - -# Detect threads -(def env (fiber/getenv (fiber/current))) -(def threads? (not (not (env 'thread/new)))) -(def- thread-flags - (if is-win [] - (if threads? ["-lpthread"] []))) - -# flags needed for the janet binary and compiling standalone -# executables. -(def janet-lflags - (case host-os - :macos ["-ldl" "-lm" ;thread-flags ;extra-lflags] - :windows [;thread-flags ;extra-lflags] - :linux ["-lm" "-ldl" "-lrt" ;thread-flags ;extra-lflags] - ["-lm" ;thread-flags ;extra-lflags])) -(def janet-ldflags []) -(def janet-cflags []) - -# Default flags for natives, but not required -# How can we better detect the need for -pthread? -# we probably want to better detect compiler -(def default-lflags (if is-win ["/nologo"] [])) -(def default-cflags - (if is-win - ["/nologo" "/MD"] - ["-std=c99" "-Wall" "-Wextra"])) -(def default-cppflags - (if is-win - ["/nologo" "/MD" "/EHsc"] - ["-std=c++11" "-Wall" "-Wextra"])) -(def default-ldflags []) - -# Required flags for dynamic libraries. These -# are used no matter what for dynamic libraries. -(def- dynamic-cflags - (if is-win - ["/LD"] - ["-fPIC"])) -(def- dynamic-lflags - (if is-win - ["/DLL"] - (if is-mac - ["-shared" "-undefined" "dynamic_lookup" ;thread-flags] - ["-shared" ;thread-flags]))) - -(defn- opt - "Get an option, allowing overrides via dynamic bindings AND some - default value dflt if no dynamic binding is set." - [opts key dflt] - (def ret (or (opts key) (dyn key dflt))) - (if (= nil ret) - (error (string "option :" key " not set"))) - ret) - -(defn check-cc - "Ensure we have a c compiler." - [] - (if is-win - (do - (if (os/getenv "INCLUDE") (break)) - (error "Run jpm inside a Developer Command Prompt. - jpm needs a c compiler to compile natives. You can install the MSVC compiler from - microsoft.com")) - (do))) - -(defn- embed-name - "Rename a janet symbol for embedding." - [path] - (->> path - (string/replace-all "\\" "___") - (string/replace-all "/" "___") - (string/replace-all ".janet" ""))) - -(defn- out-path - "Take a source file path and convert it to an output path." - [path from-ext to-ext] - (->> path - (string/replace-all "\\" "___") - (string/replace-all "/" "___") - (string/replace-all from-ext to-ext) - (string "build" sep))) - -(defn- make-define - "Generate strings for adding custom defines to the compiler." - [define value] - (if value - (string "-D" define "=" value) - (string "-D" define))) - -(defn- make-defines - "Generate many defines. Takes a dictionary of defines. If a value is - true, generates -DNAME (/DNAME on windows), otherwise -DNAME=value." - [defines] - (seq [[d v] :pairs defines] (make-define d (if (not= v true) v)))) - -(defn- getcflags - "Generate the c flags from the input options." - [opts] - @[;(opt opts :cflags default-cflags) - (string "-I" (dyn :headerpath JANET_HEADERPATH)) - (string "-I" (dyn :modpath JANET_MODPATH)) - (string "-O" (opt opts :optimize 2))]) - -(defn- getcppflags - "Generate the cpp flags from the input options." - [opts] - @[;(opt opts :cppflags default-cppflags) - (string "-I" (dyn :headerpath JANET_HEADERPATH)) - (string "-I" (dyn :modpath JANET_MODPATH)) - (string "-O" (opt opts :optimize 2))]) - -(defn- entry-name - "Name of symbol that enters static compilation of a module." - [name] - (string "janet_module_entry_" (entry-replace name))) - -(defn- compile-c - "Compile a C file into an object file." - [opts src dest &opt static?] - (def cc (opt opts :compiler default-compiler)) - (def cflags [;(getcflags opts) ;(if static? [] dynamic-cflags)]) - (def entry-defines (if-let [n (and static? (opts :entry-name))] - [(make-define "JANET_ENTRY_NAME" n)] - [])) - (def defines [;(make-defines (opt opts :defines {})) ;entry-defines]) - (def headers (or (opts :headers) [])) - (rule dest [src ;headers] - (check-cc) - (print "compiling " src " to " dest "...") - (create-dirs dest) - (if is-win - (shell cc ;defines "/c" ;cflags (string "/Fo" dest) src) - (shell cc "-c" src ;defines ;cflags "-o" dest)))) - -(defn- compile-cpp - "Compile a C++ file into an object file." - [opts src dest &opt static?] - (def cpp (opt opts :cpp-compiler default-cpp-compiler)) - (def cflags [;(getcppflags opts) ;(if static? [] dynamic-cflags)]) - (def entry-defines (if-let [n (and static? (opts :entry-name))] - [(make-define "JANET_ENTRY_NAME" n)] - [])) - (def defines [;(make-defines (opt opts :defines {})) ;entry-defines]) - (def headers (or (opts :headers) [])) - (rule dest [src ;headers] - (check-cc) - (print "compiling " src " to " dest "...") - (create-dirs dest) - (if is-win - (shell cpp ;defines "/c" ;cflags (string "/Fo" dest) src) - (shell cpp "-c" src ;defines ;cflags "-o" dest)))) - -(defn- libjanet - "Find libjanet.a (or libjanet.lib on windows) at compile time" - [] - (def libpath (dyn :libpath JANET_LIBPATH)) - (unless libpath - (error "cannot find libpath: provide --libpath or JANET_LIBPATH")) - (string (dyn :libpath JANET_LIBPATH) - sep - (if is-win "libjanet.lib" "libjanet.a"))) - -(defn- win-import-library - "On windows, an import library is needed to link to a dll statically." - [] - (def hpath (dyn :headerpath JANET_HEADERPATH)) - (unless hpath - (error "cannot find headerpath: provide --headerpath or JANET_HEADERPATH")) - (string hpath `\\janet.lib`)) - -(defn- link-c - "Link C or C++ object files together to make a native module." - [has-cpp opts target & objects] - (def linker - (if has-cpp - (opt opts (if is-win :cpp-linker :cpp-compiler) default-cpp-linker) - (opt opts (if is-win :linker :compiler) default-linker))) - (def cflags ((if has-cpp getcppflags getcflags) opts)) - (def lflags [;(opt opts :lflags default-lflags) - ;(if (opts :static) [] dynamic-lflags)]) - (def deplibs (get opts :native-deps [])) - (def dep-ldflags (seq [x :in deplibs] (string (dyn :modpath JANET_MODPATH) sep x modext))) - # Use import libs on windows - we need an import lib to link natives to other natives. - (def dep-importlibs (seq [x :in deplibs] (string (dyn :modpath JANET_MODPATH) sep x ".lib"))) - (def ldflags [;(opt opts :ldflags []) ;dep-ldflags]) - (rule target objects - (check-cc) - (print "linking " target "...") - (create-dirs target) - (if is-win - (shell linker ;ldflags (string "/OUT:" target) ;objects (win-import-library) ;dep-importlibs ;lflags) - (shell linker ;cflags ;ldflags `-o` target ;objects ;lflags)))) - -(defn- archive-c - "Link object files together to make a static library." - [opts target & objects] - (def ar (opt opts :archiver default-archiver)) - (rule target objects - (check-cc) - (print "creating static library " target "...") - (create-dirs target) - (if is-win - (shell ar "/nologo" (string "/out:" target) ;objects) - (shell ar "rcs" target ;objects)))) - -(defn- create-buffer-c-impl - [bytes dest name] - (create-dirs dest) - (def out (file/open dest :w)) - (def chunks (seq [b :in bytes] (string b))) - (file/write out - "#include \n" - "static const unsigned char bytes[] = {" - (string/join (interpose ", " chunks)) - "};\n\n" - "const unsigned char *" name "_embed = bytes;\n" - "size_t " name "_embed_size = sizeof(bytes);\n") - (file/close out)) - -(defn- create-buffer-c - "Inline raw byte file as a c file." - [source dest name] - (rule dest [source] - (print "generating " dest "...") - (create-dirs dest) - (with [f (file/open source :r)] - (create-buffer-c-impl (:read f :all) dest name)))) - -(def- root-env (table/getproto (fiber/getenv (fiber/current)))) - -(defn- modpath-to-meta - "Get the meta file path (.meta.janet) corresponding to a native module path (.so)." - [path] - (string (string/slice path 0 (- (length modext))) "meta.janet")) - -(defn- modpath-to-static - "Get the static library (.a) path corresponding to a native module path (.so)." - [path] - (string (string/slice path 0 (- -1 (length modext))) statext)) - -(defn- make-bin-source - [declarations lookup-into-invocations no-core] - (string - declarations - ``` - -int main(int argc, const char **argv) { - -#if defined(JANET_PRF) - uint8_t hash_key[JANET_HASH_KEY_SIZE + 1]; -#ifdef JANET_REDUCED_OS - char *envvar = NULL; -#else - char *envvar = getenv("JANET_HASHSEED"); -#endif - if (NULL != envvar) { - strncpy((char *) hash_key, envvar, sizeof(hash_key) - 1); - } else if (janet_cryptorand(hash_key, JANET_HASH_KEY_SIZE) != 0) { - fputs("unable to initialize janet PRF hash function.\n", stderr); - return 1; - } - janet_init_hash_key(hash_key); -#endif - - janet_init(); - - ``` - (if no-core - ``` - /* Get core env */ - JanetTable *env = janet_table(8); - JanetTable *lookup = janet_core_lookup_table(NULL); - JanetTable *temptab; - int handle = janet_gclock(); - ``` - ``` - /* Get core env */ - JanetTable *env = janet_core_env(NULL); - JanetTable *lookup = janet_env_lookup(env); - JanetTable *temptab; - int handle = janet_gclock(); - ```) - lookup-into-invocations - ``` - /* Unmarshal bytecode */ - Janet marsh_out = janet_unmarshal( - janet_payload_image_embed, - janet_payload_image_embed_size, - 0, - lookup, - NULL); - - /* Verify the marshalled object is a function */ - if (!janet_checktype(marsh_out, JANET_FUNCTION)) { - fprintf(stderr, "invalid bytecode image - expected function."); - return 1; - } - JanetFunction *jfunc = janet_unwrap_function(marsh_out); - - /* Check arity */ - janet_arity(argc, jfunc->def->min_arity, jfunc->def->max_arity); - - /* Collect command line arguments */ - JanetArray *args = janet_array(argc); - for (int i = 0; i < argc; i++) { - janet_array_push(args, janet_cstringv(argv[i])); - } - - /* Create enviornment */ - temptab = env; - janet_table_put(temptab, janet_ckeywordv("args"), janet_wrap_array(args)); - janet_gcroot(janet_wrap_table(temptab)); - - /* Unlock GC */ - janet_gcunlock(handle); - - /* Run everything */ - JanetFiber *fiber = janet_fiber(jfunc, 64, argc, argc ? args->data : NULL); - fiber->env = temptab; -#ifdef JANET_EV - janet_gcroot(janet_wrap_fiber(fiber)); - janet_schedule(fiber, janet_wrap_nil()); - janet_loop(); - int status = janet_fiber_status(fiber); - janet_deinit(); - return status; -#else - Janet out; - JanetSignal result = janet_continue(fiber, janet_wrap_nil(), &out); - if (result != JANET_SIGNAL_OK && result != JANET_SIGNAL_EVENT) { - janet_stacktrace(fiber, out); - janet_deinit(); - return result; - } - janet_deinit(); - return 0; -#endif -} - -```)) - -(defn- create-executable - "Links an image with libjanet.a (or .lib) to produce an - executable. Also will try to link native modules into the - final executable as well." - [opts source dest no-core] - - # Create executable's janet image - (def cimage_dest (string dest ".c")) - (def no-compile (opts :no-compile)) - (rule (if no-compile cimage_dest dest) [source] - (check-cc) - (print "generating executable c source...") - (create-dirs dest) - # Load entry environment and get main function. - (def entry-env (dofile source)) - (def main ((entry-env 'main) :value)) - (def dep-lflags @[]) - (def dep-ldflags @[]) - - # Create marshalling dictionary - (def mdict1 (invert (env-lookup root-env))) - (def mdict - (if no-core - (let [temp @{}] - (eachp [k v] mdict1 - (if (or (cfunction? k) (abstract? k)) - (put temp k v))) - temp) - mdict1)) - - # Load all native modules - (def prefixes @{}) - (def static-libs @[]) - (loop [[name m] :pairs module/cache - :let [n (m :native)] - :when n - :let [prefix (gensym)]] - (print "found native " n "...") - (put prefixes prefix n) - (array/push static-libs (modpath-to-static n)) - (def oldproto (table/getproto m)) - (table/setproto m nil) - (loop [[sym value] :pairs (env-lookup m)] - (put mdict value (symbol prefix sym))) - (table/setproto m oldproto)) - - # Find static modules - (var has-cpp false) - (def declarations @"") - (def lookup-into-invocations @"") - (loop [[prefix name] :pairs prefixes] - (def meta (eval-string (slurp (modpath-to-meta name)))) - (if (meta :cpp) (set has-cpp true)) - (buffer/push-string lookup-into-invocations - " temptab = janet_table(0);\n" - " temptab->proto = env;\n" - " " (meta :static-entry) "(temptab);\n" - " janet_env_lookup_into(lookup, temptab, \"" - prefix - "\", 0);\n\n") - (when-let [lfs (meta :lflags)] - (array/concat dep-lflags lfs)) - (when-let [lfs (meta :ldflags)] - (array/concat dep-ldflags lfs)) - (buffer/push-string declarations - "extern void " - (meta :static-entry) - "(JanetTable *);\n")) - - # Build image - (def image (marshal main mdict)) - # Make image byte buffer - (create-buffer-c-impl image cimage_dest "janet_payload_image") - # Append main function - (spit cimage_dest (make-bin-source declarations lookup-into-invocations no-core) :ab) - (def oimage_dest (out-path cimage_dest ".c" ".o")) - # Compile and link final exectable - (unless no-compile - (def ldflags [;dep-ldflags ;(opt opts :ldflags []) ;janet-ldflags]) - (def lflags [;static-libs (libjanet) ;dep-lflags ;(opt opts :lflags default-lflags) ;janet-lflags]) - (def defines (make-defines (opt opts :defines {}))) - (def cc (opt opts :compiler default-compiler)) - (def cflags [;(getcflags opts) ;janet-cflags]) - (check-cc) - (print "compiling " cimage_dest " to " oimage_dest "...") - (create-dirs oimage_dest) - (if is-win - (shell cc ;defines "/c" ;cflags (string "/Fo" oimage_dest) cimage_dest) - (shell cc "-c" cimage_dest ;defines ;cflags "-o" oimage_dest)) - (if has-cpp - (let [linker (opt opts (if is-win :cpp-linker :cpp-compiler) default-cpp-linker) - cppflags [;(getcppflags opts) ;janet-cflags]] - (print "linking " dest "...") - (if is-win - (shell linker ;ldflags (string "/OUT:" dest) oimage_dest ;lflags) - (shell linker ;cppflags ;ldflags `-o` dest oimage_dest ;lflags))) - (let [linker (opt opts (if is-win :linker :compiler) default-linker)] - (print "linking " dest "...") - (create-dirs dest) - (if is-win - (shell linker ;ldflags (string "/OUT:" dest) oimage_dest ;lflags) - (shell linker ;cflags ;ldflags `-o` dest oimage_dest ;lflags))))))) - -# -# Installation and Dependencies -# - -(var- stored-git-path nil) -(defn- git-path - "Get the location of git such that it can be passed as an argument to os/execute." - "(Some builds/configurations of windows don't like just the string 'git')" - [] - (if stored-git-path (break stored-git-path)) - (set stored-git-path - (if is-win - (or (os/getenv "JANET_GIT") (first (string/split "\n" (pslurp "where git")))) - (os/getenv "JANET_GIT" "git")))) - -(defn uninstall - "Uninstall bundle named name" - [name] - (def manifest (find-manifest name)) - (when-with [f (file/open manifest)] - (def man (parse (:read f :all))) - (each path (get man :paths []) - (print "removing " path) - (rm path)) - (print "removing manifest " manifest) - (:close f) # I hate windows - (rm manifest) - (print "Uninstalled."))) - -(defn install-git - "Install a bundle from git. If the bundle is already installed, the bundle - is reinistalled (but not rebuilt if artifacts are cached)." - [repotab &opt recurse no-deps] - (def repo (if (string? repotab) repotab (repotab :repo))) - (def tag (unless (string? repotab) (repotab :tag))) - # prevent infinite recursion (very unlikely, but consider - # 'my-package "my-package" in the package listing) - (when (> (or recurse 0) 100) - (error "too many references resolving package url")) - # Handle short names - (unless (string/find ":" repo) - (def pkgs - (try (require "pkgs") - ([err f] - (install-git (dyn :pkglist default-pkglist)) - (require "pkgs")))) - (def next-repo (get-in pkgs ['packages :value (symbol repo)])) - (unless next-repo - (error (string "package " repo " not found."))) - (unless (or (string? next-repo) (dictionary? next-repo)) - (error (string "expected string or table for repository, got " next-repo))) - (break (install-git next-repo (if recurse (inc recurse) 0)))) - (def cache (find-cache)) - (mkdir cache) - (def id (filepath-replace repo)) - (def module-dir (string cache sep id)) - (var fresh false) - (if (dyn :offline) - (if (not= :directory (os/stat module-dir :mode)) - (error (string "did not find cached repo for dependency " repo)) - (set fresh true)) - (when (mkdir module-dir) - (set fresh true) - (print "cloning repository " repo " to " module-dir) - (unless (zero? (os/execute [(git-path) "clone" repo module-dir] :p)) - (rimraf module-dir) - (error (string "could not clone git dependency " repo))))) - (def olddir (os/cwd)) - (try - (with-dyns [:rules @{} - :modpath (abspath (dyn :modpath JANET_MODPATH)) - :headerpath (abspath (dyn :headerpath JANET_HEADERPATH)) - :libpath (abspath (dyn :libpath JANET_LIBPATH)) - :binpath (abspath (dyn :binpath JANET_BINPATH))] - (os/cd module-dir) - (unless fresh - (os/execute [(git-path) "pull" "origin" "master" "--ff-only"] :p)) - (when tag - (os/execute [(git-path) "reset" "--hard" tag] :p)) - (unless (dyn :offline) - (os/execute [(git-path) "submodule" "update" "--init" "--recursive"] :p)) - (import-rules "./project.janet" true) - (unless no-deps (do-rule "install-deps")) - (do-rule "build") - (do-rule "install")) - ([err f] (print "Error building git repository dependency: " err) (propagate err f))) - (os/cd olddir)) - -(defn install-rule - "Add install and uninstall rule for moving file from src into destdir." - [src destdir] - (def parts (peg/match path-splitter src)) - (def name (last parts)) - (def path (string destdir sep name)) - (array/push (dyn :installed-files) path) - (phony "install" [] - (mkdir destdir) - (copy src destdir))) - -(defn- make-lockfile - [&opt filename] - (default filename "lockfile.jdn") - (def cwd (os/cwd)) - (def packages @[]) - # Read installed modules from manifests - (def mdir (find-manifest-dir)) - (each man (os/dir mdir) - (def package (parse (slurp (string mdir sep man)))) - (if (and (dictionary? package) (package :repo) (package :sha)) - (array/push packages package) - (print "Cannot add local or malformed package " mdir sep man " to lockfile, skipping..."))) - # Put in correct order, such that a package is preceded by all of its dependencies - (def ordered-packages @[]) - (def resolved @{}) - (while (< (length ordered-packages) (length packages)) - (var made-progress false) - (each p packages - (def {:repo r :sha s :dependencies d} p) - (def dep-urls (map |(if (string? $) $ ($ :repo)) d)) - (unless (resolved r) - (when (all resolved dep-urls) - (array/push ordered-packages {:repo r :sha s}) - (set made-progress true) - (put resolved r true)))) - (unless made-progress - (error (string/format "could not resolve package order for: %j" - (filter (complement resolved) (map |($ :repo) packages)))))) - # Write to file, manual format for better diffs. - (with [f (file/open filename :w)] - (with-dyns [:out f] - (prin "@[") - (eachk i ordered-packages - (unless (zero? i) - (prin "\n ")) - (prinf "%j" (ordered-packages i))) - (print "]")))) - -(defn- load-lockfile - [&opt filename] - (default filename "lockfile.jdn") - (def lockarray (parse (slurp filename))) - (each {:repo url :sha sha} lockarray - (install-git {:repo url :tag sha} nil true))) - -# -# Declaring Artifacts - used in project.janet, targets specifically -# tailored for janet. -# - -(defn declare-native - "Declare a native module. This is a shared library that can be loaded - dynamically by a janet runtime. This also builds a static libary that - can be used to bundle janet code and native into a single executable." - [&keys opts] - (def sources (opts :source)) - (def name (opts :name)) - (def path (dyn :modpath JANET_MODPATH)) - - # Make dynamic module - (def lname (string "build" sep name modext)) - - # Get objects to build with - (var has-cpp false) - (def objects - (seq [src :in sources] - (def suffix - (cond - (string/has-suffix? ".cpp" src) ".cpp" - (string/has-suffix? ".cc" src) ".cc" - (string/has-suffix? ".c" src) ".c" - (errorf "unknown source file type: %s, expected .c, .cc, or .cpp" src))) - (def op (out-path src suffix objext)) - (if (= suffix ".c") - (compile-c opts src op) - (do (compile-cpp opts src op) - (set has-cpp true))) - op)) - - (when-let [embedded (opts :embedded)] - (loop [src :in embedded] - (def c-src (out-path src ".janet" ".janet.c")) - (def o-src (out-path src ".janet" (if is-win ".janet.obj" ".janet.o"))) - (array/push objects o-src) - (create-buffer-c src c-src (embed-name src)) - (compile-c opts c-src o-src))) - (link-c has-cpp opts lname ;objects) - (add-dep "build" lname) - (install-rule lname path) - - # Add meta file - (def metaname (modpath-to-meta lname)) - (def ename (entry-name name)) - (rule metaname [] - (print "generating meta file " metaname "...") - (spit metaname (string/format - "# Metadata for static library %s\n\n%.20p" - (string name statext) - {:static-entry ename - :cpp has-cpp - :ldflags ~',(opts :ldflags) - :lflags ~',(opts :lflags)}))) - (add-dep "build" metaname) - (install-rule metaname path) - - # Make static module - (unless (dyn :nostatic) - (def sname (string "build" sep name statext)) - (def opts (merge @{:entry-name ename} opts)) - (def sobjext (string ".static" objext)) - (def sjobjext (string ".janet" sobjext)) - - # Get static objects - (def sobjects - (seq [src :in sources] - (def suffix - (cond - (string/has-suffix? ".cpp" src) ".cpp" - (string/has-suffix? ".cc" src) ".cc" - (string/has-suffix? ".c" src) ".c" - (errorf "unknown source file type: %s, expected .c, .cc, or .cpp" src))) - (def op (out-path src suffix sobjext)) - (if (= suffix ".c") - (compile-c opts src op true) - (compile-cpp opts src op true)) - op)) - - (when-let [embedded (opts :embedded)] - (loop [src :in embedded] - (def c-src (out-path src ".janet" ".janet.c")) - (def o-src (out-path src ".janet" sjobjext)) - (array/push sobjects o-src) - # Buffer c-src is already declared by dynamic module - (compile-c opts c-src o-src true))) - (archive-c opts sname ;sobjects) - (add-dep "build" sname) - (install-rule sname path))) - -(defn declare-source - "Create Janet modules. This does not actually build the module(s), - but registers them for packaging and installation. :source should be an - array of files and directores to copy into JANET_MODPATH or JANET_PATH. - :prefix can optionally be given to modify the destination path to be - (string JANET_PATH prefix source)." - [&keys {:source sources :prefix prefix}] - (def path (string (dyn :modpath JANET_MODPATH) (or prefix ""))) - (if (bytes? sources) - (install-rule sources path) - (each s sources - (install-rule s path)))) - -(defn declare-headers - "Declare headers for a library installation. Installed headers can be used by other native - libraries." - [&keys {:headers headers :prefix prefix}] - (def path (string (dyn :modpath JANET_MODPATH) (or prefix ""))) - (if (bytes? headers) - (install-rule headers path) - (each h headers - (install-rule h path)))) - -(defn declare-bin - "Declare a generic file to be installed as an executable." - [&keys {:main main}] - (install-rule main (dyn :binpath JANET_BINPATH))) - -(defn declare-executable - "Declare a janet file to be the entry of a standalone executable program. The entry - file is evaluated and a main function is looked for in the entry file. This function - is marshalled into bytecode which is then embedded in a final executable for distribution.\n\n - This executable can be installed as well to the --binpath given." - [&keys {:install install :name name :entry entry :headers headers - :cflags cflags :lflags lflags :deps deps :ldflags ldflags - :no-compile no-compile :no-core no-core}] - (def name (if is-win (string name ".exe") name)) - (def dest (string "build" sep name)) - (create-executable @{:cflags cflags :lflags lflags :ldflags ldflags :no-compile no-compile} entry dest no-core) - (if no-compile - (let [cdest (string dest ".c")] - (add-dep "build" cdest)) - (do - (add-dep "build" dest) - (when headers - (each h headers (add-dep dest h))) - (when deps - (each d deps (add-dep dest d))) - (when install - (install-rule dest (dyn :binpath JANET_BINPATH)))))) - -(defn declare-binscript - ``Declare a janet file to be installed as an executable script. Creates - a shim on windows. If hardcode is true, will insert code into the script - such that it will run correctly even when JANET_PATH is changed. if auto-shebang - is truthy, will also automatically insert a correct shebang line. - `` - [&keys {:main main :hardcode-syspath hardcode :is-janet is-janet}] - (def binpath (dyn :binpath JANET_BINPATH)) - (def auto-shebang (and is-janet (dyn :auto-shebang))) - (if (or auto-shebang hardcode) - (let [syspath (dyn :modpath JANET_MODPATH)] - (def parts (peg/match path-splitter main)) - (def name (last parts)) - (def path (string binpath sep name)) - (array/push (dyn :installed-files) path) - (phony "install" [] - (def contents - (with [f (file/open main)] - (def first-line (:read f :line)) - (def second-line (string/format "(put root-env :syspath %v)\n" syspath)) - (def rest (:read f :all)) - (string (if auto-shebang - (string "#!" (dyn :binpath JANET_BINPATH) "/janet\n")) - first-line (if hardcode second-line) rest))) - (create-dirs path) - (spit path contents) - (unless is-win (shell "chmod" "+x" path)))) - (install-rule main binpath)) - # Create a dud batch file when on windows. - (when is-win - (def name (last (peg/match path-splitter main))) - (def fullname (string binpath sep name)) - (def bat (string "@echo off\r\njanet \"" fullname "\" %*")) - (def newname (string binpath sep name ".bat")) - (array/push (dyn :installed-files) newname) - (phony "install" [] - (spit newname bat)))) - -(defn- print-rule-tree - "Show dependencies for a given rule recursively in a nice tree." - [root depth prefix prefix-part] - (print prefix root) - (when-let [[root-deps] ((getrules) root)] - (when (pos? depth) - (def l (-> root-deps length dec)) - (eachp [i d] (sorted root-deps) - (print-rule-tree - d (dec depth) - (string prefix-part (if (= i l) " └─" " ├─")) - (string prefix-part (if (= i l) " " " │ "))))))) - -(defn declare-archive - "Build a janet archive. This is a file that bundles together many janet - scripts into a janet image. This file can the be moved to any machine with - a janet vm and the required dependencies and run there." - [&keys opts] - (def entry (opts :entry)) - (def name (opts :name)) - (def iname (string "build" sep name ".jimage")) - (rule iname (or (opts :deps) []) - (create-dirs iname) - (spit iname (make-image (require entry)))) - (def path (dyn :modpath JANET_MODPATH)) - (add-dep "build" iname) - (install-rule iname path)) - -(defn declare-project - "Define your project metadata. This should - be the first declaration in a project.janet file. - Also sets up basic phony targets like clean, build, test, etc." - [&keys meta] - (setdyn :project meta) - - (def installed-files @[]) - (def manifests (find-manifest-dir)) - (def manifest (find-manifest (meta :name))) - (setdyn :manifest manifest) - (setdyn :manifest-dir manifests) - (setdyn :installed-files installed-files) - - (phony "build" []) - - (phony "manifest" [manifest]) - (rule manifest [] - (print "generating " manifest "...") - (mkdir manifests) - (def sha (pslurp (string "\"" (git-path) "\" rev-parse HEAD"))) - (def url (pslurp (string "\"" (git-path) "\" remote get-url origin"))) - (def man - {:sha (if-not (empty? sha) sha) - :repo (if-not (empty? url) url) - :dependencies (array/slice (get meta :dependencies [])) - :paths installed-files}) - (spit manifest (string/format "%j\n" man))) - - (phony "install" ["uninstall" "build" manifest] - (when (dyn :test) - (do-rule "test")) - (print "Installed as '" (meta :name) "'.")) - - (phony "install-deps" [] - (if-let [deps (meta :dependencies)] - (each dep deps - (install-git dep)) - (print "no dependencies found"))) - - (phony "uninstall" [] - (uninstall (meta :name))) - - (phony "clean" [] - (when (os/stat "./build" :mode) - (rm "build") - (print "Deleted build directory."))) - - (phony "test" ["build"] - (defn dodir - [dir] - (each sub (sort (os/dir dir)) - (def ndir (string dir sep sub)) - (case (os/stat ndir :mode) - :file (when (string/has-suffix? ".janet" ndir) - (print "running " ndir " ...") - (def result (os/execute [(dyn :executable "janet") ndir] :p)) - (when (not= 0 result) - (os/exit result))) - :directory (dodir ndir)))) - (dodir "test") - (print "All tests passed."))) - -# -# CLI -# - -(def- argpeg - (peg/compile - '(* "--" '(some (if-not "=" 1)) (+ (* "=" '(any 1)) -1)))) - -(defn- local-rule - [rule &opt no-deps] - (import-rules "./project.janet" no-deps) - (do-rule rule)) - -(defn- help - [] - (print ` -usage: jpm [--key=value, --flag] ... [subcommand] [args] ... - -Run from a directory containing a project.janet file to perform operations -on a project, or from anywhere to do operations on the global module cache (modpath). -Commands that need write permission to the modpath are considered privileged commands - in -some environments they may require super user privileges. -Other project-level commands need to have a ./project.janet file in the current directory. - -Unprivileged global subcommands: - help : show this help text - show-paths : prints the paths that will be used to install things. - quickbin entry executable : Create an executable from a janet script with a main function. - -Privileged global subcommands: - install (repo or name)... : install artifacts. If a repo is given, install the contents of that - git repository, assuming that the repository is a jpm project. If not, build - and install the current project. - uninstall (module)... : uninstall a module. If no module is given, uninstall the module - defined by the current directory. - clear-cache : clear the git cache. Useful for updating dependencies. - clear-manifest : clear the manifest. Useful for fixing broken installs. - make-lockfile (lockfile) : Create a lockfile based on repositories in the cache. The - lockfile will record the exact versions of dependencies used to ensure a reproducible - build. Lockfiles are best used with applications, not libraries. The default lockfile - name is lockfile.jdn. - load-lockfile (lockfile) : Install modules from a lockfile in a reproducible way. The - default lockfile name is lockfile.jdn. - update-pkgs : Update the current package listing from the remote git repository selected. - -Privileged project subcommands: - deps : install dependencies for the current project. - install : install artifacts of the current project. - uninstall : uninstall the current project's artifacts. - -Unprivileged project subcommands: - build : build all artifacts - clean : remove any generated files or artifacts - test : run tests. Tests should be .janet files in the test/ directory relative to project.janet. - run rule : run a rule. Can also run custom rules added via (phony "task" [deps...] ...) - or (rule "ouput.file" [deps...] ...). - rules : list rules available with run. - list-installed : list installed packages in the current syspath. - list-pkgs (search) : list packages in the package listing that the contain the string search. - If no search pattern is given, prints the entire package listing. - rule-tree (root rule) (depth) : Print a nice tree to see what rules depend on other rules. - Optionally provide a root rule to start printing from, and a - max depth to print. Without these options, all rules will print - their full dependency tree. - debug-repl : Run a repl in the context of the current project.janet file. This lets you run rules and - otherwise debug the current project.janet file. - -Keys are: - --modpath : The directory to install modules to. Defaults to $JANET_MODPATH, $JANET_PATH, or (dyn :syspath) - --headerpath : The directory containing janet headers. Defaults to $JANET_HEADERPATH. - --binpath : The directory to install binaries and scripts. Defaults to $JANET_BINPATH. - --libpath : The directory containing janet C libraries (libjanet.*). Defaults to $JANET_LIBPATH. - --compiler : C compiler to use for natives. Defaults to $CC or cc (cl.exe on windows). - --cpp-compiler : C++ compiler to use for natives. Defaults to $CXX or c++ (cl.exe on windows). - --archiver : C archiver to use for static libraries. Defaults to $AR ar (lib.exe on windows). - --linker : C linker to use for linking natives. Defaults to link.exe on windows, not used on - other platforms. - --pkglist : URL of git repository for package listing. Defaults to $JANET_PKGLIST or https://github.com/janet-lang/pkgs.git - -Flags are: - --nocolor : Disable color in the jpm repl. - --verbose : Print shell commands as they are executed. - --test : If passed to jpm install, runs tests before installing. Will run tests recursively on dependencies. - --offline : Prevents jpm from going to network to get dependencies - all dependencies should be in the cache or this command will fail. - `)) - -(defn show-help - [] - (print help)) - -(defn show-paths - [] - (print "binpath: " (dyn :binpath JANET_BINPATH)) - (print "modpath: " (dyn :modpath JANET_MODPATH)) - (print "libpath: " (dyn :libpath JANET_LIBPATH)) - (print "headerpath: " (dyn :headerpath JANET_HEADERPATH)) - (print "syspath: " (dyn :syspath))) - -(defn build - [] - (local-rule "build")) - -(defn clean - [] - (local-rule "clean")) - -(defn install - [& repo] - (if (empty? repo) - (local-rule "install") - (each rep repo (install-git rep)))) - -(defn test - [] - (local-rule "test")) - -(defn- uninstall-cmd - [& what] - (if (empty? what) - (local-rule "uninstall") - (each wha what (uninstall wha)))) - -(defn deps - [] - (local-rule "install-deps" true)) - -(defn show-rule-tree - [&opt root depth] - (import-rules "./project.janet") - (def max-depth (if depth (scan-number depth) math/inf)) - (if root - (print-rule-tree root max-depth "" "") - (let [ks (sort (seq [k :keys (dyn :rules)] k))] - (each k ks (print-rule-tree k max-depth "" ""))))) - -(defn list-rules - [&opt ctx] - (import-rules "./project.janet") - (def ks (sort (seq [k :keys (dyn :rules)] k))) - (each k ks (print k))) - -(defn list-installed - [] - (def xs - (seq [x :in (os/dir (find-manifest-dir)) - :when (string/has-suffix? ".jdn" x)] - (string/slice x 0 -5))) - (sort xs) - (each x xs (print x))) - -(defn list-pkgs - [&opt search] - (def [ok _] (module/find "pkgs")) - (unless ok - (eprint "no local package listing found. Run `jpm update-pkgs` to get listing.") - (os/exit 1)) - (def pkgs-mod (require "pkgs")) - (def ps - (seq [p :keys (get-in pkgs-mod ['packages :value] []) - :when (if search (string/find search p) true)] - p)) - (sort ps) - (each p ps (print p))) - -(defn update-pkgs - [] - (install-git (dyn :pkglist default-pkglist))) - -(defn quickbin - [input output] - (if (= (os/stat output :mode) :file) - (print "output " output " exists.")) - (create-executable @{:no-compile (dyn :no-compile)} input output (dyn :no-core)) - (do-rule output)) - -(defn jpm-debug-repl - [] - (def env - (try - (require-jpm "./project.janet") - ([err f] - (if (= "cannot open ./project.janet" err) - (put (make-jpm-env) :project {}) - (propagate err f))))) - (setdyn :pretty-format (if-not (dyn :nocolor) "%.20Q" "%.20q")) - (setdyn :err-color (if-not (dyn :nocolor) true)) - (def p (env :project)) - (def name (p :name)) - (if name (print "Project: " name)) - (if-let [r (p :repo)] (print "Repository: " r)) - (if-let [a (p :author)] (print "Author: " a)) - (defn getchunk [buf p] - (def [line] (parser/where p)) - (getline (string "jpm[" (or name "repl") "]:" line ":" (parser/state p :delimiters) "> ") buf env)) - (repl getchunk nil env)) - -(def- subcommands - {"build" build - "clean" clean - "help" show-help - "install" install - "test" test - "help" help - "deps" deps - "debug-repl" jpm-debug-repl - "rule-tree" show-rule-tree - "show-paths" show-paths - "list-installed" list-installed - "list-pkgs" list-pkgs - "clear-cache" clear-cache - "clear-manifest" clear-manifest - "run" local-rule - "rules" list-rules - "update-pkgs" update-pkgs - "uninstall" uninstall-cmd - "make-lockfile" make-lockfile - "load-lockfile" load-lockfile - "quickbin" quickbin}) - -(defn- main - "Script entry." - [& argv] - - (def- args (tuple/slice argv 1)) - (def- len (length args)) - (var i :private 0) - - # Get flags - (while (< i len) - (if-let [m (peg/match argpeg (args i))] - (if (= 2 (length m)) - (let [[key value] m] - (setdyn (keyword key) value)) - (setdyn (keyword (m 0)) true)) - (break)) - (++ i)) - - # Run subcommand - (if (= i len) - (help) - (do - (if-let [com (subcommands (args i))] - (com ;(tuple/slice args (+ i 1))) - (do - (print "invalid command " (args i)) - (help)))))) diff --git a/jpm.1 b/jpm.1 deleted file mode 100644 index c05f8f78..00000000 --- a/jpm.1 +++ /dev/null @@ -1,298 +0,0 @@ -.TH JPM 1 -.SH NAME -jpm \- the Janet Project Manager, a build tool for Janet -.SH SYNOPSIS -.B jpm -[\fB\-\-flag ...\fR] -[\fB\-\-option=value ...\fR] -.IR command -.IR args ... -.SH DESCRIPTION -jpm is the build tool that ships with a standard Janet install. It is -used for building Janet projects, installing dependencies, installing -projects, building native modules, and exporting your Janet project to a -standalone executable. Although not required for working with Janet, it -removes much of the boilerplate with installing dependencies and -building native modules. jpm requires only Janet to run, and uses git -to install dependencies (jpm will work without git installed). -.SH DOCUMENTATION - -jpm has several subcommands, each used for managing either a single Janet project or -all Janet modules installed on the system. Global commands, those that manage modules -at the system level, do things like install and uninstall packages, as well as clear the cache. -More interesting are the local commands. For more information on jpm usage, see https://janet-lang.org/docs/index.html - -.SH FLAGS - -.TP -.BR \-\-nocolor -Disable color in the jpm debug repl. - -.TP -.BR \-\-verbose -Print detailed messages of what jpm is doing, including compilation commands and other shell commands. - -.TP -.BR \-\-test -If passed to jpm install, runs tests before installing. Will run tests recursively on dependencies. - -.TP -.BR \-\-offline -Prevents jpm from going to network to get dependencies - all dependencies should be in the cache or this command will fail. -Use this flag with the deps and update-pkgs subcommands. This is not a surefire way to prevent a build script from accessing -the network, for example, a build script that invokes curl will still have network access. - -.TP -.BR \-\-auto\-shebang -Prepends installed scripts with a generated shebang line, such that they will use a janet binary located in JANET_BINPATH. - -.SH OPTIONS - -.TP -.BR \-\-modpath=/some/path -Set the path to install modules to. Defaults to $JANET_MODPATH, $JANET_PATH, or (dyn :syspath) in that order. You most likely don't need this. - -.TP -.BR \-\-headerpath=/some/path -Set the path the jpm will include when building C source code. This lets -you specify the location of janet.h and janetconf.h on your system. On a -normal install, this option is not needed. - -.TP -.BR \-\-binpath=/some/path -Set the path that jpm will install scripts and standalone executables to. Executables -defined via declare-execuatble or scripts declared via declare-binscript will be installed -here when jpm install is run. Defaults to $JANET_BINPATH, or a reasonable default for the system. -See JANET_BINPATH for more. - -.TP -.BR \-\-libpath=/some/path -Sets the path jpm will use to look for libjanet.a for building standalone executables. libjanet.so -is \fBnot\fR used for building native modules or standalone executables, only -for linking into applications that want to embed janet as a dynamic module. -Linking statically might be a better idea, even in that case. Defaults to -$JANET_LIBPATH, or a reasonable default. See JANET_LIBPATH for more. - -.TP -.BR \-\-compiler=$CC -Sets the C compiler used for compiling native modules and standalone executables. Defaults -to cc. - -.TP -.BR \-\-cpp\-compiler=$CXX -Sets the C++ compiler used for compiling native modules and standalone executables. Defaults -to c++.. - -.TP -.BR \-\-linker -Sets the linker used to create native modules and executables. Only used on windows, where -it defaults to link.exe. - -.TP -.BR \-\-pkglist=https://github.com/janet-lang/pkgs.git -Sets the git repository for the package listing used to resolve shorthand package names. - -.TP -.BR \-\-archiver=$AR -Sets the command used for creating static libraries, use for linking into the standalone executable. -Native modules are compiled twice, once a normal native module (shared object), and once as an -archive. Defaults to ar. - -.SH COMMANDS -.TP -.BR help -Shows the usage text and exits immediately. - -.TP -.BR build -Builds all artifacts specified in the project.janet file in the current directory. Artifacts will -be created in the ./build/ directory. - -.TP -.BR install\ [\fBrepo...\fR] -When run with no arguments, installs all installable artifacts in the current project to -the current JANET_MODPATH for modules and JANET_BINPATH for executables and scripts. Can also -take an optional git repository URL and will install all artifacts in that repository instead. -When run with an argument, install does not need to be run from a jpm project directory. Will also -install multiple dependencies in one command. - -.TP -.BR uninstall\ [\fBname...\fR] -Uninstall a project installed with install. uninstall expects the name of the project, not the -repository url, path to installed file, or executable name. The name of the project must be specified -at the top of the project.janet file in the declare-project form. If no name is given, uninstalls -the current project if installed. Will also uninstall multiple packages in one command. - -.TP -.BR clean -Remove all artifacts created by jpm. This just deletes the build folder. - -.TP -.BR test -Runs jpm tests. jpm will run all janet source files in the test directory as tests. A test -is considered failing if it exits with a non-zero exit code. - -.TP -.BR deps -Install all dependencies that this project requires recursively. jpm does not -resolve dependency issues, like conflicting versions of the same module are required, or -different modules with the same name. Dependencies are installed with git, so deps requires -git to be on the PATH. - -.TP -.BR clear-cache -jpm caches git repositories that are needed to install modules from a remote -source in a global cache ($JANET_PATH/.cache). If these dependencies are out of -date or too large, clear-cache will remove the cache and jpm will rebuild it -when needed. clear-cache is a global command, so a project.janet is not -required. - -.TP -.BR list-installed -List all installed packages in the current syspath. - -.TP -.BR list-pkgs\ [\fBsearch\fR] -List all package aliases in the current package listing that contain the given search string. -If no search string is given, prints the entire listing. - -.TP -.BR clear-manifest -jpm creates a manifest directory that contains a list of all installed files. -By deleting this directory, jpm will think that nothing is installed and will -try reinstalling everything on the jpm deps or jpm load-lockfile commands. Be careful with -this command, as it may leave extra files on your system and shouldn't be needed -most of the time in a healthy install. - -.TP -.BR run\ [\fBrule\fR] -Run a given rule defined in project.janet. Project definitions files (project.janet) usually -contain a few artifact declarations, which set up rules that jpm can then resolve, or execute. -A project.janet can also create custom rules to create arbitrary files or run arbitrary code, much -like make. run will run a single rule or build a single file. - -.TP -.BR rules -List all rules that can be run via run. This is useful for exploring rules in the project. - -.TP -.BR rule-tree\ [\fBroot\fR]\ [\fBdepth\fR] -Show rule dependency tree in a pretty format. Optionally provide a rule to use as the tree -root, as well as a max depth to print. By default, prints the full tree for all rules. This -can be quite long, so it is recommended to give a root rule. - -.TP -.BR show-paths -Show all of the paths used when installing and building artifacts. - -.TP -.BR update-pkgs -Update the package listing by installing the 'pkgs' package. Same as jpm install pkgs - -.TP -.BR quickbin\ [\fBentry\fR]\ [\fBexecutable\fR] -Create a standalone, statically linked executable from a Janet source file that contains a main function. -The main function is the entry point of the program and will receive command line arguments -as function arguments. The entry file can import other modules, including native C modules, and -jpm will attempt to include the dependencies into the generated executable. - -.TP -.BR debug-repl -Load the current project.janet file and start a repl in it's environment. This lets a user better -debug the project file, as well as run rules manually. - -.TP -.BR make-lockfile\ [\fBfilename\fR] -Create a lockfile. A lockfile is a record that describes what dependencies were installed at the -time of the lockfile's creation, including exact versions. A lockfile can then be later used -to set up that environment on a different machine via load-lockfile. By default, the lockfile -is created at lockfile.jdn, although any path can be used. - -.TP -.BR load-lockfile\ [\fBfilename\fR] -Install dependencies from a lockfile previously created with make-lockfile. By default, will look -for a lockfile at lockfile.jdn, although any path can be used. - -.SH ENVIRONMENT - -.B JANET_PATH -.RS -The location to look for Janet libraries. This is the only environment variable Janet needs to -find native and source code modules. If no JANET_PATH is set, Janet will look in -the default location set at compile time, which can be determined with (dyn :syspath) -.RE - -.B JANET_MODPATH -.RS -The location that jpm will use to install libraries to. Defaults to JANET_PATH, but you could -set this to a different directory if you want to. Doing so would let you import Janet modules -on the normal system path (JANET_PATH or (dyn :syspath)), but install to a different directory. It is also a more reliable way to install. -This variable is overwritten by the --modpath=/some/path if it is provided. -.RE - -.B JANET_HEADERPATH -.RS -The location that jpm will look for janet header files (janet.h and janetconf.h) that are used -to build native modules and standalone executables. If janet.h and janetconf.h are available as -default includes on your system, this value is not required. If not provided, will default to -/../include/janet. The --headerpath=/some/path option will override this -variable. -.RE - -.B JANET_LIBPATH -.RS -Similar to JANET_HEADERPATH, this path is where jpm will look for -libjanet.a for creating standalone executables. This does not need to be -set on a normal install. -If not provided, this will default to /../lib. -The --libpath=/some/path option will override this variable. -.RE - -.B JANET_BINPATH -.RS -The directory where jpm will install binary scripts and executables to. -Defaults to -(dyn :syspath)/bin -The --binpath=/some/path will override this variable. -.RE - -.B JANET_PKGLIST -.RS -The git repository URL that contains a listing of packages. This allows installing packages with shortnames, which -is mostly a convenience. However, package dependencies can use short names, package listings -can be used to choose a particular set of dependency versions for a whole project. -.RE - -.B JANET_GIT -.RS -An optional path to a git executable to use to clone git dependencies. By default, uses "git" on the current $PATH. You shouldn't need to set this -if you have a normal install of git. -.RE - -.B JPM_OS_WHICH -.RS -Use this option to override the C compiler and build system auto-detection for the host operating system. For example, set this -environment variable to "posix" to make sure that on platforms like MinGW, you will use GCC instead of MSVC. On most platforms, users will not need to -set this environment variable. Set this to one of the following -strings: -.IP -\- windows -.IP -\- macos -.IP -\- linux -.IP -\- freebsd -.IP -\- openbsd -.IP -\- netbsd -.IP -\- bsd -.IP -\- posix -.RE - - -.SH AUTHOR -Written by Calvin Rose diff --git a/meson.build b/meson.build index bf59315c..e36caaf8 100644 --- a/meson.build +++ b/meson.build @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose and contributors +# Copyright (c) 2021 Calvin Rose and contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to @@ -20,7 +20,7 @@ project('janet', 'c', default_options : ['c_std=c99', 'build.c_std=c99', 'b_lundef=false', 'default_library=both'], - version : '1.16.0') + version : '1.18.2') # Global settings janet_path = join_paths(get_option('prefix'), get_option('libdir'), 'janet') @@ -30,6 +30,7 @@ header_path = join_paths(get_option('prefix'), get_option('includedir'), 'janet' cc = meson.get_compiler('c') m_dep = cc.find_library('m', required : false) dl_dep = cc.find_library('dl', required : false) +android_spawn_dep = cc.find_library('android-spawn', required : false) thread_dep = dependency('threads') # Link options @@ -72,7 +73,9 @@ conf.set('JANET_NO_UMASK', not get_option('umask')) conf.set('JANET_NO_REALPATH', not get_option('realpath')) conf.set('JANET_NO_PROCESSES', not get_option('processes')) conf.set('JANET_SIMPLE_GETLINE', get_option('simple_getline')) -conf.set('JANET_EV_EPOLL', get_option('epoll')) +conf.set('JANET_EV_NO_EPOLL', not get_option('epoll')) +conf.set('JANET_EV_NO_KQUEUE', not get_option('kqueue')) +conf.set('JANET_NO_INTERPRETER_INTERRUPT', not get_option('interpreter_interrupt')) if get_option('os_name') != '' conf.set('JANET_OS_NAME', get_option('os_name')) endif @@ -127,12 +130,12 @@ core_src = [ 'src/core/regalloc.c', 'src/core/run.c', 'src/core/specials.c', + 'src/core/state.c', 'src/core/string.c', 'src/core/strtod.c', 'src/core/struct.c', 'src/core/symcache.c', 'src/core/table.c', - 'src/core/thread.c', 'src/core/tuple.c', 'src/core/util.c', 'src/core/value.c', @@ -158,7 +161,7 @@ mainclient_src = [ janet_boot = executable('janet-boot', core_src, boot_src, include_directories : incdir, c_args : '-DJANET_BOOTSTRAP', - dependencies : [m_dep, dl_dep, thread_dep], + dependencies : [m_dep, dl_dep, thread_dep, android_spawn_dep], native : true) # Build janet.c @@ -168,10 +171,10 @@ janetc = custom_target('janetc', capture : true, command : [ janet_boot, meson.current_source_dir(), - 'JANET_PATH', janet_path, 'JANET_HEADERPATH', header_path + 'JANET_PATH', janet_path ]) -janet_dependencies = [m_dep, dl_dep] +janet_dependencies = [m_dep, dl_dep, android_spawn_dep] if not get_option('single_threaded') janet_dependencies += thread_dep endif @@ -260,16 +263,3 @@ patched_janet = custom_target('patched-janeth', build_by_default : true, output : ['janet.h'], command : [janet_nativeclient, '@INPUT@', '@OUTPUT@']) -if get_option('peg') and not get_option('reduced_os') and get_option('processes') - install_man('jpm.1') - patched_jpm = custom_target('patched-jpm', - input : ['tools/patch-jpm.janet', 'jpm'], - install : true, - install_dir : get_option('bindir'), - build_by_default : true, - output : ['jpm'], - command : [janet_nativeclient, '@INPUT@', '@OUTPUT@', - '--binpath=' + join_paths(get_option('prefix'), get_option('bindir')), - '--libpath=' + join_paths(get_option('prefix'), get_option('libdir')), - '--headerpath=' + join_paths(get_option('prefix'), get_option('includedir'))]) -endif diff --git a/meson_options.txt b/meson_options.txt index c19f662b..afc8f353 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -17,6 +17,8 @@ option('umask', type : 'boolean', value : true) option('realpath', type : 'boolean', value : true) option('simple_getline', type : 'boolean', value : false) option('epoll', type : 'boolean', value : false) +option('kqueue', type : 'boolean', value : false) +option('interpreter_interrupt', type : 'boolean', value : false) option('recursion_guard', type : 'integer', min : 10, max : 8000, value : 1024) option('max_proto_depth', type : 'integer', min : 10, max : 8000, value : 200) diff --git a/src/boot/array_test.c b/src/boot/array_test.c index db2e6d9d..f45bc6b1 100644 --- a/src/boot/array_test.c +++ b/src/boot/array_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/boot/boot.c b/src/boot/boot.c index 4214d7d6..97c3fab8 100644 --- a/src/boot/boot.c +++ b/src/boot/boot.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 4884ba5a..b246f650 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1,5 +1,5 @@ # The core janet library -# Copyright 2020 © Calvin Rose +# Copyright 2021 © Calvin Rose ### ### @@ -51,7 +51,7 @@ ``Use a function or macro literal `f` as a macro. This lets any function be used as a macro. Inside a quasiquote, the idiom `(as-macro ,my-custom-macro arg1 arg2...)` can be used - to avoid unwanted variable capture.`` + to avoid unwanted variable capture of `my-custom-macro`.`` [f & args] (f ;args)) @@ -149,10 +149,15 @@ (defmacro /= "Shorthand for (set x (/ x n))." [x n] ~(set ,x (,/ ,x ,n))) (defmacro %= "Shorthand for (set x (% x n))." [x n] ~(set ,x (,% ,x ,n))) -(defn assert - "Throw an error if x is not truthy." +(defmacro assert + "Throw an error if x is not truthy. Will not evaluate `err` if x is truthy." [x &opt err] - (if x x (error (if err err "assert failure")))) + (def v (gensym)) + ~(do + (def ,v ,x) + (if ,v + ,v + (,error ,(if err err "assert failure"))))) (defn errorf "A combination of error and string/format. Equivalent to (error (string/format fmt ;args))" @@ -588,10 +593,15 @@ ~(fiber/new (fn [] (loop ,head (yield (do ,;body)))) :yi)) (defmacro coro - "A wrapper for making fibers. Same as (fiber/new (fn [] ;body) :yi)." + "A wrapper for making fibers that may yield multiple values (coroutine). Same as (fiber/new (fn [] ;body) :yi)." [& body] (tuple fiber/new (tuple 'fn '[] ;body) :yi)) +(defmacro fiber-fn + "A wrapper for making fibers. Same as (fiber/new (fn [] ;body) flags)." + [flags & body] + (tuple fiber/new (tuple 'fn '[] ;body) flags)) + (defn sum "Returns the sum of xs. If xs is empty, returns 0." [xs] @@ -688,6 +698,14 @@ "Returns the numeric minimum of the arguments." [& args] (extreme < args)) +(defn max-of + "Returns the numeric maximum of the argument sequence." + [args] (extreme > args)) + +(defn min-of + "Returns the numeric minimum of the argument sequence." + [args] (extreme < args)) + (defn first "Get the first element from an indexed data structure." [xs] @@ -1026,35 +1044,65 @@ (set k (next ind k))) ret) -(defn take - "Take first n elements in an indexed type. Returns new indexed instance." - [n ind] - (def use-str (bytes? ind)) - (def f (if use-str string/slice tuple/slice)) +(defn- take-n-fallback + [n xs] + (def res @[]) + (when (> n 0) + (var left n) + (each x xs + (array/push res x) + (-- left) + (if (= 0 left) (break)))) + res) + +(defn- take-until-fallback + [pred xs] + (def res @[]) + (each x xs + (if (pred x) (break)) + (array/push res x)) + res) + +(defn- slice-n + [f n ind] (def len (length ind)) # make sure end is in [0, len] (def m (if (> n 0) n 0)) (def end (if (> m len) len m)) (f ind 0 end)) -(defn take-until - "Same as (take-while (complement pred) ind)." - [pred ind] - (def use-str (bytes? ind)) - (def f (if use-str string/slice tuple/slice)) +(defn take + "Take the first n elements of a fiber, indexed or bytes type. Returns a new array, tuple or string, respectively." + [n ind] + (cond + (bytes? ind) (slice-n string/slice n ind) + (indexed? ind) (slice-n tuple/slice n ind) + (take-n-fallback n ind))) + +(defn- slice-until + [f pred ind] (def len (length ind)) (def i (find-index pred ind)) (def end (if (nil? i) len i)) (f ind 0 end)) +(defn take-until + "Same as `(take-while (complement pred) ind)`." + [pred ind] + (cond + (bytes? ind) (slice-until string/slice pred ind) + (indexed? ind) (slice-until tuple/slice pred ind) + (take-until-fallback pred ind))) + (defn take-while - `Given a predicate, take only elements from an indexed type that satisfy - the predicate, and abort on first failure. Returns a new array.` + `Given a predicate, take only elements from a fiber, indexed or bytes type that satisfy + the predicate, and abort on first failure. Returns a new array, tuple or string, respectively.` [pred ind] (take-until (complement pred) ind)) (defn drop - "Drop first n elements in an indexed type. Returns new indexed instance." + ``Drop the first n elements in an indexed or bytes type. Returns a new tuple or string + instance, respectively.`` [n ind] (def use-str (bytes? ind)) (def f (if use-str string/slice tuple/slice)) @@ -1065,7 +1113,7 @@ (f ind start -1)) (defn drop-until - "Same as (drop-while (complement pred) ind)." + "Same as `(drop-while (complement pred) ind)`." [pred ind] (def use-str (bytes? ind)) (def f (if use-str string/slice tuple/slice)) @@ -1075,8 +1123,8 @@ (f ind start)) (defn drop-while - `Given a predicate, remove elements from an indexed type that satisfy - the predicate, and abort on first failure. Returns a new array.` + `Given a predicate, remove elements from an indexed or bytes type that satisfy + the predicate, and abort on first failure. Returns a new tuple or string, respectively.` [pred ind] (drop-until (complement pred) ind)) @@ -1316,9 +1364,10 @@ ret) (defn invert - `Returns a table where the keys of an associative data structure - are the values, and the values of the keys. If multiple keys have the same - value, one key will be ignored.` + ``Returns a table where the keys of an associative data structure + are the values, and the values are the keys. If multiple keys in `ds` + are mapped to the same value, only one of those values will + become a key in the returned table.`` [ds] (def ret @{}) (loop [k :keys ds] @@ -1345,7 +1394,7 @@ a sequence of keys.` [ds ks &opt dflt] (var d ds) - (loop [k :in ks :while d] (set d (get d k))) + (loop [k :in ks :while (not (nil? d))] (set d (get d k))) (if (= nil d) dflt d)) (defn update-in @@ -1628,9 +1677,13 @@ * tuple -- a tuple pattern will match if its first element matches, and the following elements are treated as predicates and are true. - * `_` symbol -- the last special case is the `_` symbol, which is a wildcard + * `\_` symbol -- the last special case is the `\_` symbol, which is a wildcard that will match any value without creating a binding. + While a symbol pattern will ordinarily match any value, the pattern `(@ )`, + where is any symbol, will attempt to match `x` against a value + already bound to ``, rather than matching and rebinding it. + Any other value pattern will only match if it is equal to `x`. ``` [x & cases] @@ -1784,6 +1837,20 @@ ### ### +(defn maclintf + ``When inside a macro, call this function to add a linter warning. Takes + a `fmt` argument like `string/format` which is used to format the message.`` + [level fmt & args] + (def lints (dyn :macro-lints)) + (when lints + (def form (dyn :macro-form)) + (def [l c] (if (tuple? form) (tuple/sourcemap form) [nil nil])) + (def l (if-not (= -1 l) l)) + (def c (if-not (= -1 c) c)) + (def msg (string/format fmt ;args)) + (array/push lints [level l c msg])) + nil) + (defn macex1 ``Expand macros in a form, but do not recursively expand macros. See `macex` docs for info on on-binding.`` @@ -2065,11 +2132,10 @@ ### ### -# Initialize syspath and header path +# Initialize syspath (each [k v] (partition 2 (tuple/slice boot/args 2)) (case k - "JANET_PATH" (setdyn :syspath v) - "JANET_HEADERPATH" (setdyn :headerpath v))) + "JANET_PATH" (setdyn :syspath v))) (defn make-env `Create a new environment table. The new environment @@ -2097,6 +2163,43 @@ (if ec "\e[0m" "")) (eflush)) +(defn- print-line-col + "Print the source code at a line, column in a source file. If unable to open + the file, prints nothing." + [where line col] + (if-not line (break)) + (when-with [f (file/open where :r)] + (def source-code (file/read f :all)) + (var index 0) + (repeat (dec line) + (if-not index (break)) + (set index (inc (string/find "\n" source-code index)))) + (when index + (def line-end (string/find "\n" source-code index)) + (eprint " " (string/slice source-code index line-end)) + (when col + (+= index col) + (eprint (string/repeat " " (inc col)) "^")) + (eflush)))) + +(defn warn-compile + "Default handler for a compile warning" + [msg level where &opt line col] + (def ec (dyn :err-color)) + (eprin + (if ec "\e[33m" "") + where + ":" + line + ":" + col + ": compile warning (" level "): ") + (eprint msg) + (when ec + (print-line-col where line col) + (eprin "\e[0m")) + (eflush)) + (defn bad-compile "Default handler for a compile error." [msg macrof where &opt line col] @@ -2111,7 +2214,10 @@ ": compile error: ") (if macrof (debug/stacktrace macrof msg) - (eprint msg (if ec "\e[0m" ""))) + (eprint msg)) + (when ec + (print-line-col where line col) + (eprin "\e[0m")) (eflush)) (defn curenv @@ -2122,6 +2228,13 @@ (if n (repeat n (if (= nil e) (break)) (set e (table/getproto e)))) e) +(def- lint-levels + {:none 0 + :relaxed 1 + :normal 2 + :strict 3 + :all math/inf}) + (defn run-context ``` Run a context. This evaluates expressions in an environment, @@ -2134,6 +2247,7 @@ * `:env` - the environment to compile against - default is the current env * `:source` - string path of source for better errors - default is "" * `:on-compile-error` - callback when compilation fails - default is bad-compile + * `:on-compile-warning` - callback for any linting error - default is warn-compile * `:evaluator` - callback that executes thunks. Signature is (evaluator thunk source env where) * `:on-status` - callback when a value is evaluated - default is debug/stacktrace. * `:fiber-flags` - what flags to wrap the compilation fiber with. Default is :ia. @@ -2148,6 +2262,7 @@ :chunks chunks :on-status onstatus :on-compile-error on-compile-error + :on-compile-warning on-compile-warning :on-parse-error on-parse-error :fiber-flags guard :evaluator evaluator @@ -2159,6 +2274,7 @@ (default chunks (fn [buf p] (getline "" buf env))) (default onstatus debug/stacktrace) (default on-compile-error bad-compile) + (default on-compile-warning warn-compile) (default on-parse-error bad-parse) (default evaluator (fn evaluate [x &] (x))) (default default-where "") @@ -2167,6 +2283,7 @@ (var where default-where) # Evaluate 1 source form in a protected manner + (def lints @[]) (defn eval1 [source &opt l c] (def source (if expand (expand source) source)) (var good true) @@ -2174,13 +2291,29 @@ (def f (fiber/new (fn [] - (def res (compile source env where)) - (if (= (type res) :function) - (evaluator res source env where) - (do - (set good false) - (def {:error err :line line :column column :fiber errf} res) - (on-compile-error err errf where (or line l) (or column c))))) + (array/clear lints) + (def res (compile source env where lints)) + (unless (empty? lints) + # Convert lint levels to numbers. + (def levels (get env :lint-levels lint-levels)) + (def lint-error (get env :lint-error)) + (def lint-warning (get env :lint-warn)) + (def lint-error (or (get levels lint-error lint-error) 0)) + (def lint-warning (or (get levels lint-warning lint-warning) 2)) + (each [level line col msg] lints + (def lvl (get lint-levels level 0)) + (cond + (<= lvl lint-error) (do + (set good false) + (on-compile-error msg nil where (or line l) (or col c))) + (<= lvl lint-warning) (on-compile-warning msg level where (or line l) (or col c))))) + (when good + (if (= (type res) :function) + (evaluator res source env where) + (do + (set good false) + (def {:error err :line line :column column :fiber errf} res) + (on-compile-error err errf where (or line l) (or column c)))))) guard)) (fiber/setenv f env) (while (fiber/can-resume? f) @@ -2254,6 +2387,7 @@ (when (= (p-status p) :error) (parse-err p where))) + (put env :exit nil) (in env :exit-value env)) (defn quit @@ -2298,7 +2432,7 @@ (def res (compile form (fiber/getenv (fiber/current)) "eval")) (if (= (type res) :function) (res) - (error (res :error)))) + (error (get res :error)))) (defn parse `Parse a string and return the first value. For complex parsing, such as for a repl with error handling, @@ -2660,8 +2794,8 @@ (def delimiters (if has-color {:underline ["\e[4m" "\e[24m"] - :code ["\e[3;97m" "\e[39;23m"] - :italics ["\e[3m" "\e[23m"] + :code ["\e[97m" "\e[39m"] + :italics ["\e[4m" "\e[24m"] :bold ["\e[1m" "\e[22m"]} {:underline ["_" "_"] :code ["`" "`"] @@ -2694,7 +2828,7 @@ (c++) (- cursor x)) - # Detection helpers - return number of characters natched + # Detection helpers - return number of characters matched (defn ul? [] (let [x (c) x1 (cn 1)] (and @@ -2828,6 +2962,14 @@ (finish-p) new-indent)) + # Handle first line specially for defn, defmacro, etc. + (when (= (chr "(") (in str 0)) + (skipline) + (def first-line (string/slice str 0 (- cursor 1))) + (def fl-open (if has-color "\e[97m" "")) + (def fl-close (if has-color "\e[39m" "")) + (push [[(string fl-open first-line fl-close) (length first-line)]])) + (parse-blocks 0) # Emission state @@ -2965,10 +3107,10 @@ (print-index identity))) (defmacro doc - `Shows documentation for the given symbol, or can show a list of available bindings. - If sym is a symbol, will look for documentation for that symbol. If sym is a string - or is not provided, will show all lexical and dynamic bindings in the current environment with - that prefix (all bindings will be shown if no prefix is given).` + ``Shows documentation for the given symbol, or can show a list of available bindings. + If `sym` is a symbol, will look for documentation for that symbol. If `sym` is a string + or is not provided, will show all lexical and dynamic bindings in the current environment + containing that string (all bindings will be shown if no string is given).`` [&opt sym] ~(,doc* ',sym)) @@ -3234,18 +3376,23 @@ Returns a fiber that is scheduled to run the function. ``` [f & args] - (ev/go (fiber/new (fn [&] (f ;args)) :tp))) + (ev/go (fn _call [&] (f ;args)))) (defmacro ev/spawn "Run some code in a new fiber. This is shorthand for (ev/call (fn [] ;body))." [& body] - ~(,ev/go (fiber/new (fn _spawn [&] ,;body) :tp))) + ~(,ev/go (fn _spawn [&] ,;body))) (defmacro ev/do-thread ``Run some code in a new thread. Suspends the current fiber until the thread is complete, and evaluates to nil.`` [& body] - ~(,ev/thread (fiber/new (fn _thread [&] ,;body) :t))) + ~(,ev/thread (fn _do-thread [&] ,;body))) + + (defmacro ev/spawn-thread + ``Run some code in a new thread. Like `ev/do-thread`, but returns nil immediately.`` + [& body] + ~(,ev/thread (fn _spawn-thread [&] ,;body) nil :n)) (defmacro ev/with-deadline `Run a body of code with a deadline, such that if the code does not complete before @@ -3276,7 +3423,7 @@ (def ,res @[]) (,wait-for-fibers ,chan ,(seq [[i body] :pairs bodies] - ~(,ev/go (,fiber/new (fn [] (put ,res ,i ,body)) :tp) nil ,chan))) + ~(,ev/go (fn [] (put ,res ,i ,body)) nil ,chan))) ,res)))) (compwhen (dyn 'net/listen) @@ -3369,6 +3516,12 @@ # conditional compilation for reduced os (def- getenv-alias (if-let [entry (in root-env 'os/getenv)] (entry :value) (fn [&]))) +(defn- run-main + [env subargs arg] + (if-let [main (get (in env 'main) :value)] + (let [thunk (compile [main ;subargs] env arg)] + (if (function? thunk) (thunk) (error (thunk :error)))))) + (defn cli-main `Entrance for the Janet CLI tool. Call this function with the command line arguments as an array or tuple of strings to invoke the CLI interface.` @@ -3376,20 +3529,27 @@ (setdyn :args args) - (var *should-repl* false) - (var *no-file* true) - (var *quiet* false) - (var *raw-stdin* false) - (var *handleopts* true) - (var *exit-on-error* true) - (var *colorize* true) - (var *debug* false) - (var *compile-only* false) + (var should-repl false) + (var no-file true) + (var quiet false) + (var raw-stdin false) + (var handleopts true) + (var exit-on-error true) + (var colorize true) + (var debug-flag false) + (var compile-only false) + (var warn-level nil) + (var error-level nil) + (var expect-image false) (if-let [jp (getenv-alias "JANET_PATH")] (setdyn :syspath jp)) - (if-let [jp (getenv-alias "JANET_HEADERPATH")] (setdyn :headerpath jp)) (if-let [jprofile (getenv-alias "JANET_PROFILE")] (setdyn :profilepath jprofile)) + (defn- get-lint-level + [i] + (def x (in args (+ i 1))) + (or (scan-number x) (keyword x))) + # Flag handlers (def handlers {"h" (fn [&] @@ -3401,6 +3561,7 @@ -v : Print the version string -s : Use raw stdin instead of getline like functionality -e code : Execute a string of janet + -E code arguments... : Evaluate an expression as a short-fn with arguments -d : Set the debug flag in the REPL -r : Enter the REPL after running all scripts -R : Disables loading profile.janet when JANET_PROFILE is present @@ -3409,35 +3570,51 @@ -k : Compile scripts but do not execute (flycheck) -m syspath : Set system path for loading global modules -c source output : Compile janet source code into an image + -i : Load the script argument as an image file instead of source code -n : Disable ANSI color output in the REPL - -l lib : Import a module before processing more arguments + -l lib : Use a module before processing more arguments + -w level : Set the lint warning level - default is "normal" + -x level : Set the lint error level - default is "none" -- : Stop handling options ```) (os/exit 0) 1) "v" (fn [&] (print janet/version "-" janet/build) (os/exit 0) 1) - "s" (fn [&] (set *raw-stdin* true) (set *should-repl* true) 1) - "r" (fn [&] (set *should-repl* true) 1) - "p" (fn [&] (set *exit-on-error* false) 1) - "q" (fn [&] (set *quiet* true) 1) - "k" (fn [&] (set *compile-only* true) (set *exit-on-error* false) 1) - "n" (fn [&] (set *colorize* false) 1) + "s" (fn [&] (set raw-stdin true) (set should-repl true) 1) + "r" (fn [&] (set should-repl true) 1) + "p" (fn [&] (set exit-on-error false) 1) + "q" (fn [&] (set quiet true) 1) + "i" (fn [&] (set expect-image true) 1) + "k" (fn [&] (set compile-only true) (set exit-on-error false) 1) + "n" (fn [&] (set colorize false) 1) "m" (fn [i &] (setdyn :syspath (in args (+ i 1))) 2) "c" (fn c-switch [i &] - (def e (dofile (in args (+ i 1)))) + (def path (in args (+ i 1))) + (def e (dofile path)) (spit (in args (+ i 2)) (make-image e)) - (set *no-file* false) + (set no-file false) 3) - "-" (fn [&] (set *handleopts* false) 1) + "-" (fn [&] (set handleopts false) 1) "l" (fn l-switch [i &] (import* (in args (+ i 1)) - :prefix "" :exit *exit-on-error*) + :prefix "" :exit exit-on-error) 2) "e" (fn e-switch [i &] - (set *no-file* false) + (set no-file false) (eval-string (in args (+ i 1))) 2) - "d" (fn [&] (set *debug* true) 1) + "E" (fn E-switch [i &] + (set no-file false) + (def subargs (array/slice args (+ i 2))) + (def src ~|,(parse (in args (+ i 1)))) + (def thunk (compile src)) + (if (function? thunk) + ((thunk) ;subargs) + (error (get thunk :error))) + math/inf) + "d" (fn [&] (set debug-flag true) 1) + "w" (fn [i &] (set warn-level (get-lint-level i)) 2) + "x" (fn [i &] (set error-level (get-lint-level i)) 2) "R" (fn [&] (setdyn :profilepath nil) 1)}) (defn- dohandler [n i &] @@ -3449,27 +3626,37 @@ (def lenargs (length args)) (while (< i lenargs) (def arg (in args i)) - (if (and *handleopts* (= "-" (string/slice arg 0 1))) + (if (and handleopts (= "-" (string/slice arg 0 1))) (+= i (dohandler (string/slice arg 1) i)) (do - (set *no-file* false) - (def env (make-env)) (def subargs (array/slice args i)) - (put env :args subargs) - (if *compile-only* - (flycheck arg :exit *exit-on-error* :env env) + (set no-file false) + (if expect-image (do - (dofile arg :exit *exit-on-error* :env env) - (if-let [main (get (in env 'main) :value)] - (let [thunk (compile [main ;(tuple/slice args i)] env arg)] - (if (function? thunk) (thunk) (error (thunk :error))))))) + (def env (load-image (slurp arg))) + (put env :args subargs) + (put env :lint-error error-level) + (put env :lint-warn warn-level) + (if debug-flag (put env :debug true)) + (run-main env subargs arg)) + (do + (def env (make-env)) + (put env :args subargs) + (put env :lint-error error-level) + (put env :lint-warn warn-level) + (if debug-flag (put env :debug true)) + (if compile-only + (flycheck arg :exit exit-on-error :env env) + (do + (dofile arg :exit exit-on-error :env env) + (run-main env subargs arg))))) (set i lenargs)))) - (if (or *should-repl* *no-file*) + (if (or should-repl no-file) (if - *compile-only* (flycheck stdin :source "stdin" :exit *exit-on-error*) + compile-only (flycheck stdin :source "stdin" :exit exit-on-error) (do - (if-not *quiet* + (if-not quiet (print "Janet " janet/version "-" janet/build " " (os/which) "/" (os/arch) " - '(doc)' for help")) (flush) (defn getprompt [p] @@ -3483,13 +3670,15 @@ (when-let [profile.janet (dyn :profilepath)] (def new-env (dofile profile.janet :exit true)) (merge-module env new-env "" false)) - (if *debug* (put env :debug true)) - (def getter (if *raw-stdin* getstdin getline)) + (if debug-flag (put env :debug true)) + (def getter (if raw-stdin getstdin getline)) (defn getchunk [buf p] (getter (getprompt p) buf env)) - (setdyn :pretty-format (if *colorize* "%.20Q" "%.20q")) - (setdyn :err-color (if *colorize* true)) - (setdyn :doc-color (if *colorize* true)) + (setdyn :pretty-format (if colorize "%.20Q" "%.20q")) + (setdyn :err-color (if colorize true)) + (setdyn :doc-color (if colorize true)) + (setdyn :lint-error error-level) + (setdyn :lint-warn error-level) (repl getchunk nil env))))) ### @@ -3509,6 +3698,10 @@ (put into k (x k)))) into) + # Deprecate file/popen + (when-let [v (get root-env 'file/popen)] + (put v :deprecated true)) + # Modify root-env to remove private symbols and # flatten nested tables. (loop [[k v] :in (pairs root-env) @@ -3518,6 +3711,9 @@ (put flat :doc nil)) (when (boot/config :no-sourcemaps) (put flat :source-map nil)) + # Fix directory separators on windows to make image identical between windows and non-windows + (when-let [sm (get flat :source-map)] + (put flat :source-map [(string/replace-all "\\" "/" (sm 0)) (sm 1) (sm 2)])) (if (v :private) (put root-env k nil) (put root-env k flat))) @@ -3547,8 +3743,8 @@ (def feature-header "src/core/features.h") (def local-headers - ["src/core/util.h" - "src/core/state.h" + ["src/core/state.h" + "src/core/util.h" "src/core/gc.h" "src/core/vector.h" "src/core/fiber.h" @@ -3584,12 +3780,12 @@ "src/core/regalloc.c" "src/core/run.c" "src/core/specials.c" + "src/core/state.c" "src/core/string.c" "src/core/strtod.c" "src/core/struct.c" "src/core/symcache.c" "src/core/table.c" - "src/core/thread.c" "src/core/tuple.c" "src/core/util.c" "src/core/value.c" diff --git a/src/boot/buffer_test.c b/src/boot/buffer_test.c index f5348e51..44c89313 100644 --- a/src/boot/buffer_test.c +++ b/src/boot/buffer_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/boot/number_test.c b/src/boot/number_test.c index aa05ae76..87d813d8 100644 --- a/src/boot/number_test.c +++ b/src/boot/number_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/boot/system_test.c b/src/boot/system_test.c index 99165716..d46f18c0 100644 --- a/src/boot/system_test.c +++ b/src/boot/system_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/boot/table_test.c b/src/boot/table_test.c index ec59293c..66ac9a01 100644 --- a/src/boot/table_test.c +++ b/src/boot/table_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/conf/janetconf.h b/src/conf/janetconf.h index 2d91fbf0..9958ebc4 100644 --- a/src/conf/janetconf.h +++ b/src/conf/janetconf.h @@ -4,10 +4,10 @@ #define JANETCONF_H #define JANET_VERSION_MAJOR 1 -#define JANET_VERSION_MINOR 16 -#define JANET_VERSION_PATCH 0 +#define JANET_VERSION_MINOR 18 +#define JANET_VERSION_PATCH 2 #define JANET_VERSION_EXTRA "-dev" -#define JANET_VERSION "1.16.0-dev" +#define JANET_VERSION "1.18.2-dev" /* #define JANET_BUILD "local" */ @@ -32,6 +32,7 @@ /* #define JANET_NO_REALPATH */ /* #define JANET_NO_SYMLINKS */ /* #define JANET_NO_UMASK */ +/* #define JANET_NO_THREADS */ /* Other settings */ /* #define JANET_DEBUG */ @@ -46,7 +47,9 @@ /* #define JANET_STACK_MAX 16384 */ /* #define JANET_OS_NAME my-custom-os */ /* #define JANET_ARCH_NAME pdp-8 */ -/* #define JANET_EV_EPOLL */ +/* #define JANET_EV_NO_EPOLL */ +/* #define JANET_EV_NO_KQUEUE */ +/* #define JANET_NO_INTERPRETER_INTERRUPT */ /* Custom vm allocator support */ /* #include */ diff --git a/src/core/abstract.c b/src/core/abstract.c index f13e7910..12f72be2 100644 --- a/src/core/abstract.c +++ b/src/core/abstract.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -24,6 +24,12 @@ #include "features.h" #include #include "gc.h" +#include "state.h" +#ifdef JANET_EV +#ifdef JANET_WINDOWS +#include +#endif +#endif #endif /* Create new userdata */ @@ -43,3 +49,100 @@ void *janet_abstract_end(void *x) { void *janet_abstract(const JanetAbstractType *atype, size_t size) { return janet_abstract_end(janet_abstract_begin(atype, size)); } + +#ifdef JANET_EV + +/* + * Threaded abstracts + */ + +void *janet_abstract_begin_threaded(const JanetAbstractType *atype, size_t size) { + JanetAbstractHead *header = janet_malloc(sizeof(JanetAbstractHead) + size); + if (NULL == header) { + JANET_OUT_OF_MEMORY; + } + janet_vm.next_collection += size + sizeof(JanetAbstractHead); + header->gc.flags = JANET_MEMORY_THREADED_ABSTRACT; + header->gc.data.next = NULL; /* Clear memory for address sanitizers */ + header->gc.data.refcount = 1; + header->size = size; + header->type = atype; + void *abstract = (void *) & (header->data); + janet_table_put(&janet_vm.threaded_abstracts, janet_wrap_abstract(abstract), janet_wrap_false()); + return abstract; +} + +void *janet_abstract_end_threaded(void *x) { + janet_gc_settype((void *)(janet_abstract_head(x)), JANET_MEMORY_THREADED_ABSTRACT); + return x; +} + +void *janet_abstract_threaded(const JanetAbstractType *atype, size_t size) { + return janet_abstract_end_threaded(janet_abstract_begin_threaded(atype, size)); +} + +/* Refcounting primitives and sync primitives */ + +#ifdef JANET_WINDOWS + +static int32_t janet_incref(JanetAbstractHead *ab) { + return InterlockedIncrement(&ab->gc.data.refcount); +} + +static int32_t janet_decref(JanetAbstractHead *ab) { + return InterlockedDecrement(&ab->gc.data.refcount); +} + +void janet_os_mutex_init(JanetOSMutex *mutex) { + InitializeCriticalSection((CRITICAL_SECTION *) mutex); +} + +void janet_os_mutex_deinit(JanetOSMutex *mutex) { + DeleteCriticalSection((CRITICAL_SECTION *) mutex); +} + +void janet_os_mutex_lock(JanetOSMutex *mutex) { + EnterCriticalSection((CRITICAL_SECTION *) mutex); +} + +void janet_os_mutex_unlock(JanetOSMutex *mutex) { + LeaveCriticalSection((CRITICAL_SECTION *) mutex); +} + +#else + +static int32_t janet_incref(JanetAbstractHead *ab) { + return __atomic_add_fetch(&ab->gc.data.refcount, 1, __ATOMIC_RELAXED); +} + +static int32_t janet_decref(JanetAbstractHead *ab) { + return __atomic_add_fetch(&ab->gc.data.refcount, -1, __ATOMIC_RELAXED); +} + +void janet_os_mutex_init(JanetOSMutex *mutex) { + pthread_mutex_init(mutex, NULL); +} + +void janet_os_mutex_deinit(JanetOSMutex *mutex) { + pthread_mutex_destroy(mutex); +} + +void janet_os_mutex_lock(JanetOSMutex *mutex) { + pthread_mutex_lock(mutex); +} + +void janet_os_mutex_unlock(JanetOSMutex *mutex) { + pthread_mutex_unlock(mutex); +} + +#endif + +int32_t janet_abstract_incref(void *abst) { + return janet_incref(janet_abstract_head(abst)); +} + +int32_t janet_abstract_decref(void *abst) { + return janet_decref(janet_abstract_head(abst)); +} + +#endif diff --git a/src/core/array.c b/src/core/array.c index 820496c4..36d82833 100644 --- a/src/core/array.c +++ b/src/core/array.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -35,7 +35,7 @@ JanetArray *janet_array(int32_t capacity) { JanetArray *array = janet_gcalloc(JANET_MEMORY_ARRAY, sizeof(JanetArray)); Janet *data = NULL; if (capacity > 0) { - janet_vm_next_collection += capacity * sizeof(Janet); + janet_vm.next_collection += capacity * sizeof(Janet); data = (Janet *) janet_malloc(sizeof(Janet) * (size_t) capacity); if (NULL == data) { JANET_OUT_OF_MEMORY; @@ -72,7 +72,7 @@ void janet_array_ensure(JanetArray *array, int32_t capacity, int32_t growth) { if (NULL == newData) { JANET_OUT_OF_MEMORY; } - janet_vm_next_collection += (capacity - array->capacity) * sizeof(Janet); + janet_vm.next_collection += (capacity - array->capacity) * sizeof(Janet); array->data = newData; array->capacity = capacity; } @@ -122,14 +122,19 @@ Janet janet_array_peek(JanetArray *array) { /* C Functions */ -static Janet cfun_array_new(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_new, + "(array/new capacity)", + "Creates a new empty array with a pre-allocated capacity. The same as " + "(array) but can be more efficient if the maximum size of an array is known.") { janet_fixarity(argc, 1); int32_t cap = janet_getinteger(argv, 0); JanetArray *array = janet_array(cap); return janet_wrap_array(array); } -static Janet cfun_array_new_filled(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_new_filled, + "(array/new-filled count &opt value)", + "Creates a new array of `count` elements, all set to `value`, which defaults to nil. Returns the new array.") { janet_arity(argc, 1, 2); int32_t count = janet_getinteger(argv, 0); Janet x = (argc == 2) ? argv[1] : janet_wrap_nil(); @@ -141,7 +146,10 @@ static Janet cfun_array_new_filled(int32_t argc, Janet *argv) { return janet_wrap_array(array); } -static Janet cfun_array_fill(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_fill, + "(array/fill arr &opt value)", + "Replace all elements of an array with `value` (defaulting to nil) without changing the length of the array. " + "Returns the modified array.") { janet_arity(argc, 1, 2); JanetArray *array = janet_getarray(argv, 0); Janet x = (argc == 2) ? argv[1] : janet_wrap_nil(); @@ -151,19 +159,26 @@ static Janet cfun_array_fill(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_array_pop(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_pop, + "(array/pop arr)", + "Remove the last element of the array and return it. If the array is empty, will return nil. Modifies " + "the input array.") { janet_fixarity(argc, 1); JanetArray *array = janet_getarray(argv, 0); return janet_array_pop(array); } -static Janet cfun_array_peek(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_peek, + "(array/peek arr)", + "Returns the last element of the array. Does not modify the array.") { janet_fixarity(argc, 1); JanetArray *array = janet_getarray(argv, 0); return janet_array_peek(array); } -static Janet cfun_array_push(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_push, + "(array/push arr x)", + "Insert an element in the end of an array. Modifies the input array and returns it.") { janet_arity(argc, 1, -1); JanetArray *array = janet_getarray(argv, 0); if (INT32_MAX - argc + 1 <= array->count) { @@ -176,7 +191,12 @@ static Janet cfun_array_push(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_array_ensure(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_ensure, + "(array/ensure arr capacity growth)", + "Ensures that the memory backing the array is large enough for `capacity` " + "items at the given rate of growth. Capacity and growth must be integers. " + "If the backing capacity is already enough, then this function does nothing. " + "Otherwise, the backing memory will be reallocated so that there is enough space.") { janet_fixarity(argc, 3); JanetArray *array = janet_getarray(argv, 0); int32_t newcount = janet_getinteger(argv, 1); @@ -186,7 +206,13 @@ static Janet cfun_array_ensure(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_array_slice(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_slice, + "(array/slice arrtup &opt start end)", + "Takes a slice of array or tuple from `start` to `end`. The range is half open, " + "[start, end). Indexes can also be negative, indicating indexing from the " + "end of the array. By default, `start` is 0 and `end` is the length of the array. " + "Note that index -1 is synonymous with index `(length arrtup)` to allow a full " + "negative slice range. Returns a new array.") { JanetView view = janet_getindexed(argv, 0); JanetRange range = janet_getslice(argc, argv); JanetArray *array = janet_array(range.end - range.start); @@ -196,7 +222,12 @@ static Janet cfun_array_slice(int32_t argc, Janet *argv) { return janet_wrap_array(array); } -static Janet cfun_array_concat(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_concat, + "(array/concat arr & parts)", + "Concatenates a variable number of arrays (and tuples) into the first argument, " + "which must be an array. If any of the parts are arrays or tuples, their elements will " + "be inserted into the array. Otherwise, each part in `parts` will be appended to `arr` in order. " + "Return the modified array `arr`.") { int32_t i; janet_arity(argc, 1, -1); JanetArray *array = janet_getarray(argv, 0); @@ -210,6 +241,11 @@ static Janet cfun_array_concat(int32_t argc, Janet *argv) { int32_t j, len = 0; const Janet *vals = NULL; janet_indexed_view(argv[i], &vals, &len); + if (array->data == vals) { + int32_t newcount = array->count + len; + janet_array_ensure(array, newcount, 2); + janet_indexed_view(argv[i], &vals, &len); + } for (j = 0; j < len; j++) janet_array_push(array, vals[j]); } @@ -219,7 +255,12 @@ static Janet cfun_array_concat(int32_t argc, Janet *argv) { return janet_wrap_array(array); } -static Janet cfun_array_insert(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_insert, + "(array/insert arr at & xs)", + "Insert all `xs` into array `arr` at index `at`. `at` should be an integer between " + "0 and the length of the array. A negative value for `at` will index backwards from " + "the end of the array, such that inserting at -1 appends to the array. " + "Returns the array.") { size_t chunksize, restsize; janet_arity(argc, 2, -1); JanetArray *array = janet_getarray(argv, 0); @@ -245,7 +286,12 @@ static Janet cfun_array_insert(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_array_remove(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_remove, + "(array/remove arr at &opt n)", + "Remove up to `n` elements starting at index `at` in array `arr`. `at` can index from " + "the end of the array with a negative index, and `n` must be a non-negative integer. " + "By default, `n` is 1. " + "Returns the array.") { janet_arity(argc, 2, 3); JanetArray *array = janet_getarray(argv, 0); int32_t at = janet_getinteger(argv, 1); @@ -270,7 +316,9 @@ static Janet cfun_array_remove(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_array_trim(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_trim, + "(array/trim arr)", + "Set the backing capacity of an array to its current length. Returns the modified array.") { janet_fixarity(argc, 1); JanetArray *array = janet_getarray(argv, 0); if (array->count) { @@ -290,103 +338,33 @@ static Janet cfun_array_trim(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_array_clear(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_array_clear, + "(array/clear arr)", + "Empties an array, setting it's count to 0 but does not free the backing capacity. " + "Returns the modified array.") { janet_fixarity(argc, 1); JanetArray *array = janet_getarray(argv, 0); array->count = 0; return argv[0]; } -static const JanetReg array_cfuns[] = { - { - "array/new", cfun_array_new, - JDOC("(array/new capacity)\n\n" - "Creates a new empty array with a pre-allocated capacity. The same as " - "(array) but can be more efficient if the maximum size of an array is known.") - }, - { - "array/new-filled", cfun_array_new_filled, - JDOC("(array/new-filled count &opt value)\n\n" - "Creates a new array of count elements, all set to value, which defaults to nil. Returns the new array.") - }, - { - "array/fill", cfun_array_fill, - JDOC("(array/fill arr &opt value)\n\n" - "Replace all elements of an array with value (defaulting to nil) without changing the length of the array. " - "Returns the modified array.") - }, - { - "array/pop", cfun_array_pop, - JDOC("(array/pop arr)\n\n" - "Remove the last element of the array and return it. If the array is empty, will return nil. Modifies " - "the input array.") - }, - { - "array/peek", cfun_array_peek, - JDOC("(array/peek arr)\n\n" - "Returns the last element of the array. Does not modify the array.") - }, - { - "array/push", cfun_array_push, - JDOC("(array/push arr x)\n\n" - "Insert an element in the end of an array. Modifies the input array and returns it.") - }, - { - "array/ensure", cfun_array_ensure, - JDOC("(array/ensure arr capacity growth)\n\n" - "Ensures that the memory backing the array is large enough for capacity " - "items at the given rate of growth. Capacity and growth must be integers. " - "If the backing capacity is already enough, then this function does nothing. " - "Otherwise, the backing memory will be reallocated so that there is enough space.") - }, - { - "array/slice", cfun_array_slice, - JDOC("(array/slice arrtup &opt start end)\n\n" - "Takes a slice of array or tuple from start to end. The range is half open, " - "[start, end). Indexes can also be negative, indicating indexing from the end of the " - "end of the array. By default, start is 0 and end is the length of the array. " - "Note that index -1 is synonymous with index (length arrtup) to allow a full " - "negative slice range. Returns a new array.") - }, - { - "array/concat", cfun_array_concat, - JDOC("(array/concat arr & parts)\n\n" - "Concatenates a variable number of arrays (and tuples) into the first argument " - "which must be an array. If any of the parts are arrays or tuples, their elements will " - "be inserted into the array. Otherwise, each part in parts will be appended to arr in order. " - "Return the modified array arr.") - }, - { - "array/insert", cfun_array_insert, - JDOC("(array/insert arr at & xs)\n\n" - "Insert all xs into array arr at index at. at should be an integer between " - "0 and the length of the array. A negative value for at will index backwards from " - "the end of the array, such that inserting at -1 appends to the array. " - "Returns the array.") - }, - { - "array/remove", cfun_array_remove, - JDOC("(array/remove arr at &opt n)\n\n" - "Remove up to n elements starting at index at in array arr. at can index from " - "the end of the array with a negative index, and n must be a non-negative integer. " - "By default, n is 1. " - "Returns the array.") - }, - { - "array/trim", cfun_array_trim, - JDOC("(array/trim arr)\n\n" - "Set the backing capacity of an array to its current length. Returns the modified array.") - }, - { - "array/clear", cfun_array_clear, - JDOC("(array/clear arr)\n\n" - "Empties an array, setting it's count to 0 but does not free the backing capacity. " - "Returns the modified array.") - }, - {NULL, NULL, NULL} -}; - /* Load the array module */ void janet_lib_array(JanetTable *env) { - janet_core_cfuns(env, NULL, array_cfuns); + JanetRegExt array_cfuns[] = { + JANET_CORE_REG("array/new", cfun_array_new), + JANET_CORE_REG("array/new-filled", cfun_array_new_filled), + JANET_CORE_REG("array/fill", cfun_array_fill), + JANET_CORE_REG("array/pop", cfun_array_pop), + JANET_CORE_REG("array/peek", cfun_array_peek), + JANET_CORE_REG("array/push", cfun_array_push), + JANET_CORE_REG("array/ensure", cfun_array_ensure), + JANET_CORE_REG("array/slice", cfun_array_slice), + JANET_CORE_REG("array/concat", cfun_array_concat), + JANET_CORE_REG("array/insert", cfun_array_insert), + JANET_CORE_REG("array/remove", cfun_array_remove), + JANET_CORE_REG("array/trim", cfun_array_trim), + JANET_CORE_REG("array/clear", cfun_array_clear), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, array_cfuns); } diff --git a/src/core/asm.c b/src/core/asm.c index 31e3dac1..b603b383 100644 --- a/src/core/asm.c +++ b/src/core/asm.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -942,8 +942,12 @@ Janet janet_disasm(JanetFuncDef *def) { return janet_wrap_struct(janet_table_to_struct(ret)); } -/* C Function for assembly */ -static Janet cfun_asm(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_asm, + "(asm assembly)", + "Returns a new function that is the compiled result of the assembly.\n" + "The syntax for the assembly can be found on the Janet website, and should correspond\n" + "to the return value of disasm. Will throw an\n" + "error on invalid assembly.") { janet_fixarity(argc, 1); JanetAssembleResult res; res = janet_asm(argv[0], 0); @@ -953,7 +957,24 @@ static Janet cfun_asm(int32_t argc, Janet *argv) { return janet_wrap_function(janet_thunk(res.funcdef)); } -static Janet cfun_disasm(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_disasm, + "(disasm func &opt field)", + "Returns assembly that could be used to compile the given function. " + "func must be a function, not a c function. Will throw on error on a badly " + "typed argument. If given a field name, will only return that part of the function assembly. " + "Possible fields are:\n\n" + "* :arity - number of required and optional arguments.\n" + "* :min-arity - minimum number of arguments function can be called with.\n" + "* :max-arity - maximum number of arguments function can be called with.\n" + "* :vararg - true if function can take a variable number of arguments.\n" + "* :bytecode - array of parsed bytecode instructions. Each instruction is a tuple.\n" + "* :source - name of source file that this function was compiled from.\n" + "* :name - name of function.\n" + "* :slotcount - how many virtual registers, or slots, this function uses. Corresponds to stack space used by function.\n" + "* :constants - an array of constants referenced by this function.\n" + "* :sourcemap - a mapping of each bytecode instruction to a line and column in the source file.\n" + "* :environments - an internal mapping of which enclosing functions are referenced for bindings.\n" + "* :defs - other function definitions that this function may instantiate.\n") { janet_arity(argc, 1, 2); JanetFunction *f = janet_getfunction(argv, 0); if (argc == 2) { @@ -976,41 +997,14 @@ static Janet cfun_disasm(int32_t argc, Janet *argv) { } } -static const JanetReg asm_cfuns[] = { - { - "asm", cfun_asm, - JDOC("(asm assembly)\n\n" - "Returns a new function that is the compiled result of the assembly.\n" - "The syntax for the assembly can be found on the Janet website, and should correspond\n" - "to the return value of disasm. Will throw an\n" - "error on invalid assembly.") - }, - { - "disasm", cfun_disasm, - JDOC("(disasm func &opt field)\n\n" - "Returns assembly that could be used to compile the given function.\n" - "func must be a function, not a c function. Will throw on error on a badly\n" - "typed argument. If given a field name, will only return that part of the function assembly.\n" - "Possible fields are:\n\n" - "* :arity - number of required and optional arguments.\n\n" - "* :min-arity - minimum number of arguments function can be called with.\n\n" - "* :max-arity - maximum number of arguments function can be called with.\n\n" - "* :vararg - true if function can take a variable number of arguments.\n\n" - "* :bytecode - array of parsed bytecode instructions. Each instruction is a tuple.\n\n" - "* :source - name of source file that this function was compiled from.\n\n" - "* :name - name of function.\n\n" - "* :slotcount - how many virtual registers, or slots, this function uses. Corresponds to stack space used by function.\n\n" - "* :constants - an array of constants referenced by this function.\n\n" - "* :sourcemap - a mapping of each bytecode instruction to a line and column in the source file.\n\n" - "* :environments - an internal mapping of which enclosing functions are referenced for bindings.\n\n" - "* :defs - other function definitions that this function may instantiate.\n") - }, - {NULL, NULL, NULL} -}; - /* Load the library */ void janet_lib_asm(JanetTable *env) { - janet_core_cfuns(env, NULL, asm_cfuns); + JanetRegExt asm_cfuns[] = { + JANET_CORE_REG("asm", cfun_asm), + JANET_CORE_REG("disasm", cfun_disasm), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, asm_cfuns); } #endif diff --git a/src/core/buffer.c b/src/core/buffer.c index 1f4791d9..802051f1 100644 --- a/src/core/buffer.c +++ b/src/core/buffer.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -162,14 +162,20 @@ void janet_buffer_push_u64(JanetBuffer *buffer, uint64_t x) { /* C functions */ -static Janet cfun_buffer_new(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_new, + "(buffer/new capacity)", + "Creates a new, empty buffer with enough backing memory for capacity bytes. " + "Returns a new buffer of length 0.") { janet_fixarity(argc, 1); int32_t cap = janet_getinteger(argv, 0); JanetBuffer *buffer = janet_buffer(cap); return janet_wrap_buffer(buffer); } -static Janet cfun_buffer_new_filled(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_new_filled, + "(buffer/new-filled count &opt byte)", + "Creates a new buffer of length count filled with byte. By default, byte is 0. " + "Returns the new buffer.") { janet_arity(argc, 1, 2); int32_t count = janet_getinteger(argv, 0); int32_t byte = 0; @@ -183,7 +189,10 @@ static Janet cfun_buffer_new_filled(int32_t argc, Janet *argv) { return janet_wrap_buffer(buffer); } -static Janet cfun_buffer_fill(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_fill, + "(buffer/fill buffer &opt byte)", + "Fill up a buffer with bytes, defaulting to 0s. Does not change the buffer's length. " + "Returns the modified buffer.") { janet_arity(argc, 1, 2); JanetBuffer *buffer = janet_getbuffer(argv, 0); int32_t byte = 0; @@ -196,7 +205,10 @@ static Janet cfun_buffer_fill(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_trim(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_trim, + "(buffer/trim buffer)", + "Set the backing capacity of the buffer to the current length of the buffer. Returns the " + "modified buffer.") { janet_fixarity(argc, 1); JanetBuffer *buffer = janet_getbuffer(argv, 0); if (buffer->count < buffer->capacity) { @@ -211,7 +223,10 @@ static Janet cfun_buffer_trim(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_u8(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_u8, + "(buffer/push-byte buffer & xs)", + "Append bytes to a buffer. Will expand the buffer as necessary. " + "Returns the modified buffer. Will throw an error if the buffer overflows.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); @@ -221,7 +236,11 @@ static Janet cfun_buffer_u8(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_word(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_word, + "(buffer/push-word buffer & xs)", + "Append machine words to a buffer. The 4 bytes of the integer are appended " + "in twos complement, little endian order, unsigned for all x. Returns the modified buffer. Will " + "throw an error if the buffer overflows.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); @@ -235,7 +254,12 @@ static Janet cfun_buffer_word(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_chars(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_chars, + "(buffer/push-string buffer & xs)", + "Push byte sequences onto the end of a buffer. " + "Will accept any of strings, keywords, symbols, and buffers. " + "Returns the modified buffer. " + "Will throw an error if the buffer overflows.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); @@ -250,7 +274,13 @@ static Janet cfun_buffer_chars(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_push(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_push, + "(buffer/push buffer & xs)", + "Push both individual bytes and byte sequences to a buffer. For each x in xs, " + "push the byte if x is an integer, otherwise push the bytesequence to the buffer. " + "Thus, this function behaves like both `buffer/push-string` and `buffer/push-byte`. " + "Returns the modified buffer. " + "Will throw an error if the buffer overflows.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); @@ -270,14 +300,19 @@ static Janet cfun_buffer_push(int32_t argc, Janet *argv) { } -static Janet cfun_buffer_clear(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_clear, + "(buffer/clear buffer)", + "Sets the size of a buffer to 0 and empties it. The buffer retains " + "its memory so it can be efficiently refilled. Returns the modified buffer.") { janet_fixarity(argc, 1); JanetBuffer *buffer = janet_getbuffer(argv, 0); buffer->count = 0; return argv[0]; } -static Janet cfun_buffer_popn(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_popn, + "(buffer/popn buffer n)", + "Removes the last n bytes from the buffer. Returns the modified buffer.") { janet_fixarity(argc, 2); JanetBuffer *buffer = janet_getbuffer(argv, 0); int32_t n = janet_getinteger(argv, 1); @@ -290,7 +325,12 @@ static Janet cfun_buffer_popn(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_slice(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_slice, + "(buffer/slice bytes &opt start end)", + "Takes a slice of a byte sequence from start to end. The range is half open, " + "[start, end). Indexes can also be negative, indicating indexing from the end of the " + "end of the array. By default, start is 0 and end is the length of the buffer. " + "Returns a new buffer.") { JanetByteView view = janet_getbytes(argv, 0); JanetRange range = janet_getslice(argc, argv); JanetBuffer *buffer = janet_buffer(range.end - range.start); @@ -314,7 +354,9 @@ static void bitloc(int32_t argc, Janet *argv, JanetBuffer **b, int32_t *index, i *bit = which_bit; } -static Janet cfun_buffer_bitset(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_bitset, + "(buffer/bit-set buffer index)", + "Sets the bit at the given bit-index. Returns the buffer.") { int bit; int32_t index; JanetBuffer *buffer; @@ -323,7 +365,9 @@ static Janet cfun_buffer_bitset(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_bitclear(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_bitclear, + "(buffer/bit-clear buffer index)", + "Clears the bit at the given bit-index. Returns the buffer.") { int bit; int32_t index; JanetBuffer *buffer; @@ -332,7 +376,9 @@ static Janet cfun_buffer_bitclear(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_bitget(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_bitget, + "(buffer/bit buffer index)", + "Gets the bit at the given bit-index. Returns true if the bit is set, false if not.") { int bit; int32_t index; JanetBuffer *buffer; @@ -340,7 +386,9 @@ static Janet cfun_buffer_bitget(int32_t argc, Janet *argv) { return janet_wrap_boolean(buffer->data[index] & (1 << bit)); } -static Janet cfun_buffer_bittoggle(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_bittoggle, + "(buffer/bit-toggle buffer index)", + "Toggles the bit at the given bit index in buffer. Returns the buffer.") { int bit; int32_t index; JanetBuffer *buffer; @@ -349,7 +397,11 @@ static Janet cfun_buffer_bittoggle(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_blit(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_blit, + "(buffer/blit dest src &opt dest-start src-start src-end)", + "Insert the contents of src into dest. Can optionally take indices that " + "indicate which part of src to copy into which part of dest. Indices can be " + "negative to index from the end of src or dest. Returns dest.") { janet_arity(argc, 2, 5); JanetBuffer *dest = janet_getbuffer(argv, 0); JanetByteView src = janet_getbytes(argv, 1); @@ -386,7 +438,10 @@ static Janet cfun_buffer_blit(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_buffer_format(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_buffer_format, + "(buffer/format buffer format & args)", + "Snprintf like functionality for printing values into a buffer. Returns " + " the modified buffer.") { janet_arity(argc, 2, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); const char *strfrmt = (const char *) janet_getstring(argv, 1); @@ -394,116 +449,26 @@ static Janet cfun_buffer_format(int32_t argc, Janet *argv) { return argv[0]; } -static const JanetReg buffer_cfuns[] = { - { - "buffer/new", cfun_buffer_new, - JDOC("(buffer/new capacity)\n\n" - "Creates a new, empty buffer with enough backing memory for capacity bytes. " - "Returns a new buffer of length 0.") - }, - { - "buffer/new-filled", cfun_buffer_new_filled, - JDOC("(buffer/new-filled count &opt byte)\n\n" - "Creates a new buffer of length count filled with byte. By default, byte is 0. " - "Returns the new buffer.") - }, - { - "buffer/fill", cfun_buffer_fill, - JDOC("(buffer/fill buffer &opt byte)\n\n" - "Fill up a buffer with bytes, defaulting to 0s. Does not change the buffer's length. " - "Returns the modified buffer.") - }, - { - "buffer/trim", cfun_buffer_trim, - JDOC("(buffer/trim buffer)\n\n" - "Set the backing capacity of the buffer to the current length of the buffer. Returns the " - "modified buffer.") - }, - { - "buffer/push-byte", cfun_buffer_u8, - JDOC("(buffer/push-byte buffer & xs)\n\n" - "Append bytes to a buffer. Will expand the buffer as necessary. " - "Returns the modified buffer. Will throw an error if the buffer overflows.") - }, - { - "buffer/push-word", cfun_buffer_word, - JDOC("(buffer/push-word buffer & xs)\n\n" - "Append machine words to a buffer. The 4 bytes of the integer are appended " - "in twos complement, little endian order, unsigned for all x. Returns the modified buffer. Will " - "throw an error if the buffer overflows.") - }, - { - "buffer/push-string", cfun_buffer_chars, - JDOC("(buffer/push-string buffer & xs)\n\n" - "Push byte sequences onto the end of a buffer. " - "Will accept any of strings, keywords, symbols, and buffers. " - "Returns the modified buffer. " - "Will throw an error if the buffer overflows.") - }, - { - "buffer/push", cfun_buffer_push, - JDOC("(buffer/push buffer & xs)\n\n" - "Push both individual bytes and byte sequences to a buffer. For each x in xs, " - "push the byte if x is an integer, otherwise push the bytesequence to the buffer. " - "Thus, this function behaves like both `buffer/push-string` and `buffer/push-byte`. " - "Returns the modified buffer. " - "Will throw an error if the buffer overflows.") - }, - { - "buffer/popn", cfun_buffer_popn, - JDOC("(buffer/popn buffer n)\n\n" - "Removes the last n bytes from the buffer. Returns the modified buffer.") - }, - { - "buffer/clear", cfun_buffer_clear, - JDOC("(buffer/clear buffer)\n\n" - "Sets the size of a buffer to 0 and empties it. The buffer retains " - "its memory so it can be efficiently refilled. Returns the modified buffer.") - }, - { - "buffer/slice", cfun_buffer_slice, - JDOC("(buffer/slice bytes &opt start end)\n\n" - "Takes a slice of a byte sequence from start to end. The range is half open, " - "[start, end). Indexes can also be negative, indicating indexing from the end of the " - "end of the array. By default, start is 0 and end is the length of the buffer. " - "Returns a new buffer.") - }, - { - "buffer/bit-set", cfun_buffer_bitset, - JDOC("(buffer/bit-set buffer index)\n\n" - "Sets the bit at the given bit-index. Returns the buffer.") - }, - { - "buffer/bit-clear", cfun_buffer_bitclear, - JDOC("(buffer/bit-clear buffer index)\n\n" - "Clears the bit at the given bit-index. Returns the buffer.") - }, - { - "buffer/bit", cfun_buffer_bitget, - JDOC("(buffer/bit buffer index)\n\n" - "Gets the bit at the given bit-index. Returns true if the bit is set, false if not.") - }, - { - "buffer/bit-toggle", cfun_buffer_bittoggle, - JDOC("(buffer/bit-toggle buffer index)\n\n" - "Toggles the bit at the given bit index in buffer. Returns the buffer.") - }, - { - "buffer/blit", cfun_buffer_blit, - JDOC("(buffer/blit dest src &opt dest-start src-start src-end)\n\n" - "Insert the contents of src into dest. Can optionally take indices that " - "indicate which part of src to copy into which part of dest. Indices can be " - "negative to index from the end of src or dest. Returns dest.") - }, - { - "buffer/format", cfun_buffer_format, - JDOC("(buffer/format buffer format & args)\n\n" - "Snprintf like functionality for printing values into a buffer. Returns " - " the modified buffer.") - }, - {NULL, NULL, NULL} -}; - void janet_lib_buffer(JanetTable *env) { - janet_core_cfuns(env, NULL, buffer_cfuns); + JanetRegExt buffer_cfuns[] = { + JANET_CORE_REG("buffer/new", cfun_buffer_new), + JANET_CORE_REG("buffer/new-filled", cfun_buffer_new_filled), + JANET_CORE_REG("buffer/fill", cfun_buffer_fill), + JANET_CORE_REG("buffer/trim", cfun_buffer_trim), + JANET_CORE_REG("buffer/push-byte", cfun_buffer_u8), + JANET_CORE_REG("buffer/push-word", cfun_buffer_word), + JANET_CORE_REG("buffer/push-string", cfun_buffer_chars), + JANET_CORE_REG("buffer/push", cfun_buffer_push), + JANET_CORE_REG("buffer/popn", cfun_buffer_popn), + JANET_CORE_REG("buffer/clear", cfun_buffer_clear), + JANET_CORE_REG("buffer/slice", cfun_buffer_slice), + JANET_CORE_REG("buffer/bit-set", cfun_buffer_bitset), + JANET_CORE_REG("buffer/bit-clear", cfun_buffer_bitclear), + JANET_CORE_REG("buffer/bit", cfun_buffer_bitget), + JANET_CORE_REG("buffer/bit-toggle", cfun_buffer_bittoggle), + JANET_CORE_REG("buffer/blit", cfun_buffer_blit), + JANET_CORE_REG("buffer/format", cfun_buffer_format), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, buffer_cfuns); } diff --git a/src/core/bytecode.c b/src/core/bytecode.c index bd07b5ef..44b576a8 100644 --- a/src/core/bytecode.c +++ b/src/core/bytecode.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/capi.c b/src/core/capi.c index 4cff6257..c86e9783 100644 --- a/src/core/capi.c +++ b/src/core/capi.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -51,15 +51,15 @@ JANET_NO_RETURN static void janet_top_level_signal(const char *msg) { } void janet_signalv(JanetSignal sig, Janet message) { - if (janet_vm_return_reg != NULL) { - *janet_vm_return_reg = message; - if (NULL != janet_vm_fiber) { - janet_vm_fiber->flags |= JANET_FIBER_DID_LONGJUMP; + if (janet_vm.return_reg != NULL) { + *janet_vm.return_reg = message; + if (NULL != janet_vm.fiber) { + janet_vm.fiber->flags |= JANET_FIBER_DID_LONGJUMP; } #if defined(JANET_BSD) || defined(JANET_APPLE) - _longjmp(*janet_vm_jmp_buf, sig); + _longjmp(*janet_vm.signal_buf, sig); #else - longjmp(*janet_vm_jmp_buf, sig); + longjmp(*janet_vm.signal_buf, sig); #endif } else { const char *str = (const char *)janet_formatc("janet top level signal - %v\n", message); @@ -212,7 +212,7 @@ const char *janet_getcstring(const Janet *argv, int32_t n) { const uint8_t *jstr = janet_getstring(argv, n); const char *cstr = (const char *)jstr; if (strlen(cstr) != (size_t) janet_string_length(jstr)) { - janet_panicf("string %v contains embedded 0s"); + janet_panic("string contains embedded 0s"); } return cstr; } @@ -358,26 +358,26 @@ JanetRange janet_getslice(int32_t argc, const Janet *argv) { } Janet janet_dyn(const char *name) { - if (!janet_vm_fiber) { - if (!janet_vm_top_dyns) return janet_wrap_nil(); - return janet_table_get(janet_vm_top_dyns, janet_ckeywordv(name)); + if (!janet_vm.fiber) { + if (!janet_vm.top_dyns) return janet_wrap_nil(); + return janet_table_get(janet_vm.top_dyns, janet_ckeywordv(name)); } - if (janet_vm_fiber->env) { - return janet_table_get(janet_vm_fiber->env, janet_ckeywordv(name)); + if (janet_vm.fiber->env) { + return janet_table_get(janet_vm.fiber->env, janet_ckeywordv(name)); } else { return janet_wrap_nil(); } } void janet_setdyn(const char *name, Janet value) { - if (!janet_vm_fiber) { - if (!janet_vm_top_dyns) janet_vm_top_dyns = janet_table(10); - janet_table_put(janet_vm_top_dyns, janet_ckeywordv(name), value); + if (!janet_vm.fiber) { + if (!janet_vm.top_dyns) janet_vm.top_dyns = janet_table(10); + janet_table_put(janet_vm.top_dyns, janet_ckeywordv(name), value); } else { - if (!janet_vm_fiber->env) { - janet_vm_fiber->env = janet_table(1); + if (!janet_vm.fiber->env) { + janet_vm.fiber->env = janet_table(1); } - janet_table_put(janet_vm_fiber->env, janet_ckeywordv(name), value); + janet_table_put(janet_vm.fiber->env, janet_ckeywordv(name), value); } } diff --git a/src/core/cfuns.c b/src/core/cfuns.c index 3e5f9ad6..046aa9e1 100644 --- a/src/core/cfuns.c +++ b/src/core/cfuns.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/compile.c b/src/core/compile.c index 1583d81f..bc7e99c5 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -53,6 +53,36 @@ void janetc_cerror(JanetCompiler *c, const char *m) { janetc_error(c, janet_cstring(m)); } +static const char *janet_lint_level_names[] = { + "relaxed", + "normal", + "strict" +}; + +/* Emit compiler linter messages */ +void janetc_lintf(JanetCompiler *c, JanetCompileLintLevel level, const char *format, ...) { + if (NULL != c->lints) { + /* format message */ + va_list args; + JanetBuffer buffer; + int32_t len = 0; + while (format[len]) len++; + janet_buffer_init(&buffer, len); + va_start(args, format); + janet_formatbv(&buffer, format, args); + va_end(args); + const uint8_t *str = janet_string(buffer.data, buffer.count); + janet_buffer_deinit(&buffer); + /* construct linting payload */ + Janet *payload = janet_tuple_begin(4); + payload[0] = janet_ckeywordv(janet_lint_level_names[level]); + payload[1] = c->current_mapping.line == -1 ? janet_wrap_nil() : janet_wrap_integer(c->current_mapping.line); + payload[2] = c->current_mapping.column == -1 ? janet_wrap_nil() : janet_wrap_integer(c->current_mapping.column); + payload[3] = janet_wrap_string(str); + janet_array_push(c->lints, janet_wrap_tuple(janet_tuple_end(payload))); + } +} + /* Free a slot */ void janetc_freeslot(JanetCompiler *c, JanetSlot s) { if (s.flags & (JANET_SLOT_CONSTANT | JANET_SLOT_REF | JANET_SLOT_NAMED)) return; @@ -199,24 +229,41 @@ JanetSlot janetc_resolve( /* Symbol not found - check for global */ { - Janet check; - JanetBindingType btype = janet_resolve(c->env, sym, &check); - switch (btype) { + JanetBinding binding = janet_resolve_ext(c->env, sym); + switch (binding.type) { default: case JANET_BINDING_NONE: janetc_error(c, janet_formatc("unknown symbol %q", janet_wrap_symbol(sym))); return janetc_cslot(janet_wrap_nil()); case JANET_BINDING_DEF: case JANET_BINDING_MACRO: /* Macro should function like defs when not in calling pos */ - return janetc_cslot(check); + ret = janetc_cslot(binding.value); + break; case JANET_BINDING_VAR: { - JanetSlot ret = janetc_cslot(check); - /* TODO save type info */ + ret = janetc_cslot(binding.value); ret.flags |= JANET_SLOT_REF | JANET_SLOT_NAMED | JANET_SLOT_MUTABLE | JANET_SLOTTYPE_ANY; ret.flags &= ~JANET_SLOT_CONSTANT; - return ret; + break; } } + JanetCompileLintLevel depLevel = JANET_C_LINT_RELAXED; + switch (binding.deprecation) { + case JANET_BINDING_DEP_NONE: + break; + case JANET_BINDING_DEP_RELAXED: + depLevel = JANET_C_LINT_RELAXED; + break; + case JANET_BINDING_DEP_NORMAL: + depLevel = JANET_C_LINT_NORMAL; + break; + case JANET_BINDING_DEP_STRICT: + depLevel = JANET_C_LINT_STRICT; + break; + } + if (binding.deprecation != JANET_BINDING_DEP_NONE) { + janetc_lintf(c, depLevel, "%q is deprecated", janet_wrap_symbol(sym)); + } + return ret; } /* Symbol was found */ @@ -399,6 +446,7 @@ void janetc_throwaway(JanetFopts opts, Janet x) { int32_t mapbufstart = janet_v_count(c->mapbuffer); janetc_scope(&unusedScope, c, JANET_SCOPE_UNUSED, "unusued"); janetc_value(opts, x); + janetc_lintf(c, JANET_C_LINT_STRICT, "dead code, consider removing %.2q", x); janetc_popscope(c); if (c->buffer) { janet_v__cnt(c->buffer) = bufstart; @@ -631,6 +679,9 @@ static int macroexpand1( Janet tempOut; JanetSignal status = janet_continue(fiberp, janet_wrap_nil(), &tempOut); janet_table_put(c->env, mf_kw, janet_wrap_nil()); + if (c->lints) { + janet_table_put(c->env, janet_ckeywordv("macro-lints"), janet_wrap_array(c->lints)); + } janet_gcunlock(lock); if (status != JANET_SIGNAL_OK) { const uint8_t *es = janet_formatc("(macro) %V", tempOut); @@ -825,7 +876,7 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { } /* Initialize a compiler */ -static void janetc_init(JanetCompiler *c, JanetTable *env, const uint8_t *where) { +static void janetc_init(JanetCompiler *c, JanetTable *env, const uint8_t *where, JanetArray *lints) { c->scope = NULL; c->buffer = NULL; c->mapbuffer = NULL; @@ -834,6 +885,7 @@ static void janetc_init(JanetCompiler *c, JanetTable *env, const uint8_t *where) c->source = where; c->current_mapping.line = -1; c->current_mapping.column = -1; + c->lints = lints; /* Init result */ c->result.error = NULL; c->result.status = JANET_COMPILE_OK; @@ -851,12 +903,13 @@ static void janetc_deinit(JanetCompiler *c) { } /* Compile a form. */ -JanetCompileResult janet_compile(Janet source, JanetTable *env, const uint8_t *where) { +JanetCompileResult janet_compile_lint(Janet source, + JanetTable *env, const uint8_t *where, JanetArray *lints) { JanetCompiler c; JanetScope rootscope; JanetFopts fopts; - janetc_init(&c, env, where); + janetc_init(&c, env, where, lints); /* Push a function scope */ janetc_scope(&rootscope, &c, JANET_SCOPE_FUNCTION | JANET_SCOPE_TOP, "root"); @@ -884,19 +937,31 @@ JanetCompileResult janet_compile(Janet source, JanetTable *env, const uint8_t *w return c.result; } +JanetCompileResult janet_compile(Janet source, JanetTable *env, const uint8_t *where) { + return janet_compile_lint(source, env, where, NULL); +} + /* C Function for compiling */ -static Janet cfun(int32_t argc, Janet *argv) { - janet_arity(argc, 1, 3); - JanetTable *env = argc > 1 ? janet_gettable(argv, 1) : janet_vm_fiber->env; +JANET_CORE_FN(cfun, + "(compile ast &opt env source lints)", + "Compiles an Abstract Syntax Tree (ast) into a function. " + "Pair the compile function with parsing functionality to implement " + "eval. Returns a new function and does not modify ast. Returns an error " + "struct with keys :line, :column, and :error if compilation fails. " + "If a `lints` array is given, linting messages will be appended to the array. " + "Each message will be a tuple of the form `(level line col message)`.") { + janet_arity(argc, 1, 4); + JanetTable *env = argc > 1 ? janet_gettable(argv, 1) : janet_vm.fiber->env; if (NULL == env) { env = janet_table(0); - janet_vm_fiber->env = env; + janet_vm.fiber->env = env; } const uint8_t *source = NULL; - if (argc == 3) { + if (argc >= 3) { source = janet_getstring(argv, 2); } - JanetCompileResult res = janet_compile(argv[0], env, source); + JanetArray *lints = (argc >= 4) ? janet_getarray(argv, 3) : NULL; + JanetCompileResult res = janet_compile_lint(argv[0], env, source, lints); if (res.status == JANET_COMPILE_OK) { return janet_wrap_function(janet_thunk(res.funcdef)); } else { @@ -915,18 +980,10 @@ static Janet cfun(int32_t argc, Janet *argv) { } } -static const JanetReg compile_cfuns[] = { - { - "compile", cfun, - JDOC("(compile ast &opt env source)\n\n" - "Compiles an Abstract Syntax Tree (ast) into a function. " - "Pair the compile function with parsing functionality to implement " - "eval. Returns a new function and does not modify ast. Returns an error " - "struct with keys :line, :column, and :error if compilation fails.") - }, - {NULL, NULL, NULL} -}; - void janet_lib_compile(JanetTable *env) { - janet_core_cfuns(env, NULL, compile_cfuns); + JanetRegExt cfuns[] = { + JANET_CORE_REG("compile", cfun), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, cfuns); } diff --git a/src/core/compile.h b/src/core/compile.h index 20f20224..2b510cec 100644 --- a/src/core/compile.h +++ b/src/core/compile.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -29,6 +29,13 @@ #include "regalloc.h" #endif +/* Levels for compiler warnings */ +typedef enum { + JANET_C_LINT_RELAXED, + JANET_C_LINT_NORMAL, + JANET_C_LINT_STRICT +} JanetCompileLintLevel; + /* Tags for some functions for the prepared inliner */ #define JANET_FUN_DEBUG 1 #define JANET_FUN_ERROR 2 @@ -78,10 +85,10 @@ typedef struct JanetSpecial JanetSpecial; #define JANET_SLOT_MUTABLE 0x40000 #define JANET_SLOT_REF 0x80000 #define JANET_SLOT_RETURNED 0x100000 -/* Needed for handling single element arrays as global vars. */ - -/* Used for unquote-splicing */ -#define JANET_SLOT_SPLICED 0x200000 +#define JANET_SLOT_DEP_NOTE 0x200000 +#define JANET_SLOT_DEP_WARN 0x400000 +#define JANET_SLOT_DEP_ERROR 0x800000 +#define JANET_SLOT_SPLICED 0x1000000 #define JANET_SLOTTYPE_ANY 0xFFFF @@ -164,6 +171,9 @@ struct JanetCompiler { /* Prevent unbounded recursion */ int recursion_guard; + + /* Collect linting results */ + JanetArray *lints; }; #define JANET_FOPTS_TAIL 0x10000 @@ -230,6 +240,9 @@ JanetSlot janetc_return(JanetCompiler *c, JanetSlot s); void janetc_error(JanetCompiler *c, const uint8_t *m); void janetc_cerror(JanetCompiler *c, const char *m); +/* Linting */ +void janetc_lintf(JanetCompiler *C, JanetCompileLintLevel level, const char *format, ...); + /* Dispatch to correct form compiler */ JanetSlot janetc_value(JanetFopts opts, Janet x); diff --git a/src/core/corelib.c b/src/core/corelib.c index f6521f50..24e24a60 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -35,6 +35,13 @@ extern const unsigned char *janet_core_image; extern size_t janet_core_image_size; #endif +/* Docstrings should only exist during bootstrap */ +#ifdef JANET_BOOTSTRAP +#define JDOC(x) (x) +#else +#define JDOC(x) NULL +#endif + /* Use LoadLibrary on windows or dlopen on posix to load dynamic libaries * with native code. */ #if defined(JANET_NO_DYNAMIC_MODULES) @@ -130,7 +137,7 @@ static const char *janet_dyncstring(const char *name, const char *dflt) { const uint8_t *jstr = janet_unwrap_string(x); const char *cstr = (const char *)jstr; if (strlen(cstr) != (size_t) janet_string_length(jstr)) { - janet_panicf("string %v contains embedded 0s"); + janet_panicf("string %v contains embedded 0s", x); } return cstr; } @@ -143,7 +150,18 @@ static int is_path_sep(char c) { } /* Used for module system. */ -static Janet janet_core_expand_path(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_expand_path, + "(module/expand-path path template)", + "Expands a path template as found in `module/paths` for `module/find`. " + "This takes in a path (the argument to require) and a template string, " + "to expand the path to a path that can be " + "used for importing files. The replacements are as follows:\n\n" + "* :all: -- the value of path verbatim\n\n" + "* :cur: -- the current file, or (dyn :current-file)\n\n" + "* :dir: -- the directory containing the current file\n\n" + "* :name: -- the name component of path, with extension if given\n\n" + "* :native: -- the extension used to load natives, .so or .dll\n\n" + "* :sys: -- the system path, or (dyn :syspath)") { janet_fixarity(argc, 2); const char *input = janet_getcstring(argv, 0); const char *template = janet_getcstring(argv, 1); @@ -266,11 +284,13 @@ static Janet janet_core_expand_path(int32_t argc, Janet *argv) { return janet_wrap_buffer(out); } -static Janet janet_core_dyn(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_dyn, + "(dyn key &opt default)", + "Get a dynamic binding. Returns the default value (or nil) if no binding found.") { janet_arity(argc, 1, 2); Janet value; - if (janet_vm_fiber->env) { - value = janet_table_get(janet_vm_fiber->env, argv[0]); + if (janet_vm.fiber->env) { + value = janet_table_get(janet_vm.fiber->env, argv[0]); } else { value = janet_wrap_nil(); } @@ -280,16 +300,24 @@ static Janet janet_core_dyn(int32_t argc, Janet *argv) { return value; } -static Janet janet_core_setdyn(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_setdyn, + "(setdyn key value)", + "Set a dynamic binding. Returns value.") { janet_fixarity(argc, 2); - if (!janet_vm_fiber->env) { - janet_vm_fiber->env = janet_table(2); + if (!janet_vm.fiber->env) { + janet_vm.fiber->env = janet_table(2); } - janet_table_put(janet_vm_fiber->env, argv[0], argv[1]); + janet_table_put(janet_vm.fiber->env, argv[0], argv[1]); return argv[1]; } -static Janet janet_core_native(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_native, + "(native path &opt env)", + "Load a native module from the given path. The path " + "must be an absolute or relative path on the file system, and is " + "usually a .so file on Unix systems, and a .dll file on Windows. " + "Returns an environment table that contains functions and other values " + "from the native module.") { JanetModule init; janet_arity(argc, 1, 2); const uint8_t *path = janet_getstring(argv, 0); @@ -309,67 +337,104 @@ static Janet janet_core_native(int32_t argc, Janet *argv) { return janet_wrap_table(env); } -static Janet janet_core_describe(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_describe, + "(describe x)", + "Returns a string that is a human-readable description of a value x.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_description_b(b, argv[i]); return janet_stringv(b->data, b->count); } -static Janet janet_core_string(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_string, + "(string & xs)", + "Creates a string by concatenating the elements of `xs` together. If an " + "element is not a byte sequence, it is converted to bytes via `describe`. " + "Returns the new string.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_to_string_b(b, argv[i]); return janet_stringv(b->data, b->count); } -static Janet janet_core_symbol(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_symbol, + "(symbol & xs)", + "Creates a symbol by concatenating the elements of `xs` together. If an " + "element is not a byte sequence, it is converted to bytes via `describe`. " + "Returns the new symbol.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_to_string_b(b, argv[i]); return janet_symbolv(b->data, b->count); } -static Janet janet_core_keyword(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_keyword, + "(keyword & xs)", + "Creates a keyword by concatenating the elements of `xs` together. If an " + "element is not a byte sequence, it is converted to bytes via `describe`. " + "Returns the new keyword.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_to_string_b(b, argv[i]); return janet_keywordv(b->data, b->count); } -static Janet janet_core_buffer(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_buffer, + "(buffer & xs)", + "Creates a buffer by concatenating the elements of `xs` together. If an " + "element is not a byte sequence, it is converted to bytes via `describe`. " + "Returns the new buffer.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_to_string_b(b, argv[i]); return janet_wrap_buffer(b); } -static Janet janet_core_is_abstract(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_is_abstract, + "(abstract? x)", + "Check if x is an abstract type.") { janet_fixarity(argc, 1); return janet_wrap_boolean(janet_checktype(argv[0], JANET_ABSTRACT)); } -static Janet janet_core_scannumber(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_scannumber, + "(scan-number str &opt base)", + "Parse a number from a byte sequence and return that number, either an integer " + "or a real. The number " + "must be in the same format as numbers in janet source code. Will return nil " + "on an invalid number. Optionally provide a base - if a base is provided, no " + "radix specifier is expected at the beginning of the number.") { double number; - janet_fixarity(argc, 1); + janet_arity(argc, 1, 2); JanetByteView view = janet_getbytes(argv, 0); - if (janet_scan_number(view.bytes, view.len, &number)) + int32_t base = janet_optinteger(argv, argc, 1, 0); + int valid = base == 0 || (base >= 2 && base <= 36); + if (!valid) { + janet_panicf("expected base between 2 and 36, got %d", base); + } + if (janet_scan_number_base(view.bytes, view.len, base, &number)) return janet_wrap_nil(); return janet_wrap_number(number); } -static Janet janet_core_tuple(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_tuple, + "(tuple & items)", + "Creates a new tuple that contains items. Returns the new tuple.") { return janet_wrap_tuple(janet_tuple_n(argv, argc)); } -static Janet janet_core_array(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_array, + "(array & items)", + "Create a new array that contains items. Returns the new array.") { JanetArray *array = janet_array(argc); array->count = argc; safe_memcpy(array->data, argv, argc * sizeof(Janet)); return janet_wrap_array(array); } -static Janet janet_core_slice(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_slice, + "(slice x &opt start end)", + "Extract a sub-range of an indexed data structure or byte sequence.") { JanetRange range; JanetByteView bview; JanetView iview; @@ -384,7 +449,12 @@ static Janet janet_core_slice(int32_t argc, Janet *argv) { } } -static Janet janet_core_table(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_table, + "(table & kvs)", + "Creates a new table from a variadic number of keys and values. " + "kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has " + "an odd number of elements, an error will be thrown. Returns the " + "new table.") { int32_t i; if (argc & 1) janet_panic("expected even number of arguments"); @@ -395,7 +465,9 @@ static Janet janet_core_table(int32_t argc, Janet *argv) { return janet_wrap_table(table); } -static Janet janet_core_getproto(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_getproto, + "(getproto x)", + "Get the prototype of a table or struct. Will return nil if `x` has no prototype.") { janet_fixarity(argc, 1); if (janet_checktype(argv[0], JANET_TABLE)) { JanetTable *t = janet_unwrap_table(argv[0]); @@ -412,10 +484,16 @@ static Janet janet_core_getproto(int32_t argc, Janet *argv) { janet_panicf("expected struct|table, got %v", argv[0]); } -static Janet janet_core_struct(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_struct, + "(struct & kvs)", + "Create a new struct from a sequence of key value pairs. " + "kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has " + "an odd number of elements, an error will be thrown. Returns the " + "new struct.") { int32_t i; - if (argc & 1) + if (argc & 1) { janet_panic("expected even number of arguments"); + } JanetKV *st = janet_struct_begin(argc >> 1); for (i = 0; i < argc; i += 2) { janet_struct_put(st, argv[i], argv[i + 1]); @@ -423,20 +501,30 @@ static Janet janet_core_struct(int32_t argc, Janet *argv) { return janet_wrap_struct(janet_struct_end(st)); } -static Janet janet_core_gensym(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_gensym, + "(gensym)", + "Returns a new symbol that is unique across the runtime. This means it " + "will not collide with any already created symbols during compilation, so " + "it can be used in macros to generate automatic bindings.") { (void) argv; janet_fixarity(argc, 0); return janet_wrap_symbol(janet_symbol_gen()); } -static Janet janet_core_gccollect(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_gccollect, + "(gccollect)", + "Run garbage collection. You should probably not call this manually.") { (void) argv; (void) argc; janet_collect(); return janet_wrap_nil(); } -static Janet janet_core_gcsetinterval(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_gcsetinterval, + "(gcsetinterval interval)", + "Set an integer number of bytes to allocate before running garbage collection. " + "Low values for interval will be slower but use less memory. " + "High values will be faster but use more memory.") { janet_fixarity(argc, 1); size_t s = janet_getsize(argv, 0); /* limit interval to 48 bits */ @@ -445,17 +533,37 @@ static Janet janet_core_gcsetinterval(int32_t argc, Janet *argv) { janet_panic("interval too large"); } #endif - janet_vm_gc_interval = s; + janet_vm.gc_interval = s; return janet_wrap_nil(); } -static Janet janet_core_gcinterval(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_gcinterval, + "(gcinterval)", + "Returns the integer number of bytes to allocate before running an iteration " + "of garbage collection.") { (void) argv; janet_fixarity(argc, 0); - return janet_wrap_number((double) janet_vm_gc_interval); + return janet_wrap_number((double) janet_vm.gc_interval); } -static Janet janet_core_type(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_type, + "(type x)", + "Returns the type of `x` as a keyword. `x` is one of:\n\n" + "* :nil\n\n" + "* :boolean\n\n" + "* :number\n\n" + "* :array\n\n" + "* :tuple\n\n" + "* :table\n\n" + "* :struct\n\n" + "* :string\n\n" + "* :buffer\n\n" + "* :symbol\n\n" + "* :keyword\n\n" + "* :function\n\n" + "* :cfunction\n\n" + "* :fiber\n\n" + "or another keyword for an abstract type.") { janet_fixarity(argc, 1); JanetType t = janet_type(argv[0]); if (t == JANET_ABSTRACT) { @@ -465,12 +573,21 @@ static Janet janet_core_type(int32_t argc, Janet *argv) { } } -static Janet janet_core_hash(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_hash, + "(hash value)", + "Gets a hash for any value. The hash is an integer can be used " + "as a cheap hash function for all values. If two values are strictly equal, " + "then they will have the same hash value.") { janet_fixarity(argc, 1); return janet_wrap_number(janet_hash(argv[0])); } -static Janet janet_core_getline(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_getline, + "(getline &opt prompt buf env)", + "Reads a line of input into a buffer, including the newline character, using a prompt. " + "An optional environment table can be provided for auto-complete. " + "Returns the modified buffer. " + "Use this function to implement a simple interface for a terminal program.") { FILE *in = janet_dynfile("in", stdin); FILE *out = janet_dynfile("out", stdout); janet_arity(argc, 0, 3); @@ -495,21 +612,27 @@ static Janet janet_core_getline(int32_t argc, Janet *argv) { return janet_wrap_buffer(buf); } -static Janet janet_core_trace(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_trace, + "(trace func)", + "Enable tracing on a function. Returns the function.") { janet_fixarity(argc, 1); JanetFunction *func = janet_getfunction(argv, 0); func->gc.flags |= JANET_FUNCFLAG_TRACE; return argv[0]; } -static Janet janet_core_untrace(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_untrace, + "(untrace func)", + "Disables tracing on a function. Returns the function.") { janet_fixarity(argc, 1); JanetFunction *func = janet_getfunction(argv, 0); func->gc.flags &= ~JANET_FUNCFLAG_TRACE; return argv[0]; } -static Janet janet_core_check_int(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_check_int, + "(int? x)", + "Check if x can be exactly represented as a 32 bit signed two's complement integer.") { janet_fixarity(argc, 1); if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false; double num = janet_unwrap_number(argv[0]); @@ -518,7 +641,9 @@ ret_false: return janet_wrap_false(); } -static Janet janet_core_check_nat(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_check_nat, + "(nat? x)", + "Check if x can be exactly represented as a non-negative 32 bit signed two's complement integer.") { janet_fixarity(argc, 1); if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false; double num = janet_unwrap_number(argv[0]); @@ -527,7 +652,9 @@ ret_false: return janet_wrap_false(); } -static Janet janet_core_signal(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_core_signal, + "(signal what x)", + "Raise a signal with payload x. ") { janet_arity(argc, 1, 2); int sig; if (janet_checkint(argv[0])) { @@ -552,210 +679,6 @@ static Janet janet_core_signal(int32_t argc, Janet *argv) { janet_signalv(sig, payload); } -static const JanetReg corelib_cfuns[] = { - { - "native", janet_core_native, - JDOC("(native path &opt env)\n\n" - "Load a native module from the given path. The path " - "must be an absolute or relative path on the file system, and is " - "usually a .so file on Unix systems, and a .dll file on Windows. " - "Returns an environment table that contains functions and other values " - "from the native module.") - }, - { - "describe", janet_core_describe, - JDOC("(describe x)\n\n" - "Returns a string that is a human-readable description of a value x.") - }, - { - "string", janet_core_string, - JDOC("(string & xs)\n\n" - "Creates a string by concatenating the elements of `xs` together. If an " - "element is not a byte sequence, it is converted to bytes via `describe`. " - "Returns the new string.") - }, - { - "symbol", janet_core_symbol, - JDOC("(symbol & xs)\n\n" - "Creates a symbol by concatenating the elements of `xs` together. If an " - "element is not a byte sequence, it is converted to bytes via `describe`. " - "Returns the new symbol.") - }, - { - "keyword", janet_core_keyword, - JDOC("(keyword & xs)\n\n" - "Creates a keyword by concatenating the elements of `xs` together. If an " - "element is not a byte sequence, it is converted to bytes via `describe`. " - "Returns the new keyword.") - }, - { - "buffer", janet_core_buffer, - JDOC("(buffer & xs)\n\n" - "Creates a buffer by concatenating the elements of `xs` together. If an " - "element is not a byte sequence, it is converted to bytes via `describe`. " - "Returns the new buffer.") - }, - { - "abstract?", janet_core_is_abstract, - JDOC("(abstract? x)\n\n" - "Check if x is an abstract type.") - }, - { - "table", janet_core_table, - JDOC("(table & kvs)\n\n" - "Creates a new table from a variadic number of keys and values. " - "kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has " - "an odd number of elements, an error will be thrown. Returns the " - "new table.") - }, - { - "array", janet_core_array, - JDOC("(array & items)\n\n" - "Create a new array that contains items. Returns the new array.") - }, - { - "scan-number", janet_core_scannumber, - JDOC("(scan-number str)\n\n" - "Parse a number from a byte sequence an return that number, either and integer " - "or a real. The number " - "must be in the same format as numbers in janet source code. Will return nil " - "on an invalid number.") - }, - { - "tuple", janet_core_tuple, - JDOC("(tuple & items)\n\n" - "Creates a new tuple that contains items. Returns the new tuple.") - }, - { - "struct", janet_core_struct, - JDOC("(struct & kvs)\n\n" - "Create a new struct from a sequence of key value pairs. " - "kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has " - "an odd number of elements, an error will be thrown. Returns the " - "new struct.") - }, - { - "gensym", janet_core_gensym, - JDOC("(gensym)\n\n" - "Returns a new symbol that is unique across the runtime. This means it " - "will not collide with any already created symbols during compilation, so " - "it can be used in macros to generate automatic bindings.") - }, - { - "gccollect", janet_core_gccollect, - JDOC("(gccollect)\n\n" - "Run garbage collection. You should probably not call this manually.") - }, - { - "gcsetinterval", janet_core_gcsetinterval, - JDOC("(gcsetinterval interval)\n\n" - "Set an integer number of bytes to allocate before running garbage collection. " - "Low values for interval will be slower but use less memory. " - "High values will be faster but use more memory.") - }, - { - "gcinterval", janet_core_gcinterval, - JDOC("(gcinterval)\n\n" - "Returns the integer number of bytes to allocate before running an iteration " - "of garbage collection.") - }, - { - "type", janet_core_type, - JDOC("(type x)\n\n" - "Returns the type of `x` as a keyword. `x` is one of:\n\n" - "* :nil\n\n" - "* :boolean\n\n" - "* :number\n\n" - "* :array\n\n" - "* :tuple\n\n" - "* :table\n\n" - "* :struct\n\n" - "* :string\n\n" - "* :buffer\n\n" - "* :symbol\n\n" - "* :keyword\n\n" - "* :function\n\n" - "* :cfunction\n\n" - "* :fiber\n\n" - "or another keyword for an abstract type.") - }, - { - "hash", janet_core_hash, - JDOC("(hash value)\n\n" - "Gets a hash for any value. The hash is an integer can be used " - "as a cheap hash function for all values. If two values are strictly equal, " - "then they will have the same hash value.") - }, - { - "getline", janet_core_getline, - JDOC("(getline &opt prompt buf env)\n\n" - "Reads a line of input into a buffer, including the newline character, using a prompt. " - "An optional environment table can be provided for auto-complete. " - "Returns the modified buffer. " - "Use this function to implement a simple interface for a terminal program.") - }, - { - "dyn", janet_core_dyn, - JDOC("(dyn key &opt default)\n\n" - "Get a dynamic binding. Returns the default value (or nil) if no binding found.") - }, - { - "setdyn", janet_core_setdyn, - JDOC("(setdyn key value)\n\n" - "Set a dynamic binding. Returns value.") - }, - { - "trace", janet_core_trace, - JDOC("(trace func)\n\n" - "Enable tracing on a function. Returns the function.") - }, - { - "untrace", janet_core_untrace, - JDOC("(untrace func)\n\n" - "Disables tracing on a function. Returns the function.") - }, - { - "module/expand-path", janet_core_expand_path, - JDOC("(module/expand-path path template)\n\n" - "Expands a path template as found in `module/paths` for `module/find`. " - "This takes in a path (the argument to require) and a template string, " - "to expand the path to a path that can be " - "used for importing files. The replacements are as follows:\n\n" - "* :all: -- the value of path verbatim\n\n" - "* :cur: -- the current file, or (dyn :current-file)\n\n" - "* :dir: -- the directory containing the current file\n\n" - "* :name: -- the name component of path, with extension if given\n\n" - "* :native: -- the extension used to load natives, .so or .dll\n\n" - "* :sys: -- the system path, or (dyn :syspath)") - }, - { - "int?", janet_core_check_int, - JDOC("(int? x)\n\n" - "Check if x can be exactly represented as a 32 bit signed two's complement integer.") - }, - { - "nat?", janet_core_check_nat, - JDOC("(nat? x)\n\n" - "Check if x can be exactly represented as a non-negative 32 bit signed two's complement integer.") - }, - { - "slice", janet_core_slice, - JDOC("(slice x &opt start end)\n\n" - "Extract a sub-range of an indexed data structure or byte sequence.") - }, - { - "signal", janet_core_signal, - JDOC("(signal what x)\n\n" - "Raise a signal with payload x. ") - }, - { - "getproto", janet_core_getproto, - JDOC("(getproto x)\n\n" - "Get the prototype of a table or struct. Will return nil if `x` has no prototype.") - }, - {NULL, NULL, NULL} -}; - #ifdef JANET_BOOTSTRAP /* Utility for inline assembly */ @@ -1028,7 +951,39 @@ static const uint32_t cmp_asm[] = { */ static void janet_load_libs(JanetTable *env) { - janet_core_cfuns(env, NULL, corelib_cfuns); + JanetRegExt corelib_cfuns[] = { + JANET_CORE_REG("native", janet_core_native), + JANET_CORE_REG("describe", janet_core_describe), + JANET_CORE_REG("string", janet_core_string), + JANET_CORE_REG("symbol", janet_core_symbol), + JANET_CORE_REG("keyword", janet_core_keyword), + JANET_CORE_REG("buffer", janet_core_buffer), + JANET_CORE_REG("abstract?", janet_core_is_abstract), + JANET_CORE_REG("table", janet_core_table), + JANET_CORE_REG("array", janet_core_array), + JANET_CORE_REG("scan-number", janet_core_scannumber), + JANET_CORE_REG("tuple", janet_core_tuple), + JANET_CORE_REG("struct", janet_core_struct), + JANET_CORE_REG("gensym", janet_core_gensym), + JANET_CORE_REG("gccollect", janet_core_gccollect), + JANET_CORE_REG("gcsetinterval", janet_core_gcsetinterval), + JANET_CORE_REG("gcinterval", janet_core_gcinterval), + JANET_CORE_REG("type", janet_core_type), + JANET_CORE_REG("hash", janet_core_hash), + JANET_CORE_REG("getline", janet_core_getline), + JANET_CORE_REG("dyn", janet_core_dyn), + JANET_CORE_REG("setdyn", janet_core_setdyn), + JANET_CORE_REG("trace", janet_core_trace), + JANET_CORE_REG("untrace", janet_core_untrace), + JANET_CORE_REG("module/expand-path", janet_core_expand_path), + JANET_CORE_REG("int?", janet_core_check_int), + JANET_CORE_REG("nat?", janet_core_check_nat), + JANET_CORE_REG("slice", janet_core_slice), + JANET_CORE_REG("signal", janet_core_signal), + JANET_CORE_REG("getproto", janet_core_getproto), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, corelib_cfuns); janet_lib_io(env); janet_lib_math(env); janet_lib_array(env); @@ -1052,9 +1007,6 @@ static void janet_load_libs(JanetTable *env) { #ifdef JANET_INT_TYPES janet_lib_inttypes(env); #endif -#ifdef JANET_THREADS - janet_lib_thread(env); -#endif #ifdef JANET_EV janet_lib_ev(env); #endif @@ -1238,8 +1190,8 @@ JanetTable *janet_core_env(JanetTable *replacements) { JanetTable *janet_core_env(JanetTable *replacements) { /* Memoize core env, ignoring replacements the second time around. */ - if (NULL != janet_vm_core_env) { - return janet_vm_core_env; + if (NULL != janet_vm.core_env) { + return janet_vm.core_env; } JanetTable *dict = janet_core_lookup_table(replacements); @@ -1255,7 +1207,7 @@ JanetTable *janet_core_env(JanetTable *replacements) { /* Memoize */ janet_gcroot(marsh_out); JanetTable *env = janet_unwrap_table(marsh_out); - janet_vm_core_env = env; + janet_vm.core_env = env; /* Invert image dict manually here. We can't do this in boot.janet as it * breaks deterministic builds */ @@ -1287,9 +1239,7 @@ JanetTable *janet_core_lookup_table(JanetTable *replacements) { JanetKV kv = replacements->data[i]; if (!janet_checktype(kv.key, JANET_NIL)) { janet_table_put(dict, kv.key, kv.value); - if (janet_checktype(kv.value, JANET_CFUNCTION)) { - janet_table_put(janet_vm_registry, kv.value, kv.key); - } + /* Add replacement functions to registry? */ } } } diff --git a/src/core/debug.c b/src/core/debug.c index b278b0eb..81676775 100644 --- a/src/core/debug.c +++ b/src/core/debug.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -55,7 +55,7 @@ void janet_debug_find( JanetFuncDef **def_out, int32_t *pc_out, const uint8_t *source, int32_t sourceLine, int32_t sourceColumn) { /* Scan the heap for right func def */ - JanetGCObject *current = janet_vm_blocks; + JanetGCObject *current = janet_vm.blocks; /* Keep track of the best source mapping we have seen so far */ int32_t besti = -1; int32_t best_line = -1; @@ -86,7 +86,7 @@ void janet_debug_find( } } } - current = current->next; + current = current->data.next; } if (best_def) { *def_out = best_def; @@ -118,6 +118,7 @@ void janet_stacktrace(JanetFiber *fiber, Janet err) { fiber = fibers[fi]; int32_t i = fiber->frame; while (i > 0) { + JanetCFunRegistry *reg = NULL; JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE); JanetFuncDef *def = NULL; i = frame->prevframe; @@ -144,11 +145,19 @@ void janet_stacktrace(JanetFiber *fiber, Janet err) { } else { JanetCFunction cfun = (JanetCFunction)(frame->pc); if (cfun) { - Janet name = janet_table_get(janet_vm_registry, janet_wrap_cfunction(cfun)); - if (!janet_checktype(name, JANET_NIL)) - janet_eprintf(" %s", (const char *)janet_to_string(name)); - else + reg = janet_registry_get(cfun); + if (NULL != reg && NULL != reg->name) { + if (reg->name_prefix) { + janet_eprintf(" %s/%s", reg->name_prefix, reg->name); + } else { + janet_eprintf(" %s", reg->name); + } + if (NULL != reg->source_file) { + janet_eprintf(" [%s]", reg->source_file); + } + } else { janet_eprintf(" "); + } } } if (frame->flags & JANET_STACKFRAME_TAILCALL) @@ -161,6 +170,11 @@ void janet_stacktrace(JanetFiber *fiber, Janet err) { } else { janet_eprintf(" pc=%d", off); } + } else if (NULL != reg) { + /* C Function */ + if (reg->source_line > 0) { + janet_eprintf(" on line %d", (long) reg->source_line); + } } janet_eprintf("\n"); } @@ -195,7 +209,13 @@ static void helper_find_fun(int32_t argc, Janet *argv, JanetFuncDef **def, int32 *bytecode_offset = offset; } -static Janet cfun_debug_break(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_break, + "(debug/break source line col)", + "Sets a breakpoint in `source` at a given line and column. " + "Will throw an error if the breakpoint location " + "cannot be found. For example\n\n" + "\t(debug/break \"core.janet\" 10 4)\n\n" + "will set a breakpoint at line 10, 4th column of the file core.janet.") { JanetFuncDef *def; int32_t offset; helper_find(argc, argv, &def, &offset); @@ -203,7 +223,11 @@ static Janet cfun_debug_break(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet cfun_debug_unbreak(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_unbreak, + "(debug/unbreak source line column)", + "Remove a breakpoint with a source key at a given line and column. " + "Will throw an error if the breakpoint " + "cannot be found.") { JanetFuncDef *def; int32_t offset = 0; helper_find(argc, argv, &def, &offset); @@ -211,7 +235,11 @@ static Janet cfun_debug_unbreak(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet cfun_debug_fbreak(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_fbreak, + "(debug/fbreak fun &opt pc)", + "Set a breakpoint in a given function. pc is an optional offset, which " + "is in bytecode instructions. fun is a function value. Will throw an error " + "if the offset is too large or negative.") { JanetFuncDef *def; int32_t offset = 0; helper_find_fun(argc, argv, &def, &offset); @@ -219,7 +247,9 @@ static Janet cfun_debug_fbreak(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet cfun_debug_unfbreak(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_unfbreak, + "(debug/unfbreak fun &opt pc)", + "Unset a breakpoint set with debug/fbreak.") { JanetFuncDef *def; int32_t offset; helper_find_fun(argc, argv, &def, &offset); @@ -227,7 +257,12 @@ static Janet cfun_debug_unfbreak(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet cfun_debug_lineage(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_lineage, + "(debug/lineage fib)", + "Returns an array of all child fibers from a root fiber. This function " + "is useful when a fiber signals or errors to an ancestor fiber. Using this function, " + "the fiber handling the error can see which fiber raised the signal. This function should " + "be used mostly for debugging purposes.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); JanetArray *array = janet_array(0); @@ -252,9 +287,20 @@ static Janet doframe(JanetStackFrame *frame) { } else { JanetCFunction cfun = (JanetCFunction)(frame->pc); if (cfun) { - Janet name = janet_table_get(janet_vm_registry, janet_wrap_cfunction(cfun)); - if (!janet_checktype(name, JANET_NIL)) { - janet_table_put(t, janet_ckeywordv("name"), name); + JanetCFunRegistry *reg = janet_registry_get(cfun); + if (NULL != reg->name) { + if (NULL != reg->name_prefix) { + janet_table_put(t, janet_ckeywordv("name"), janet_wrap_string(janet_formatc("%s/%s", reg->name_prefix, reg->name))); + } else { + janet_table_put(t, janet_ckeywordv("name"), janet_cstringv(reg->name)); + } + if (NULL != reg->source_file) { + janet_table_put(t, janet_ckeywordv("source"), janet_cstringv(reg->source_file)); + } + if (reg->source_line > 0) { + janet_table_put(t, janet_ckeywordv("source-line"), janet_wrap_integer(reg->source_line)); + janet_table_put(t, janet_ckeywordv("source-column"), janet_wrap_integer(1)); + } } } janet_table_put(t, janet_ckeywordv("c"), janet_wrap_true()); @@ -284,7 +330,21 @@ static Janet doframe(JanetStackFrame *frame) { return janet_wrap_table(t); } -static Janet cfun_debug_stack(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_stack, + "(debug/stack fib)", + "Gets information about the stack as an array of tables. Each table " + "in the array contains information about a stack frame. The top-most, current " + "stack frame is the first table in the array, and the bottom-most stack frame " + "is the last value. Each stack frame contains some of the following attributes:\n\n" + "* :c - true if the stack frame is a c function invocation\n\n" + "* :column - the current source column of the stack frame\n\n" + "* :function - the function that the stack frame represents\n\n" + "* :line - the current source line of the stack frame\n\n" + "* :name - the human-friendly name of the function\n\n" + "* :pc - integer indicating the location of the program counter\n\n" + "* :source - string with the file path or other identifier for the source code\n\n" + "* :slots - array of all values in each slot\n\n" + "* :tail - boolean indicating a tail call") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); JanetArray *array = janet_array(0); @@ -300,7 +360,11 @@ static Janet cfun_debug_stack(int32_t argc, Janet *argv) { return janet_wrap_array(array); } -static Janet cfun_debug_stacktrace(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_stacktrace, + "(debug/stacktrace fiber &opt err)", + "Prints a nice looking stacktrace for a fiber. Can optionally provide " + "an error value to print the stack trace with. If `err` is nil or not " + "provided, will skip the error line. Returns the fiber.") { janet_arity(argc, 1, 2); JanetFiber *fiber = janet_getfiber(argv, 0); Janet x = argc == 1 ? janet_wrap_nil() : argv[1]; @@ -308,7 +372,11 @@ static Janet cfun_debug_stacktrace(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_debug_argstack(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_argstack, + "(debug/arg-stack fiber)", + "Gets all values currently on the fiber's argument stack. Normally, " + "this should be empty unless the fiber signals while pushing arguments " + "to make a function call. Returns a new array.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); JanetArray *array = janet_array(fiber->stacktop - fiber->stackstart); @@ -317,7 +385,11 @@ static Janet cfun_debug_argstack(int32_t argc, Janet *argv) { return janet_wrap_array(array); } -static Janet cfun_debug_step(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_debug_step, + "(debug/step fiber &opt x)", + "Run a fiber for one virtual instruction of the Janet machine. Can optionally " + "pass in a value that will be passed as the resuming value. Returns the signal value, " + "which will usually be nil, as breakpoints raise nil signals.") { janet_arity(argc, 1, 2); JanetFiber *fiber = janet_getfiber(argv, 0); Janet out = janet_wrap_nil(); @@ -325,85 +397,19 @@ static Janet cfun_debug_step(int32_t argc, Janet *argv) { return out; } -static const JanetReg debug_cfuns[] = { - { - "debug/break", cfun_debug_break, - JDOC("(debug/break source line col)\n\n" - "Sets a breakpoint in `source` at a given line and column. " - "Will throw an error if the breakpoint location " - "cannot be found. For example\n\n" - "\t(debug/break \"core.janet\" 10 4)\n\n" - "wil set a breakpoint at line 10, 4th column of the file core.janet.") - }, - { - "debug/unbreak", cfun_debug_unbreak, - JDOC("(debug/unbreak source line column)\n\n" - "Remove a breakpoint with a source key at a given line and column. " - "Will throw an error if the breakpoint " - "cannot be found.") - }, - { - "debug/fbreak", cfun_debug_fbreak, - JDOC("(debug/fbreak fun &opt pc)\n\n" - "Set a breakpoint in a given function. pc is an optional offset, which " - "is in bytecode instructions. fun is a function value. Will throw an error " - "if the offset is too large or negative.") - }, - { - "debug/unfbreak", cfun_debug_unfbreak, - JDOC("(debug/unfbreak fun &opt pc)\n\n" - "Unset a breakpoint set with debug/fbreak.") - }, - { - "debug/arg-stack", cfun_debug_argstack, - JDOC("(debug/arg-stack fiber)\n\n" - "Gets all values currently on the fiber's argument stack. Normally, " - "this should be empty unless the fiber signals while pushing arguments " - "to make a function call. Returns a new array.") - }, - { - "debug/stack", cfun_debug_stack, - JDOC("(debug/stack fib)\n\n" - "Gets information about the stack as an array of tables. Each table " - "in the array contains information about a stack frame. The top-most, current " - "stack frame is the first table in the array, and the bottom-most stack frame " - "is the last value. Each stack frame contains some of the following attributes:\n\n" - "* :c - true if the stack frame is a c function invocation\n\n" - "* :column - the current source column of the stack frame\n\n" - "* :function - the function that the stack frame represents\n\n" - "* :line - the current source line of the stack frame\n\n" - "* :name - the human-friendly name of the function\n\n" - "* :pc - integer indicating the location of the program counter\n\n" - "* :source - string with the file path or other identifier for the source code\n\n" - "* :slots - array of all values in each slot\n\n" - "* :tail - boolean indicating a tail call") - }, - { - "debug/stacktrace", cfun_debug_stacktrace, - JDOC("(debug/stacktrace fiber &opt err)\n\n" - "Prints a nice looking stacktrace for a fiber. Can optionally provide " - "an error value to print the stack trace with. If `err` is nil or not " - "provided, will skipp the error line. Returns the fiber.") - }, - { - "debug/lineage", cfun_debug_lineage, - JDOC("(debug/lineage fib)\n\n" - "Returns an array of all child fibers from a root fiber. This function " - "is useful when a fiber signals or errors to an ancestor fiber. Using this function, " - "the fiber handling the error can see which fiber raised the signal. This function should " - "be used mostly for debugging purposes.") - }, - { - "debug/step", cfun_debug_step, - JDOC("(debug/step fiber &opt x)\n\n" - "Run a fiber for one virtual instruction of the Janet machine. Can optionally " - "pass in a value that will be passed as the resuming value. Returns the signal value, " - "which will usually be nil, as breakpoints raise nil signals.") - }, - {NULL, NULL, NULL} -}; - /* Module entry point */ void janet_lib_debug(JanetTable *env) { - janet_core_cfuns(env, NULL, debug_cfuns); + JanetRegExt debug_cfuns[] = { + JANET_CORE_REG("debug/break", cfun_debug_break), + JANET_CORE_REG("debug/unbreak", cfun_debug_unbreak), + JANET_CORE_REG("debug/fbreak", cfun_debug_fbreak), + JANET_CORE_REG("debug/unfbreak", cfun_debug_unfbreak), + JANET_CORE_REG("debug/arg-stack", cfun_debug_argstack), + JANET_CORE_REG("debug/stack", cfun_debug_stack), + JANET_CORE_REG("debug/stacktrace", cfun_debug_stacktrace), + JANET_CORE_REG("debug/lineage", cfun_debug_lineage), + JANET_CORE_REG("debug/step", cfun_debug_step), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, debug_cfuns); } diff --git a/src/core/emit.c b/src/core/emit.c index 236ad1e0..d3e2c15f 100644 --- a/src/core/emit.c +++ b/src/core/emit.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/emit.h b/src/core/emit.h index 5b9229b6..833bc755 100644 --- a/src/core/emit.h +++ b/src/core/emit.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/ev.c b/src/core/ev.c index ccd65010..89048b7e 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2021 Calvin Rose and contributors. +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -20,6 +20,7 @@ * IN THE SOFTWARE. */ + #ifndef JANET_AMALG #include "features.h" #include @@ -53,23 +54,21 @@ #include #include #endif +#ifdef JANET_EV_KQUEUE +#include +#endif #endif -/* Ring buffer for storing a list of fibers */ -typedef struct { - int32_t capacity; - int32_t head; - int32_t tail; - void *data; -} JanetQueue; - typedef struct { + JanetVM *thread; JanetFiber *fiber; uint32_t sched_id; enum { - JANET_CP_MODE_ITEM, + JANET_CP_MODE_READ, + JANET_CP_MODE_WRITE, JANET_CP_MODE_CHOICE_READ, - JANET_CP_MODE_CHOICE_WRITE + JANET_CP_MODE_CHOICE_WRITE, + JANET_CP_MODE_CLOSE } mode; } JanetChannelPending; @@ -78,8 +77,34 @@ typedef struct { JanetQueue read_pending; JanetQueue write_pending; int32_t limit; + int closed; + int is_threaded; + JanetOSMutex lock; } JanetChannel; +typedef struct { + JanetFiber *fiber; + Janet value; + JanetSignal sig; + uint32_t expected_sched_id; /* If the fiber has been rescheduled this loop, don't run first scheduling. */ +} JanetTask; + +/* Wrap return value by pairing it with the callback used to handle it + * in the main thread */ +typedef struct { + JanetEVGenericMessage msg; + JanetThreadedCallback cb; +} JanetSelfPipeEvent; + +/* Structure used to initialize threads in the thread pool + * (same head structure as self pipe event)*/ +typedef struct { + JanetEVGenericMessage msg; + JanetThreadedCallback cb; + JanetThreadedSubroutine subr; + JanetHandle write_pipe; +} JanetEVThreadInit; + #define JANET_MAX_Q_CAPACITY 0x7FFFFFF static void janet_q_init(JanetQueue *q) { @@ -135,38 +160,8 @@ static int janet_q_pop(JanetQueue *q, void *out, size_t itemsize) { return 0; } -/* New fibers to spawn or resume */ -typedef struct JanetTask JanetTask; -struct JanetTask { - JanetFiber *fiber; - Janet value; - JanetSignal sig; -}; - -/* Min priority queue of timestamps for timeouts. */ -typedef int64_t JanetTimestamp; -typedef struct JanetTimeout JanetTimeout; -struct JanetTimeout { - JanetTimestamp when; - JanetFiber *fiber; - JanetFiber *curr_fiber; - uint32_t sched_id; - int is_error; -}; - /* Forward declaration */ -static void janet_unlisten(JanetListenerState *state); - -/* Global data */ -JANET_THREAD_LOCAL size_t janet_vm_tq_count = 0; -JANET_THREAD_LOCAL size_t janet_vm_tq_capacity = 0; -JANET_THREAD_LOCAL JanetQueue janet_vm_spawn; -JANET_THREAD_LOCAL JanetTimeout *janet_vm_tq = NULL; -JANET_THREAD_LOCAL JanetRNG janet_vm_ev_rng; -JANET_THREAD_LOCAL JanetListenerState **janet_vm_listeners = NULL; -JANET_THREAD_LOCAL size_t janet_vm_listener_count = 0; -JANET_THREAD_LOCAL size_t janet_vm_listener_cap = 0; -JANET_THREAD_LOCAL size_t janet_vm_extra_listeners = 0; +static void janet_unlisten(JanetListenerState *state, int is_gc); /* Get current timestamp (millisecond precision) */ static JanetTimestamp ts_now(void); @@ -180,58 +175,58 @@ static JanetTimestamp ts_delta(JanetTimestamp ts, double delta) { /* Look at the next timeout value without * removing it. */ static int peek_timeout(JanetTimeout *out) { - if (janet_vm_tq_count == 0) return 0; - *out = janet_vm_tq[0]; + if (janet_vm.tq_count == 0) return 0; + *out = janet_vm.tq[0]; return 1; } /* Remove the next timeout from the priority queue */ static void pop_timeout(size_t index) { - if (janet_vm_tq_count <= index) return; - janet_vm_tq[index] = janet_vm_tq[--janet_vm_tq_count]; + if (janet_vm.tq_count <= index) return; + janet_vm.tq[index] = janet_vm.tq[--janet_vm.tq_count]; for (;;) { size_t left = (index << 1) + 1; size_t right = left + 1; size_t smallest = index; - if (left < janet_vm_tq_count && - (janet_vm_tq[left].when < janet_vm_tq[smallest].when)) + if (left < janet_vm.tq_count && + (janet_vm.tq[left].when < janet_vm.tq[smallest].when)) smallest = left; - if (right < janet_vm_tq_count && - (janet_vm_tq[right].when < janet_vm_tq[smallest].when)) + if (right < janet_vm.tq_count && + (janet_vm.tq[right].when < janet_vm.tq[smallest].when)) smallest = right; if (smallest == index) return; - JanetTimeout temp = janet_vm_tq[index]; - janet_vm_tq[index] = janet_vm_tq[smallest]; - janet_vm_tq[smallest] = temp; + JanetTimeout temp = janet_vm.tq[index]; + janet_vm.tq[index] = janet_vm.tq[smallest]; + janet_vm.tq[smallest] = temp; index = smallest; } } /* Add a timeout to the timeout min heap */ static void add_timeout(JanetTimeout to) { - size_t oldcount = janet_vm_tq_count; + size_t oldcount = janet_vm.tq_count; size_t newcount = oldcount + 1; - if (newcount > janet_vm_tq_capacity) { + if (newcount > janet_vm.tq_capacity) { size_t newcap = 2 * newcount; - JanetTimeout *tq = janet_realloc(janet_vm_tq, newcap * sizeof(JanetTimeout)); + JanetTimeout *tq = janet_realloc(janet_vm.tq, newcap * sizeof(JanetTimeout)); if (NULL == tq) { JANET_OUT_OF_MEMORY; } - janet_vm_tq = tq; - janet_vm_tq_capacity = newcap; + janet_vm.tq = tq; + janet_vm.tq_capacity = newcap; } /* Append */ - janet_vm_tq_count = (int32_t) newcount; - janet_vm_tq[oldcount] = to; + janet_vm.tq_count = (int32_t) newcount; + janet_vm.tq[oldcount] = to; /* Heapify */ size_t index = oldcount; while (index > 0) { size_t parent = (index - 1) >> 1; - if (janet_vm_tq[parent].when <= janet_vm_tq[index].when) break; + if (janet_vm.tq[parent].when <= janet_vm.tq[index].when) break; /* Swap */ - JanetTimeout tmp = janet_vm_tq[index]; - janet_vm_tq[index] = janet_vm_tq[parent]; - janet_vm_tq[parent] = tmp; + JanetTimeout tmp = janet_vm.tq[index]; + janet_vm.tq[index] = janet_vm.tq[parent]; + janet_vm.tq[parent] = tmp; /* Next */ index = parent; } @@ -239,10 +234,13 @@ static void add_timeout(JanetTimeout to) { /* Create a new event listener */ static JanetListenerState *janet_listen_impl(JanetStream *stream, JanetListener behavior, int mask, size_t size, void *user) { + if (stream->flags & JANET_STREAM_CLOSED) { + janet_panic("cannot listen on closed stream"); + } if (stream->_mask & mask) { janet_panic("cannot listen for duplicate event on stream"); } - if (janet_vm_root_fiber->waiting != NULL) { + if (janet_vm.root_fiber->waiting != NULL) { janet_panic("current fiber is already waiting for event"); } if (size < sizeof(JanetListenerState)) @@ -252,8 +250,8 @@ static JanetListenerState *janet_listen_impl(JanetStream *stream, JanetListener JANET_OUT_OF_MEMORY; } state->machine = behavior; - state->fiber = janet_vm_root_fiber; - janet_vm_root_fiber->waiting = state; + state->fiber = janet_vm.root_fiber; + janet_vm.root_fiber->waiting = state; state->stream = stream; state->_mask = mask; stream->_mask |= mask; @@ -261,17 +259,17 @@ static JanetListenerState *janet_listen_impl(JanetStream *stream, JanetListener stream->state = state; /* Keep track of a listener for GC purposes */ - int resize = janet_vm_listener_cap == janet_vm_listener_count; + int resize = janet_vm.listener_cap == janet_vm.listener_count; if (resize) { - size_t newcap = janet_vm_listener_count ? janet_vm_listener_cap * 2 : 16; - janet_vm_listeners = janet_realloc(janet_vm_listeners, newcap * sizeof(JanetListenerState *)); - if (NULL == janet_vm_listeners) { + size_t newcap = janet_vm.listener_count ? janet_vm.listener_cap * 2 : 16; + janet_vm.listeners = janet_realloc(janet_vm.listeners, newcap * sizeof(JanetListenerState *)); + if (NULL == janet_vm.listeners) { JANET_OUT_OF_MEMORY; } - janet_vm_listener_cap = newcap; + janet_vm.listener_cap = newcap; } - size_t index = janet_vm_listener_count++; - janet_vm_listeners[index] = state; + size_t index = janet_vm.listener_count++; + janet_vm.listeners[index] = state; state->_index = index; /* Emit INIT event for convenience */ @@ -282,7 +280,7 @@ static JanetListenerState *janet_listen_impl(JanetStream *stream, JanetListener /* Indicate we are no longer listening for an event. This * frees the memory of the state machine as well. */ -static void janet_unlisten_impl(JanetListenerState *state) { +static void janet_unlisten_impl(JanetListenerState *state, int is_gc) { state->machine(state, JANET_ASYNC_EVENT_DEINIT); /* Remove state machine from poll list */ JanetListenerState **iter = &(state->stream->state); @@ -293,14 +291,16 @@ static void janet_unlisten_impl(JanetListenerState *state) { /* Remove mask */ state->stream->_mask &= ~(state->_mask); /* Ensure fiber does not reference this state */ - JanetFiber *fiber = state->fiber; - if (NULL != fiber && fiber->waiting == state) { - fiber->waiting = NULL; + if (!is_gc) { + JanetFiber *fiber = state->fiber; + if (NULL != fiber && fiber->waiting == state) { + fiber->waiting = NULL; + } } /* Untrack a listener for gc purposes */ size_t index = state->_index; - janet_vm_listeners[index] = janet_vm_listeners[--janet_vm_listener_count]; - janet_vm_listeners[index]->_index = index; + janet_vm.listeners[index] = janet_vm.listeners[--janet_vm.listener_count]; + janet_vm.listeners[index]->_index = index; janet_free(state); } @@ -324,22 +324,16 @@ JanetStream *janet_stream(JanetHandle handle, uint32_t flags, const JanetMethod return stream; } -/* Called to clean up a stream */ -static int janet_stream_gc(void *p, size_t s) { - (void) s; - JanetStream *stream = (JanetStream *)p; - janet_stream_close(stream); - return 0; -} - /* Close a stream */ -void janet_stream_close(JanetStream *stream) { +static void janet_stream_close_impl(JanetStream *stream, int is_gc) { if (stream->flags & JANET_STREAM_CLOSED) return; JanetListenerState *state = stream->state; while (NULL != state) { - state->machine(state, JANET_ASYNC_EVENT_CLOSE); + if (!is_gc) { + state->machine(state, JANET_ASYNC_EVENT_CLOSE); + } JanetListenerState *next_state = state->_next; - janet_unlisten(state); + janet_unlisten(state, is_gc); state = next_state; } stream->state = NULL; @@ -353,11 +347,26 @@ void janet_stream_close(JanetStream *stream) { { CloseHandle(stream->handle); } + stream->handle = INVALID_HANDLE_VALUE; #else close(stream->handle); + stream->handle = -1; #endif } +void janet_stream_close(JanetStream *stream) { + janet_stream_close_impl(stream, 0); +} + + +/* Called to clean up a stream */ +static int janet_stream_gc(void *p, size_t s) { + (void) s; + JanetStream *stream = (JanetStream *)p; + janet_stream_close_impl(stream, 1); + return 0; +} + /* Mark a stream for GC */ static int janet_stream_mark(void *p, size_t s) { (void) s; @@ -455,11 +464,8 @@ const JanetAbstractType janet_stream_type = { /* Register a fiber to resume with value */ void janet_schedule_signal(JanetFiber *fiber, Janet value, JanetSignal sig) { - if (fiber->flags & JANET_FIBER_FLAG_SCHEDULED) return; - fiber->flags |= JANET_FIBER_FLAG_SCHEDULED; - fiber->sched_id++; - JanetTask t = { fiber, value, sig }; - janet_q_push(&janet_vm_spawn, &t, sizeof(t)); + JanetTask t = { fiber, value, sig, ++fiber->sched_id }; + janet_q_push(&janet_vm.spawn, &t, sizeof(t)); } void janet_cancel(JanetFiber *fiber, Janet value) { @@ -474,7 +480,7 @@ void janet_fiber_did_resume(JanetFiber *fiber) { /* Cancel any pending fibers */ if (fiber->waiting) { fiber->waiting->machine(fiber->waiting, JANET_ASYNC_EVENT_CANCEL); - janet_unlisten(fiber->waiting); + janet_unlisten(fiber->waiting, 0); } } @@ -482,34 +488,34 @@ void janet_fiber_did_resume(JanetFiber *fiber) { void janet_ev_mark(void) { /* Pending tasks */ - JanetTask *tasks = janet_vm_spawn.data; - if (janet_vm_spawn.head <= janet_vm_spawn.tail) { - for (int32_t i = janet_vm_spawn.head; i < janet_vm_spawn.tail; i++) { + JanetTask *tasks = janet_vm.spawn.data; + if (janet_vm.spawn.head <= janet_vm.spawn.tail) { + for (int32_t i = janet_vm.spawn.head; i < janet_vm.spawn.tail; i++) { janet_mark(janet_wrap_fiber(tasks[i].fiber)); janet_mark(tasks[i].value); } } else { - for (int32_t i = janet_vm_spawn.head; i < janet_vm_spawn.capacity; i++) { + for (int32_t i = janet_vm.spawn.head; i < janet_vm.spawn.capacity; i++) { janet_mark(janet_wrap_fiber(tasks[i].fiber)); janet_mark(tasks[i].value); } - for (int32_t i = 0; i < janet_vm_spawn.tail; i++) { + for (int32_t i = 0; i < janet_vm.spawn.tail; i++) { janet_mark(janet_wrap_fiber(tasks[i].fiber)); janet_mark(tasks[i].value); } } /* Pending timeouts */ - for (size_t i = 0; i < janet_vm_tq_count; i++) { - janet_mark(janet_wrap_fiber(janet_vm_tq[i].fiber)); - if (janet_vm_tq[i].curr_fiber != NULL) { - janet_mark(janet_wrap_fiber(janet_vm_tq[i].curr_fiber)); + for (size_t i = 0; i < janet_vm.tq_count; i++) { + janet_mark(janet_wrap_fiber(janet_vm.tq[i].fiber)); + if (janet_vm.tq[i].curr_fiber != NULL) { + janet_mark(janet_wrap_fiber(janet_vm.tq[i].curr_fiber)); } } /* Pending listeners */ - for (size_t i = 0; i < janet_vm_listener_count; i++) { - JanetListenerState *state = janet_vm_listeners[i]; + for (size_t i = 0; i < janet_vm.listener_count; i++) { + JanetListenerState *state = janet_vm.listeners[i]; if (NULL != state->fiber) { janet_mark(janet_wrap_fiber(state->fiber)); } @@ -519,47 +525,35 @@ void janet_ev_mark(void) { } static int janet_channel_push(JanetChannel *channel, Janet x, int mode); +static int janet_channel_pop(JanetChannel *channel, Janet *item, int is_choice); -static Janet make_supervisor_event(const char *name, JanetFiber *fiber) { +static Janet make_supervisor_event(const char *name, JanetFiber *fiber, int threaded) { Janet tup[2]; tup[0] = janet_ckeywordv(name); - tup[1] = janet_wrap_fiber(fiber); + tup[1] = threaded ? fiber->last_value : janet_wrap_fiber(fiber) ; return janet_wrap_tuple(janet_tuple_n(tup, 2)); } -/* Run a top level task */ -static void run_one(JanetFiber *fiber, Janet value, JanetSignal sigin) { - fiber->flags &= ~JANET_FIBER_FLAG_SCHEDULED; - Janet res; - JanetSignal sig = janet_continue_signal(fiber, value, &res, sigin); - JanetChannel *chan = (JanetChannel *)(fiber->supervisor_channel); - if (NULL == chan) { - if (sig != JANET_SIGNAL_EVENT && sig != JANET_SIGNAL_YIELD) { - janet_stacktrace(fiber, res); - } - } else if (sig == JANET_SIGNAL_OK || (fiber->flags & (1 << sig))) { - janet_channel_push(chan, make_supervisor_event(janet_signal_names[sig], fiber), 2); - } -} - /* Common init code */ void janet_ev_init_common(void) { - janet_q_init(&janet_vm_spawn); - janet_vm_listener_count = 0; - janet_vm_listener_cap = 0; - janet_vm_listeners = NULL; - janet_vm_tq = NULL; - janet_vm_tq_count = 0; - janet_vm_tq_capacity = 0; - janet_rng_seed(&janet_vm_ev_rng, 0); + janet_q_init(&janet_vm.spawn); + janet_vm.listener_count = 0; + janet_vm.listener_cap = 0; + janet_vm.listeners = NULL; + janet_vm.tq = NULL; + janet_vm.tq_count = 0; + janet_vm.tq_capacity = 0; + janet_table_init_raw(&janet_vm.threaded_abstracts, 0); + janet_rng_seed(&janet_vm.ev_rng, 0); } /* Common deinit code */ void janet_ev_deinit_common(void) { - janet_q_deinit(&janet_vm_spawn); - janet_free(janet_vm_tq); - janet_free(janet_vm_listeners); - janet_vm_listeners = NULL; + janet_q_deinit(&janet_vm.spawn); + janet_free(janet_vm.tq); + janet_free(janet_vm.listeners); + janet_vm.listeners = NULL; + janet_table_deinit(&janet_vm.threaded_abstracts); } /* Short hand to yield to event loop */ @@ -569,7 +563,7 @@ void janet_await(void) { /* Set timeout for the current root fiber */ void janet_addtimeout(double sec) { - JanetFiber *fiber = janet_vm_root_fiber; + JanetFiber *fiber = janet_vm.root_fiber; JanetTimeout to; to.when = ts_delta(ts_now(), sec); to.fiber = fiber; @@ -580,53 +574,105 @@ void janet_addtimeout(double sec) { } void janet_ev_inc_refcount(void) { - janet_vm_extra_listeners++; + janet_vm.extra_listeners++; } void janet_ev_dec_refcount(void) { - janet_vm_extra_listeners--; + janet_vm.extra_listeners--; } /* Channels */ #define JANET_MAX_CHANNEL_CAPACITY 0xFFFFFF -static void janet_chan_init(JanetChannel *chan, int32_t limit) { +static inline int janet_chan_is_threaded(JanetChannel *chan) { + return chan->is_threaded; +} + +static int janet_chan_pack(JanetChannel *chan, Janet *x) { + if (!janet_chan_is_threaded(chan)) return 0; + switch (janet_type(*x)) { + default: { + JanetBuffer *buf = janet_malloc(sizeof(JanetBuffer)); + if (NULL == buf) { + JANET_OUT_OF_MEMORY; + } + janet_buffer_init(buf, 10); + janet_marshal(buf, *x, NULL, JANET_MARSHAL_UNSAFE); + *x = janet_wrap_buffer(buf); + return 0; + } + case JANET_NIL: + case JANET_NUMBER: + case JANET_POINTER: + case JANET_BOOLEAN: + case JANET_CFUNCTION: + return 0; + } +} + +static int janet_chan_unpack(JanetChannel *chan, Janet *x, int is_cleanup) { + if (!janet_chan_is_threaded(chan)) return 0; + switch (janet_type(*x)) { + default: + return 1; + case JANET_BUFFER: { + JanetBuffer *buf = janet_unwrap_buffer(*x); + int flags = is_cleanup ? JANET_MARSHAL_UNSAFE : (JANET_MARSHAL_UNSAFE | JANET_MARSHAL_DECREF); + *x = janet_unmarshal(buf->data, buf->count, flags, NULL, NULL); + janet_buffer_deinit(buf); + janet_free(buf); + return 0; + } + case JANET_NIL: + case JANET_NUMBER: + case JANET_POINTER: + case JANET_BOOLEAN: + case JANET_CFUNCTION: + return 0; + } +} + +static void janet_chan_init(JanetChannel *chan, int32_t limit, int threaded) { chan->limit = limit; + chan->closed = 0; + chan->is_threaded = threaded; janet_q_init(&chan->items); janet_q_init(&chan->read_pending); janet_q_init(&chan->write_pending); + janet_os_mutex_init(&chan->lock); } static void janet_chan_deinit(JanetChannel *chan) { janet_q_deinit(&chan->read_pending); janet_q_deinit(&chan->write_pending); + if (janet_chan_is_threaded(chan)) { + Janet item; + while (!janet_q_pop(&chan->items, &item, sizeof(item))) { + janet_chan_unpack(chan, &item, 1); + } + } janet_q_deinit(&chan->items); + janet_os_mutex_deinit(&chan->lock); +} + +static void janet_chan_lock(JanetChannel *chan) { + if (!janet_chan_is_threaded(chan)) return; + janet_os_mutex_lock(&chan->lock); +} + +static void janet_chan_unlock(JanetChannel *chan) { + if (!janet_chan_is_threaded(chan)) return; + janet_os_mutex_unlock(&chan->lock); } /* * Janet Channel abstract type */ -static int janet_chanat_mark(void *p, size_t s); -static int janet_chanat_gc(void *p, size_t s); -static Janet janet_chanat_next(void *p, Janet key); -static int janet_chanat_get(void *p, Janet key, Janet *out); - -static const JanetAbstractType ChannelAT = { - "core/channel", - janet_chanat_gc, - janet_chanat_mark, - janet_chanat_get, - NULL, /* put */ - NULL, /* marshal */ - NULL, /* unmarshal */ - NULL, /* tostring */ - NULL, /* compare */ - NULL, /* hash */ - janet_chanat_next, - JANET_ATEND_NEXT -}; +static Janet janet_wrap_channel(JanetChannel *channel) { + return janet_wrap_abstract(channel); +} static int janet_chanat_gc(void *p, size_t s) { (void) s; @@ -670,99 +716,256 @@ static int janet_chanat_mark(void *p, size_t s) { static Janet make_write_result(JanetChannel *channel) { Janet *tup = janet_tuple_begin(2); tup[0] = janet_ckeywordv("give"); - tup[1] = janet_wrap_abstract(channel); + tup[1] = janet_wrap_channel(channel); return janet_wrap_tuple(janet_tuple_end(tup)); } static Janet make_read_result(JanetChannel *channel, Janet x) { Janet *tup = janet_tuple_begin(3); tup[0] = janet_ckeywordv("take"); - tup[1] = janet_wrap_abstract(channel); + tup[1] = janet_wrap_channel(channel); tup[2] = x; return janet_wrap_tuple(janet_tuple_end(tup)); } +static Janet make_close_result(JanetChannel *channel) { + Janet *tup = janet_tuple_begin(2); + tup[0] = janet_ckeywordv("close"); + tup[1] = janet_wrap_channel(channel); + return janet_wrap_tuple(janet_tuple_end(tup)); +} + +/* Callback to use for scheduling a fiber from another thread. */ +static void janet_thread_chan_cb(JanetEVGenericMessage msg) { + uint32_t sched_id = (uint32_t) msg.argi; + JanetFiber *fiber = msg.fiber; + int mode = msg.tag; + JanetChannel *channel = (JanetChannel *) msg.argp; + Janet x = msg.argj; + janet_ev_dec_refcount(); + if (fiber->sched_id == sched_id) { + if (mode == JANET_CP_MODE_CHOICE_READ) { + janet_assert(!janet_chan_unpack(channel, &x, 0), "packing error"); + janet_schedule(fiber, make_read_result(channel, x)); + } else if (mode == JANET_CP_MODE_CHOICE_WRITE) { + janet_schedule(fiber, make_write_result(channel)); + } else if (mode == JANET_CP_MODE_READ) { + janet_assert(!janet_chan_unpack(channel, &x, 0), "packing error"); + janet_schedule(fiber, x); + } else if (mode == JANET_CP_MODE_WRITE) { + janet_schedule(fiber, janet_wrap_channel(channel)); + } else { /* (mode == JANET_CP_MODE_CLOSE) */ + janet_schedule(fiber, janet_wrap_nil()); + } + } else if (mode != JANET_CP_MODE_CLOSE) { + /* Fiber has already been cancelled or resumed. */ + /* Resend event to another waiting thread, depending on mode */ + int is_read = (mode == JANET_CP_MODE_CHOICE_READ) || (mode == JANET_CP_MODE_READ); + if (is_read) { + JanetChannelPending reader; + janet_chan_lock(channel); + if (!janet_q_pop(&channel->read_pending, &reader, sizeof(reader))) { + JanetVM *vm = reader.thread; + JanetEVGenericMessage msg; + msg.tag = reader.mode; + msg.fiber = reader.fiber; + msg.argi = (int32_t) reader.sched_id; + msg.argp = channel; + msg.argj = x; + janet_ev_post_event(vm, janet_thread_chan_cb, msg); + } + janet_chan_unlock(channel); + } else { + JanetChannelPending writer; + janet_chan_lock(channel); + if (!janet_q_pop(&channel->write_pending, &writer, sizeof(writer))) { + JanetVM *vm = writer.thread; + JanetEVGenericMessage msg; + msg.tag = writer.mode; + msg.fiber = writer.fiber; + msg.argi = (int32_t) writer.sched_id; + msg.argp = channel; + msg.argj = janet_wrap_nil(); + janet_ev_post_event(vm, janet_thread_chan_cb, msg); + } + janet_chan_unlock(channel); + } + } +} + /* Push a value to a channel, and return 1 if channel should block, zero otherwise. - * If the push would block, will add to the write_pending queue in the channel. */ + * If the push would block, will add to the write_pending queue in the channel. + * Handles both threaded and unthreaded channels. */ static int janet_channel_push(JanetChannel *channel, Janet x, int mode) { JanetChannelPending reader; int is_empty; - do { + if (janet_chan_pack(channel, &x)) { + janet_panicf("failed to pack value for channel: %v", x); + } + janet_chan_lock(channel); + if (channel->closed) { + janet_chan_unlock(channel); + janet_panic("cannot write to closed channel"); + } + int is_threaded = janet_chan_is_threaded(channel); + if (is_threaded) { + /* don't dereference fiber from another thread */ is_empty = janet_q_pop(&channel->read_pending, &reader, sizeof(reader)); - } while (!is_empty && (reader.sched_id != reader.fiber->sched_id)); + } else { + do { + is_empty = janet_q_pop(&channel->read_pending, &reader, sizeof(reader)); + } while (!is_empty && (reader.sched_id != reader.fiber->sched_id)); + } if (is_empty) { /* No pending reader */ if (janet_q_push(&channel->items, &x, sizeof(Janet))) { + janet_chan_unlock(channel); janet_panicf("channel overflow: %v", x); } else if (janet_q_count(&channel->items) > channel->limit) { /* No root fiber, we are in completion on a root fiber. Don't block. */ - if (mode == 2) return 0; + if (mode == 2) { + janet_chan_unlock(channel); + return 0; + } /* Pushed successfully, but should block. */ JanetChannelPending pending; - pending.fiber = janet_vm_root_fiber, - pending.sched_id = janet_vm_root_fiber->sched_id, - pending.mode = mode ? JANET_CP_MODE_CHOICE_WRITE : JANET_CP_MODE_ITEM; + pending.thread = &janet_vm; + pending.fiber = janet_vm.root_fiber, + pending.sched_id = janet_vm.root_fiber->sched_id, + pending.mode = mode ? JANET_CP_MODE_CHOICE_WRITE : JANET_CP_MODE_WRITE; janet_q_push(&channel->write_pending, &pending, sizeof(pending)); + janet_chan_unlock(channel); + janet_ev_inc_refcount(); + if (is_threaded) { + janet_gcroot(janet_wrap_fiber(pending.fiber)); + } return 1; } } else { /* Pending reader */ - if (reader.mode == JANET_CP_MODE_CHOICE_READ) { - janet_schedule(reader.fiber, make_read_result(channel, x)); + if (is_threaded) { + JanetVM *vm = reader.thread; + JanetEVGenericMessage msg; + msg.tag = reader.mode; + msg.fiber = reader.fiber; + msg.argi = (int32_t) reader.sched_id; + msg.argp = channel; + msg.argj = x; + janet_ev_post_event(vm, janet_thread_chan_cb, msg); } else { - janet_schedule(reader.fiber, x); + janet_ev_dec_refcount(); + if (reader.mode == JANET_CP_MODE_CHOICE_READ) { + janet_schedule(reader.fiber, make_read_result(channel, x)); + } else { + janet_schedule(reader.fiber, x); + } } } + janet_chan_unlock(channel); return 0; } -/* Pop from a channel - returns 1 if item was obtain, 0 otherwise. The item +/* Pop from a channel - returns 1 if item was obtained, 0 otherwise. The item * is returned by reference. If the pop would block, will add to the read_pending * queue in the channel. */ static int janet_channel_pop(JanetChannel *channel, Janet *item, int is_choice) { JanetChannelPending writer; + janet_chan_lock(channel); + if (channel->closed) { + janet_chan_unlock(channel); + *item = janet_wrap_nil(); + return 1; + } + int is_threaded = janet_chan_is_threaded(channel); if (janet_q_pop(&channel->items, item, sizeof(Janet))) { /* Queue empty */ JanetChannelPending pending; - pending.fiber = janet_vm_root_fiber, - pending.sched_id = janet_vm_root_fiber->sched_id; - pending.mode = is_choice ? JANET_CP_MODE_CHOICE_READ : JANET_CP_MODE_ITEM; + pending.thread = &janet_vm; + pending.fiber = janet_vm.root_fiber, + pending.sched_id = janet_vm.root_fiber->sched_id; + pending.mode = is_choice ? JANET_CP_MODE_CHOICE_READ : JANET_CP_MODE_READ; janet_q_push(&channel->read_pending, &pending, sizeof(pending)); + janet_chan_unlock(channel); + janet_ev_inc_refcount(); + if (is_threaded) { + janet_gcroot(janet_wrap_fiber(pending.fiber)); + } return 0; } + janet_assert(!janet_chan_unpack(channel, item, 0), "bad channel packing"); if (!janet_q_pop(&channel->write_pending, &writer, sizeof(writer))) { - /* pending writer */ - if (writer.mode == JANET_CP_MODE_CHOICE_WRITE) { - janet_schedule(writer.fiber, make_write_result(channel)); + /* Pending writer */ + if (is_threaded) { + JanetVM *vm = writer.thread; + JanetEVGenericMessage msg; + msg.tag = writer.mode; + msg.fiber = writer.fiber; + msg.argi = (int32_t) writer.sched_id; + msg.argp = channel; + msg.argj = janet_wrap_nil(); + janet_ev_post_event(vm, janet_thread_chan_cb, msg); } else { - janet_schedule(writer.fiber, janet_wrap_abstract(channel)); + janet_ev_dec_refcount(); + if (writer.mode == JANET_CP_MODE_CHOICE_WRITE) { + janet_schedule(writer.fiber, make_write_result(channel)); + } else { + janet_schedule(writer.fiber, janet_wrap_abstract(channel)); + } } } + janet_chan_unlock(channel); return 1; } +JanetChannel *janet_channel_unwrap(void *abstract) { + return abstract; +} + +JanetChannel *janet_getchannel(const Janet *argv, int32_t n) { + return janet_channel_unwrap(janet_getabstract(argv, n, &janet_channel_type)); +} + +JanetChannel *janet_optchannel(const Janet *argv, int32_t argc, int32_t n, JanetChannel *dflt) { + if (argc > n && !janet_checktype(argv[n], JANET_NIL)) { + return janet_getchannel(argv, n); + } else { + return dflt; + } +} + /* Channel Methods */ -static Janet cfun_channel_push(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_channel_push, + "(ev/give channel value)", + "Write a value to a channel, suspending the current fiber if the channel is full. " + "Returns the channel if the write succeeded, nil otherwise.") { janet_fixarity(argc, 2); - JanetChannel *channel = janet_getabstract(argv, 0, &ChannelAT); + JanetChannel *channel = janet_getchannel(argv, 0); if (janet_channel_push(channel, argv[1], 0)) { janet_await(); } return argv[0]; } -static Janet cfun_channel_pop(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_channel_pop, + "(ev/take channel)", + "Read from a channel, suspending the current fiber if no value is available.") { janet_fixarity(argc, 1); - JanetChannel *channel = janet_getabstract(argv, 0, &ChannelAT); + JanetChannel *channel = janet_getchannel(argv, 0); Janet item; if (janet_channel_pop(channel, &item, 0)) { - janet_schedule(janet_vm_root_fiber, item); + janet_schedule(janet_vm.root_fiber, item); } janet_await(); } -static Janet cfun_channel_choice(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_channel_choice, + "(ev/select & clauses)", + "Block until the first of several channel operations occur. Returns a tuple of the form [:give chan], [:take chan x], or [:close chan], where " + "a :give tuple is the result of a write and :take tuple is the result of a read. Each clause must be either a channel (for " + "a channel take operation) or a tuple [channel x] for a channel give operation. Operations are tried in order, such that the first " + "clauses will take precedence over later clauses. Both and give and take operations can return a [:close chan] tuple, which indicates that " + "the specified channel was closed while waiting, or that the channel was already closed.") { janet_arity(argc, 1, -1); int32_t len; const Janet *data; @@ -771,14 +974,21 @@ static Janet cfun_channel_choice(int32_t argc, Janet *argv) { for (int32_t i = 0; i < argc; i++) { if (janet_indexed_view(argv[i], &data, &len) && len == 2) { /* Write */ - JanetChannel *chan = janet_getabstract(data, 0, &ChannelAT); + JanetChannel *chan = janet_getchannel(data, 0); + janet_chan_lock(chan); + if (chan->closed) { + return make_close_result(chan); + } if (janet_q_count(&chan->items) < chan->limit) { janet_channel_push(chan, data[1], 1); return make_write_result(chan); } } else { /* Read */ - JanetChannel *chan = janet_getabstract(argv, i, &ChannelAT); + JanetChannel *chan = janet_getchannel(argv, i); + if (chan->closed) { + return make_close_result(chan); + } if (chan->items.head != chan->items.tail) { Janet item; janet_channel_pop(chan, &item, 1); @@ -791,12 +1001,14 @@ static Janet cfun_channel_choice(int32_t argc, Janet *argv) { for (int32_t i = 0; i < argc; i++) { if (janet_indexed_view(argv[i], &data, &len) && len == 2) { /* Write */ - JanetChannel *chan = janet_getabstract(data, 0, &ChannelAT); + JanetChannel *chan = janet_getchannel(data, 0); + if (chan->closed) continue; janet_channel_push(chan, data[1], 1); } else { /* Read */ Janet item; - JanetChannel *chan = janet_getabstract(argv, i, &ChannelAT); + JanetChannel *chan = janet_getchannel(argv, i); + if (chan->closed) continue; janet_channel_pop(chan, &item, 1); } } @@ -804,47 +1016,132 @@ static Janet cfun_channel_choice(int32_t argc, Janet *argv) { janet_await(); } -static Janet cfun_channel_full(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_channel_full, + "(ev/full channel)", + "Check if a channel is full or not.") { janet_fixarity(argc, 1); - JanetChannel *channel = janet_getabstract(argv, 0, &ChannelAT); - return janet_wrap_boolean(janet_q_count(&channel->items) >= channel->limit); + JanetChannel *channel = janet_getchannel(argv, 0); + janet_chan_lock(channel); + Janet ret = janet_wrap_boolean(janet_q_count(&channel->items) >= channel->limit); + janet_chan_unlock(channel); + return ret; } -static Janet cfun_channel_capacity(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_channel_capacity, + "(ev/capacity channel)", + "Get the number of items a channel will store before blocking writers.") { janet_fixarity(argc, 1); - JanetChannel *channel = janet_getabstract(argv, 0, &ChannelAT); - return janet_wrap_integer(channel->limit); + JanetChannel *channel = janet_getchannel(argv, 0); + janet_chan_lock(channel); + Janet ret = janet_wrap_integer(channel->limit); + janet_chan_unlock(channel); + return ret; } -static Janet cfun_channel_count(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_channel_count, + "(ev/count channel)", + "Get the number of items currently waiting in a channel.") { janet_fixarity(argc, 1); - JanetChannel *channel = janet_getabstract(argv, 0, &ChannelAT); - return janet_wrap_integer(janet_q_count(&channel->items)); + JanetChannel *channel = janet_getchannel(argv, 0); + janet_chan_lock(channel); + Janet ret = janet_wrap_integer(janet_q_count(&channel->items)); + janet_chan_unlock(channel); + return ret; } /* Fisher yates shuffle of arguments to get fairness */ static void fisher_yates_args(int32_t argc, Janet *argv) { for (int32_t i = argc; i > 1; i--) { - int32_t swap_index = janet_rng_u32(&janet_vm_ev_rng) % i; + int32_t swap_index = janet_rng_u32(&janet_vm.ev_rng) % i; Janet temp = argv[swap_index]; argv[swap_index] = argv[i - 1]; argv[i - 1] = temp; } } -static Janet cfun_channel_rchoice(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_channel_rchoice, + "(ev/rselect & clauses)", + "Similar to ev/select, but will try clauses in a random order for fairness.") { fisher_yates_args(argc, argv); return cfun_channel_choice(argc, argv); } -static Janet cfun_channel_new(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_channel_new, + "(ev/chan &opt capacity)", + "Create a new channel. capacity is the number of values to queue before " + "blocking writers, defaults to 0 if not provided. Returns a new channel.") { janet_arity(argc, 0, 1); int32_t limit = janet_optnat(argv, argc, 0, 0); - JanetChannel *channel = janet_abstract(&ChannelAT, sizeof(JanetChannel)); - janet_chan_init(channel, limit); + JanetChannel *channel = janet_abstract(&janet_channel_type, sizeof(JanetChannel)); + janet_chan_init(channel, limit, 0); return janet_wrap_abstract(channel); } +JANET_CORE_FN(cfun_channel_new_threaded, + "(ev/thread-chan &opt limit)", + "Create a threaded channel. A threaded channel is a channel that can be shared between threads and " + "used to communicate between any number of operating system threads.") { + janet_arity(argc, 0, 1); + int32_t limit = janet_optnat(argv, argc, 0, 0); + JanetChannel *tchan = janet_abstract_threaded(&janet_channel_type, sizeof(JanetChannel)); + janet_chan_init(tchan, limit, 1); + return janet_wrap_abstract(tchan); +} + +JANET_CORE_FN(cfun_channel_close, + "(ev/chan-close chan)", + "Close a channel. A closed channel will cause all pending reads and writes to return nil. " + "Returns the channel.") { + janet_fixarity(argc, 1); + JanetChannel *channel = janet_getchannel(argv, 0); + janet_chan_lock(channel); + if (!channel->closed) { + channel->closed = 1; + JanetChannelPending writer; + while (!janet_q_pop(&channel->write_pending, &writer, sizeof(writer))) { + if (writer.thread != &janet_vm) { + JanetVM *vm = writer.thread; + JanetEVGenericMessage msg; + msg.fiber = writer.fiber; + msg.argp = channel; + msg.tag = JANET_CP_MODE_CLOSE; + msg.argi = (int32_t) writer.sched_id; + msg.argj = janet_wrap_nil(); + janet_ev_post_event(vm, janet_thread_chan_cb, msg); + } else { + janet_ev_dec_refcount(); + if (writer.mode == JANET_CP_MODE_CHOICE_WRITE) { + janet_schedule(writer.fiber, janet_wrap_nil()); + } else { + janet_schedule(writer.fiber, make_close_result(channel)); + } + } + } + JanetChannelPending reader; + while (!janet_q_pop(&channel->read_pending, &reader, sizeof(reader))) { + if (reader.thread != &janet_vm) { + JanetVM *vm = reader.thread; + JanetEVGenericMessage msg; + msg.fiber = reader.fiber; + msg.argp = channel; + msg.tag = JANET_CP_MODE_CLOSE; + msg.argi = (int32_t) reader.sched_id; + msg.argj = janet_wrap_nil(); + janet_ev_post_event(vm, janet_thread_chan_cb, msg); + } else { + janet_ev_dec_refcount(); + if (reader.mode == JANET_CP_MODE_CHOICE_READ) { + janet_schedule(reader.fiber, janet_wrap_nil()); + } else { + janet_schedule(reader.fiber, make_close_result(channel)); + } + } + } + } + janet_chan_unlock(channel); + return argv[0]; +} + static const JanetMethod ev_chanat_methods[] = { {"select", cfun_channel_choice}, {"rselect", cfun_channel_rchoice}, @@ -853,6 +1150,7 @@ static const JanetMethod ev_chanat_methods[] = { {"give", cfun_channel_push}, {"capacity", cfun_channel_capacity}, {"full", cfun_channel_full}, + {"close", cfun_channel_close}, {NULL, NULL} }; @@ -867,11 +1165,33 @@ static Janet janet_chanat_next(void *p, Janet key) { return janet_nextmethod(ev_chanat_methods, key); } +const JanetAbstractType janet_channel_type = { + "core/channel", + janet_chanat_gc, + janet_chanat_mark, + janet_chanat_get, + NULL, /* put */ + NULL, /* marshal */ + NULL, /* unmarshal */ + NULL, /* tostring */ + NULL, /* compare */ + NULL, /* hash */ + janet_chanat_next, + JANET_ATEND_NEXT +}; + /* Main event loop */ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout); -void janet_loop1(void) { +int janet_loop_done(void) { + return !(janet_vm.listener_count || + (janet_vm.spawn.head != janet_vm.spawn.tail) || + janet_vm.tq_count || + janet_vm.extra_listeners); +} + +JanetFiber *janet_loop1(void) { /* Schedule expired timers */ JanetTimeout to; JanetTimestamp now = ts_now(); @@ -880,13 +1200,13 @@ void janet_loop1(void) { if (to.curr_fiber != NULL) { /* This is a deadline (for a fiber, not a function call) */ JanetFiberStatus s = janet_fiber_status(to.curr_fiber); - int isFinished = s == (JANET_STATUS_DEAD || - s == JANET_STATUS_ERROR || - s == JANET_STATUS_USER0 || - s == JANET_STATUS_USER1 || - s == JANET_STATUS_USER2 || - s == JANET_STATUS_USER3 || - s == JANET_STATUS_USER4); + int isFinished = (s == JANET_STATUS_DEAD || + s == JANET_STATUS_ERROR || + s == JANET_STATUS_USER0 || + s == JANET_STATUS_USER1 || + s == JANET_STATUS_USER2 || + s == JANET_STATUS_USER3 || + s == JANET_STATUS_USER4); if (!isFinished) { janet_cancel(to.fiber, janet_cstringv("deadline expired")); } @@ -903,14 +1223,33 @@ void janet_loop1(void) { } /* Run scheduled fibers */ - while (janet_vm_spawn.head != janet_vm_spawn.tail) { - JanetTask task = {NULL, janet_wrap_nil(), JANET_SIGNAL_OK}; - janet_q_pop(&janet_vm_spawn, &task, sizeof(task)); - run_one(task.fiber, task.value, task.sig); + while (janet_vm.spawn.head != janet_vm.spawn.tail) { + JanetTask task = {NULL, janet_wrap_nil(), JANET_SIGNAL_OK, 0}; + janet_q_pop(&janet_vm.spawn, &task, sizeof(task)); + if (task.expected_sched_id != task.fiber->sched_id) continue; + Janet res; + JanetSignal sig = janet_continue_signal(task.fiber, task.value, &res, task.sig); + void *sv = task.fiber->supervisor_channel; + int is_suspended = sig == JANET_SIGNAL_EVENT || sig == JANET_SIGNAL_YIELD || sig == JANET_SIGNAL_INTERRUPT; + if (NULL == sv) { + if (!is_suspended) { + janet_stacktrace(task.fiber, res); + } + } else if (sig == JANET_SIGNAL_OK || (task.fiber->flags & (1 << sig))) { + JanetChannel *chan = janet_channel_unwrap(sv); + janet_channel_push(chan, make_supervisor_event(janet_signal_names[sig], + task.fiber, chan->is_threaded), 2); + } else if (!is_suspended) { + janet_stacktrace(task.fiber, res); + } + if (sig == JANET_SIGNAL_INTERRUPT) { + /* On interrupts, return the interrupted fiber immediately */ + return task.fiber; + } } /* Poll for events */ - if (janet_vm_listener_count || janet_vm_tq_count || janet_vm_extra_listeners) { + if (janet_vm.listener_count || janet_vm.tq_count || janet_vm.extra_listeners) { JanetTimeout to; memset(&to, 0, sizeof(to)); int has_timeout; @@ -919,15 +1258,32 @@ void janet_loop1(void) { pop_timeout(0); } /* Run polling implementation only if pending timeouts or pending events */ - if (janet_vm_tq_count || janet_vm_listener_count || janet_vm_extra_listeners) { + if (janet_vm.tq_count || janet_vm.listener_count || janet_vm.extra_listeners) { janet_loop1_impl(has_timeout, to.when); } } + + /* No fiber was interrupted */ + return NULL; +} + +/* Same as janet_interpreter_interrupt, but will also + * break out of the event loop if waiting for an event + * (say, waiting for ev/sleep to finish). Does this by pushing + * an empty event to the event loop. */ +void janet_loop1_interrupt(JanetVM *vm) { + janet_interpreter_interrupt(vm); + JanetEVGenericMessage msg = {0}; + JanetCallback cb = NULL; + janet_ev_post_event(vm, cb, msg); } void janet_loop(void) { - while (janet_vm_listener_count || (janet_vm_spawn.head != janet_vm_spawn.tail) || janet_vm_tq_count || janet_vm_extra_listeners) { - janet_loop1(); + while (!janet_loop_done()) { + JanetFiber *interrupted_fiber = janet_loop1(); + if (NULL != interrupted_fiber) { + janet_schedule(interrupted_fiber, janet_wrap_nil()); + } } } @@ -935,22 +1291,6 @@ void janet_loop(void) { * Self-pipe handling code. */ -/* Wrap return value by pairing it with the callback used to handle it - * in the main thread */ -typedef struct { - JanetEVGenericMessage msg; - JanetThreadedCallback cb; -} JanetSelfPipeEvent; - -/* Structure used to initialize threads in the thread pool - * (same head structure as self pipe event)*/ -typedef struct { - JanetEVGenericMessage msg; - JanetThreadedCallback cb; - JanetThreadedSubroutine subr; - JanetHandle write_pipe; -} JanetEVThreadInit; - #ifdef JANET_WINDOWS /* On windows, use PostQueuedCompletionStatus instead for @@ -958,10 +1298,8 @@ typedef struct { #else -static JANET_THREAD_LOCAL JanetHandle janet_vm_selfpipe[2]; - static void janet_ev_setup_selfpipe(void) { - if (janet_make_pipe(janet_vm_selfpipe, 0)) { + if (janet_make_pipe(janet_vm.selfpipe, 0)) { JANET_EXIT("failed to initialize self pipe in event loop"); } } @@ -969,43 +1307,42 @@ static void janet_ev_setup_selfpipe(void) { /* Handle events from the self pipe inside the event loop */ static void janet_ev_handle_selfpipe(void) { JanetSelfPipeEvent response; - while (read(janet_vm_selfpipe[0], &response, sizeof(response)) > 0) { - response.cb(response.msg); - janet_ev_dec_refcount(); + while (read(janet_vm.selfpipe[0], &response, sizeof(response)) > 0) { + if (NULL != response.cb) { + response.cb(response.msg); + } } } static void janet_ev_cleanup_selfpipe(void) { - close(janet_vm_selfpipe[0]); - close(janet_vm_selfpipe[1]); + close(janet_vm.selfpipe[0]); + close(janet_vm.selfpipe[1]); } #endif #ifdef JANET_WINDOWS -JANET_THREAD_LOCAL HANDLE janet_vm_iocp = NULL; - static JanetTimestamp ts_now(void) { return (JanetTimestamp) GetTickCount64(); } void janet_ev_init(void) { janet_ev_init_common(); - janet_vm_iocp = CreateIoCompletionPort(INVALID_HANDLE_VALUE, NULL, 0, 0); - if (NULL == janet_vm_iocp) janet_panic("could not create io completion port"); + janet_vm.iocp = CreateIoCompletionPort(INVALID_HANDLE_VALUE, NULL, 0, 0); + if (NULL == janet_vm.iocp) janet_panic("could not create io completion port"); } void janet_ev_deinit(void) { janet_ev_deinit_common(); - CloseHandle(janet_vm_iocp); + CloseHandle(janet_vm.iocp); } JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, int mask, size_t size, void *user) { /* Add the handle to the io completion port if not already added */ JanetListenerState *state = janet_listen_impl(stream, behavior, mask, size, user); if (!(stream->flags & JANET_STREAM_IOCP)) { - if (NULL == CreateIoCompletionPort(stream->handle, janet_vm_iocp, (ULONG_PTR) stream, 0)) { + if (NULL == CreateIoCompletionPort(stream->handle, janet_vm.iocp, (ULONG_PTR) stream, 0)) { janet_panicf("failed to listen for events: %V", janet_ev_lasterr()); } stream->flags |= JANET_STREAM_IOCP; @@ -1014,8 +1351,8 @@ JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, in } -static void janet_unlisten(JanetListenerState *state) { - janet_unlisten_impl(state); +static void janet_unlisten(JanetListenerState *state, int is_gc) { + janet_unlisten_impl(state, is_gc); } void janet_loop1_impl(int has_timeout, JanetTimestamp to) { @@ -1035,15 +1372,16 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp to) { } else { waittime = INFINITE; } - BOOL result = GetQueuedCompletionStatus(janet_vm_iocp, &num_bytes_transfered, &completionKey, &overlapped, (DWORD) waittime); + BOOL result = GetQueuedCompletionStatus(janet_vm.iocp, &num_bytes_transfered, &completionKey, &overlapped, (DWORD) waittime); if (result || overlapped) { if (0 == completionKey) { /* Custom event */ JanetSelfPipeEvent *response = (JanetSelfPipeEvent *)(overlapped); - response->cb(response->msg); + if (NULL != response->cb) { + response->cb(response->msg); + } janet_free(response); - janet_ev_dec_refcount(); } else { /* Normal event */ JanetStream *stream = (JanetStream *) completionKey; @@ -1054,7 +1392,7 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp to) { state->bytes = num_bytes_transfered; JanetAsyncStatus status = state->machine(state, JANET_ASYNC_EVENT_COMPLETE); if (status == JANET_ASYNC_STATUS_DONE) { - janet_unlisten(state); + janet_unlisten(state, 0); } break; } else { @@ -1067,10 +1405,6 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp to) { #elif defined(JANET_EV_EPOLL) -JANET_THREAD_LOCAL int janet_vm_epoll = 0; -JANET_THREAD_LOCAL int janet_vm_timerfd = 0; -JANET_THREAD_LOCAL int janet_vm_timer_enabled = 0; - static JanetTimestamp ts_now(void) { struct timespec now; janet_assert(-1 != clock_gettime(CLOCK_MONOTONIC, &now), "failed to get time"); @@ -1088,6 +1422,23 @@ static int make_epoll_events(int mask) { return events; } +static void janet_epoll_sync_callback(JanetEVGenericMessage msg) { + JanetListenerState *state = msg.argp; + JanetAsyncStatus status1 = JANET_ASYNC_STATUS_NOT_DONE; + JanetAsyncStatus status2 = JANET_ASYNC_STATUS_NOT_DONE; + if (state->stream->_mask & JANET_ASYNC_LISTEN_WRITE) + status1 = state->machine(state, JANET_ASYNC_EVENT_WRITE); + if (state->stream->_mask & JANET_ASYNC_LISTEN_WRITE) + status2 = state->machine(state, JANET_ASYNC_EVENT_READ); + if (status1 == JANET_ASYNC_STATUS_DONE || + status2 == JANET_ASYNC_STATUS_DONE) { + janet_unlisten(state, 0); + } else { + /* Repost event */ + janet_ev_post_event(NULL, janet_epoll_sync_callback, msg); + } +} + /* Wait for the next event */ JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, int mask, size_t size, void *user) { int is_first = !(stream->state); @@ -1098,54 +1449,71 @@ JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, in ev.data.ptr = stream; int status; do { - status = epoll_ctl(janet_vm_epoll, op, stream->handle, &ev); + status = epoll_ctl(janet_vm.epoll, op, stream->handle, &ev); } while (status == -1 && errno == EINTR); if (status == -1) { - janet_unlisten_impl(state); - janet_panicv(janet_ev_lasterr()); + if (errno == EPERM) { + /* Couldn't add to event loop, so assume that it completes + * synchronously. In that case, fire the completion + * event manually, since this should be a read or write + * event to a file. So we just post a custom event to do the read/write + * asap. */ + /* Use flag to indicate state is not registered in epoll */ + state->_mask |= (1 << JANET_ASYNC_EVENT_COMPLETE); + JanetEVGenericMessage msg = {0}; + msg.argp = state; + janet_ev_post_event(NULL, janet_epoll_sync_callback, msg); + } else { + /* Unexpected error */ + janet_unlisten_impl(state, 0); + janet_panicv(janet_ev_lasterr()); + } } return state; } /* Tell system we are done listening for a certain event */ -static void janet_unlisten(JanetListenerState *state) { +static void janet_unlisten(JanetListenerState *state, int is_gc) { JanetStream *stream = state->stream; if (!(stream->flags & JANET_STREAM_CLOSED)) { - int is_last = (state->_next == NULL && stream->state == state); - int op = is_last ? EPOLL_CTL_DEL : EPOLL_CTL_MOD; - struct epoll_event ev; - ev.events = make_epoll_events(stream->_mask & ~state->_mask); - ev.data.ptr = stream; - int status; - do { - status = epoll_ctl(janet_vm_epoll, op, stream->handle, &ev); - } while (status == -1 && errno == EINTR); - if (status == -1) { - janet_panicv(janet_ev_lasterr()); + /* Use flag to indicate state is not registered in epoll */ + if (!(state->_mask & (1 << JANET_ASYNC_EVENT_COMPLETE))) { + int is_last = (state->_next == NULL && stream->state == state); + int op = is_last ? EPOLL_CTL_DEL : EPOLL_CTL_MOD; + struct epoll_event ev; + ev.events = make_epoll_events(stream->_mask & ~state->_mask); + ev.data.ptr = stream; + int status; + do { + status = epoll_ctl(janet_vm.epoll, op, stream->handle, &ev); + } while (status == -1 && errno == EINTR); + if (status == -1) { + janet_panicv(janet_ev_lasterr()); + } } } /* Destroy state machine and free memory */ - janet_unlisten_impl(state); + janet_unlisten_impl(state, is_gc); } #define JANET_EPOLL_MAX_EVENTS 64 void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { struct itimerspec its; - if (janet_vm_timer_enabled || has_timeout) { + if (janet_vm.timer_enabled || has_timeout) { memset(&its, 0, sizeof(its)); if (has_timeout) { its.it_value.tv_sec = timeout / 1000; its.it_value.tv_nsec = (timeout % 1000) * 1000000; } - timerfd_settime(janet_vm_timerfd, TFD_TIMER_ABSTIME, &its, NULL); + timerfd_settime(janet_vm.timerfd, TFD_TIMER_ABSTIME, &its, NULL); } - janet_vm_timer_enabled = has_timeout; + janet_vm.timer_enabled = has_timeout; /* Poll for events */ struct epoll_event events[JANET_EPOLL_MAX_EVENTS]; int ready; do { - ready = epoll_wait(janet_vm_epoll, events, JANET_EPOLL_MAX_EVENTS, -1); + ready = epoll_wait(janet_vm.epoll, events, JANET_EPOLL_MAX_EVENTS, -1); } while (ready == -1 && errno == EINTR); if (ready == -1) { JANET_EXIT("failed to poll events"); @@ -1154,17 +1522,17 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { /* Step state machines */ for (int i = 0; i < ready; i++) { void *p = events[i].data.ptr; - if (&janet_vm_timerfd == p) { + if (&janet_vm.timerfd == p) { /* Timer expired, ignore */; - } else if (janet_vm_selfpipe == p) { + } else if (janet_vm.selfpipe == p) { /* Self-pipe handling */ janet_ev_handle_selfpipe(); } else { JanetStream *stream = p; int mask = events[i].events; JanetListenerState *state = stream->state; - state->event = events + i; while (NULL != state) { + state->event = events + i; JanetListenerState *next_state = state->_next; JanetAsyncStatus status1 = JANET_ASYNC_STATUS_NOT_DONE; JanetAsyncStatus status2 = JANET_ASYNC_STATUS_NOT_DONE; @@ -1182,7 +1550,7 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { status2 == JANET_ASYNC_STATUS_DONE || status3 == JANET_ASYNC_STATUS_DONE || status4 == JANET_ASYNC_STATUS_DONE) - janet_unlisten(state); + janet_unlisten(state, 0); state = next_state; } } @@ -1192,17 +1560,17 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { void janet_ev_init(void) { janet_ev_init_common(); janet_ev_setup_selfpipe(); - janet_vm_epoll = epoll_create1(EPOLL_CLOEXEC); - janet_vm_timerfd = timerfd_create(CLOCK_MONOTONIC, TFD_CLOEXEC | TFD_NONBLOCK); - janet_vm_timer_enabled = 0; - if (janet_vm_epoll == -1 || janet_vm_timerfd == -1) goto error; + janet_vm.epoll = epoll_create1(EPOLL_CLOEXEC); + janet_vm.timerfd = timerfd_create(CLOCK_MONOTONIC, TFD_CLOEXEC | TFD_NONBLOCK); + janet_vm.timer_enabled = 0; + if (janet_vm.epoll == -1 || janet_vm.timerfd == -1) goto error; struct epoll_event ev; ev.events = EPOLLIN | EPOLLET; - ev.data.ptr = &janet_vm_timerfd; - if (-1 == epoll_ctl(janet_vm_epoll, EPOLL_CTL_ADD, janet_vm_timerfd, &ev)) goto error; + ev.data.ptr = &janet_vm.timerfd; + if (-1 == epoll_ctl(janet_vm.epoll, EPOLL_CTL_ADD, janet_vm.timerfd, &ev)) goto error; ev.events = EPOLLIN | EPOLLET; - ev.data.ptr = janet_vm_selfpipe; - if (-1 == epoll_ctl(janet_vm_epoll, EPOLL_CTL_ADD, janet_vm_selfpipe[0], &ev)) goto error; + ev.data.ptr = janet_vm.selfpipe; + if (-1 == epoll_ctl(janet_vm.epoll, EPOLL_CTL_ADD, janet_vm.selfpipe[0], &ev)) goto error; return; error: JANET_EXIT("failed to initialize event loop"); @@ -1210,22 +1578,211 @@ error: void janet_ev_deinit(void) { janet_ev_deinit_common(); - close(janet_vm_epoll); - close(janet_vm_timerfd); + close(janet_vm.epoll); + close(janet_vm.timerfd); janet_ev_cleanup_selfpipe(); - janet_vm_epoll = 0; + janet_vm.epoll = 0; } /* * End epoll implementation */ +#elif defined(JANET_EV_KQUEUE) +/* Definition from: + * https://github.com/wahern/cqueues/blob/master/src/lib/kpoll.c + * NetBSD uses intptr_t while others use void * for .udata */ +#define EV_SETx(ev, a, b, c, d, e, f) EV_SET((ev), (a), (b), (c), (d), (e), ((__typeof__((ev)->udata))(f))) +#define JANET_KQUEUE_TF (EV_ADD | EV_ENABLE | EV_CLEAR | EV_ONESHOT) +#define JANET_KQUEUE_MIN_INTERVAL 0 + +/* NOTE: + * NetBSD and OpenBSD expect things are always intervals, and FreeBSD doesn't + * like an ABSTIME in the past so just use intervals always. Introduces a + * calculation to determine the minimum timeout per timeout requested of + * kqueue. Also note that NetBSD doesn't accept timeout intervals less than 1 + * millisecond, so correct all intervals on that platform to be at least 1 + * millisecond.*/ +JanetTimestamp to_interval(const JanetTimestamp ts) { + return ts >= JANET_KQUEUE_MIN_INTERVAL ? ts : JANET_KQUEUE_MIN_INTERVAL; +} +#define JANET_KQUEUE_INTERVAL(timestamp) (to_interval((timestamp - ts_now()))) + + +/* TODO: make this available be we using kqueue or epoll, instead of + * redefinining it for kqueue and epoll separately? */ +static JanetTimestamp ts_now(void) { + struct timespec now; + janet_assert(-1 != clock_gettime(CLOCK_MONOTONIC, &now), "failed to get time"); + uint64_t res = 1000 * now.tv_sec; + res += now.tv_nsec / 1000000; + return res; +} + +/* NOTE: Assumes Janet's timestamp precision is in milliseconds. */ +static void timestamp2timespec(struct timespec *t, JanetTimestamp ts) { + t->tv_sec = ts == 0 ? 0 : ts / 1000; + t->tv_nsec = ts == 0 ? 0 : (ts % 1000) * 1000000; +} + +void add_kqueue_events(const struct kevent *events, int length) { + /* NOTE: Status should be equal to the amount of events added, which isn't + * always known since deletions or modifications occur. Can't use the + * eventlist argument for it to report to us what failed otherwise we may + * poll in events to handle! This code assumes atomicity, that kqueue can + * either succeed or fail, but never partially (which is seemingly how it + * works in practice). When encountering an "inbetween" state we currently + * just panic! + * + * The FreeBSD man page kqueue(2) shows a check through the change list to + * check if kqueue had an error with any of the events being pushed to + * change. Maybe we should do this, even tho the man page also doesn't + * note that kqueue actually does this. We do not do this at this time. */ + int status; + status = kevent(janet_vm.kq, events, length, NULL, 0, NULL); + if (status == -1 && errno != EINTR) + janet_panicv(janet_ev_lasterr()); +} + +JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, int mask, size_t size, void *user) { + JanetListenerState *state = janet_listen_impl(stream, behavior, mask, size, user); + struct kevent kev[2]; + + int length = 0; + if (state->stream->_mask & JANET_ASYNC_LISTEN_READ) { + EV_SETx(&kev[length], stream->handle, EVFILT_READ, EV_ADD | EV_ENABLE, 0, 0, stream); + length++; + } + if (state->stream->_mask & JANET_ASYNC_LISTEN_WRITE) { + EV_SETx(&kev[length], stream->handle, EVFILT_WRITE, EV_ADD | EV_ENABLE, 0, 0, stream); + length++; + } + + if (length > 0) { + add_kqueue_events(kev, length); + } + + return state; +} + +static void janet_unlisten(JanetListenerState *state, int is_gc) { + JanetStream *stream = state->stream; + if (!(stream->flags & JANET_STREAM_CLOSED)) { + /* Use flag to indicate state is not registered in kqueue */ + if (!(state->_mask & (1 << JANET_ASYNC_EVENT_COMPLETE))) { + int is_last = (state->_next == NULL && stream->state == state); + int op = is_last ? EV_DELETE : EV_DISABLE | EV_ADD; + struct kevent kev[2]; + EV_SETx(&kev[1], stream->handle, EVFILT_WRITE, op, 0, 0, stream); + + int length = 0; + if (stream->_mask & JANET_ASYNC_EVENT_WRITE) { + EV_SETx(&kev[length], stream->handle, EVFILT_WRITE, op, 0, 0, stream); + length++; + } + if (stream->_mask & JANET_ASYNC_EVENT_READ) { + EV_SETx(&kev[length], stream->handle, EVFILT_READ, op, 0, 0, stream); + length++; + } + + add_kqueue_events(kev, length); + } + } + janet_unlisten_impl(state, is_gc); +} + +#define JANET_KQUEUE_MAX_EVENTS 64 + +void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { + /* Poll for events */ + /* NOTE: + * We calculate the timeout interval per iteration. When the interval + * drops to 0 or negative, we effect a timeout of 0. Effecting a timeout + * of infinity will not work and could make other fibers with timeouts + * miss their timeouts if we did so. + * JANET_KQUEUE_INTERVAL insures we have a timeout of no less than 0. */ + int status; + struct timespec ts; + struct kevent events[JANET_KQUEUE_MAX_EVENTS]; + do { + if (janet_vm.timer_enabled || has_timeout) { + timestamp2timespec(&ts, JANET_KQUEUE_INTERVAL(timeout)); + status = kevent(janet_vm.kq, NULL, 0, events, + JANET_KQUEUE_MAX_EVENTS, &ts); + } else { + status = kevent(janet_vm.kq, NULL, 0, events, + JANET_KQUEUE_MAX_EVENTS, NULL); + } + } while (status == -1 && errno == EINTR); + if (status == -1) + JANET_EXIT("failed to poll events"); + + /* Make sure timer is set accordingly. */ + janet_vm.timer_enabled = has_timeout; + + /* Step state machines */ + for (int i = 0; i < status; i++) { + void *p = (void *) events[i].udata; + if (janet_vm.selfpipe == p) { + /* Self-pipe handling */ + janet_ev_handle_selfpipe(); + } else { + JanetStream *stream = p; + JanetListenerState *state = stream->state; + while (NULL != state) { + JanetListenerState *next_state = state->_next; + state->event = events + i; + JanetAsyncStatus statuses[4]; + for (int i = 0; i < 4; i++) + statuses[i] = JANET_ASYNC_STATUS_NOT_DONE; + + if (!(events[i].flags & EV_ERROR)) { + if (events[i].filter == EVFILT_WRITE) + statuses[0] = state->machine(state, JANET_ASYNC_EVENT_WRITE); + if (events[i].filter == EVFILT_READ) + statuses[1] = state->machine(state, JANET_ASYNC_EVENT_READ); + if ((events[i].flags & EV_EOF) && !(events[i].data > 0)) + statuses[3] = state->machine(state, JANET_ASYNC_EVENT_HUP); + } else { + statuses[2] = state->machine(state, JANET_ASYNC_EVENT_ERR); + } + if (statuses[0] == JANET_ASYNC_STATUS_DONE || + statuses[1] == JANET_ASYNC_STATUS_DONE || + statuses[2] == JANET_ASYNC_STATUS_DONE || + statuses[3] == JANET_ASYNC_STATUS_DONE) + janet_unlisten(state, 0); + + state = next_state; + } + } + } +} + +void janet_ev_init(void) { + janet_ev_init_common(); + janet_ev_setup_selfpipe(); + janet_vm.kq = kqueue(); + janet_vm.timer_enabled = 0; + if (janet_vm.kq == -1) goto error; + struct kevent event; + EV_SETx(&event, janet_vm.selfpipe[0], EVFILT_READ, EV_ADD | EV_ENABLE, 0, 0, janet_vm.selfpipe); + add_kqueue_events(&event, 1); + return; +error: + JANET_EXIT("failed to initialize event loop"); +} + +void janet_ev_deinit(void) { + janet_ev_deinit_common(); + close(janet_vm.kq); + janet_ev_cleanup_selfpipe(); + janet_vm.kq = 0; +} + #else #include -JANET_THREAD_LOCAL struct pollfd *janet_vm_fds = NULL; - static JanetTimestamp ts_now(void) { struct timespec now; janet_assert(-1 != clock_gettime(CLOCK_REALTIME, &now), "failed to get time"); @@ -1245,12 +1802,12 @@ static int make_poll_events(int mask) { /* Wait for the next event */ JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, int mask, size_t size, void *user) { - size_t oldsize = janet_vm_listener_cap; + size_t oldsize = janet_vm.listener_cap; JanetListenerState *state = janet_listen_impl(stream, behavior, mask, size, user); - size_t newsize = janet_vm_listener_cap; + size_t newsize = janet_vm.listener_cap; if (newsize > oldsize) { - janet_vm_fds = janet_realloc(janet_vm_fds, (newsize + 1) * sizeof(struct pollfd)); - if (NULL == janet_vm_fds) { + janet_vm.fds = janet_realloc(janet_vm.fds, (newsize + 1) * sizeof(struct pollfd)); + if (NULL == janet_vm.fds) { JANET_OUT_OF_MEMORY; } } @@ -1258,13 +1815,13 @@ JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, in ev.fd = stream->handle; ev.events = make_poll_events(state->stream->_mask); ev.revents = 0; - janet_vm_fds[state->_index + 1] = ev; + janet_vm.fds[state->_index + 1] = ev; return state; } -static void janet_unlisten(JanetListenerState *state) { - janet_vm_fds[state->_index + 1] = janet_vm_fds[janet_vm_listener_count]; - janet_unlisten_impl(state); +static void janet_unlisten(JanetListenerState *state, int is_gc) { + janet_vm.fds[state->_index + 1] = janet_vm.fds[janet_vm.listener_count]; + janet_unlisten_impl(state, is_gc); } void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { @@ -1276,23 +1833,23 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { JanetTimestamp now = ts_now(); to = now > timeout ? 0 : (int)(timeout - now); } - ready = poll(janet_vm_fds, janet_vm_listener_count + 1, to); + ready = poll(janet_vm.fds, janet_vm.listener_count + 1, to); } while (ready == -1 && errno == EINTR); if (ready == -1) { JANET_EXIT("failed to poll events"); } /* Check selfpipe */ - if (janet_vm_fds[0].revents & POLLIN) { - janet_vm_fds[0].revents = 0; + if (janet_vm.fds[0].revents & POLLIN) { + janet_vm.fds[0].revents = 0; janet_ev_handle_selfpipe(); } /* Step state machines */ - for (size_t i = 0; i < janet_vm_listener_count; i++) { - struct pollfd *pfd = janet_vm_fds + i + 1; + for (size_t i = 0; i < janet_vm.listener_count; i++) { + struct pollfd *pfd = janet_vm.fds + i + 1; /* Skip fds where nothing interesting happened */ - JanetListenerState *state = janet_vm_listeners[i]; + JanetListenerState *state = janet_vm.listeners[i]; /* Normal event */ int mask = pfd->revents; JanetAsyncStatus status1 = JANET_ASYNC_STATUS_NOT_DONE; @@ -1312,29 +1869,29 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { status2 == JANET_ASYNC_STATUS_DONE || status3 == JANET_ASYNC_STATUS_DONE || status4 == JANET_ASYNC_STATUS_DONE) - janet_unlisten(state); + janet_unlisten(state, 0); } } void janet_ev_init(void) { janet_ev_init_common(); - janet_vm_fds = NULL; + janet_vm.fds = NULL; janet_ev_setup_selfpipe(); - janet_vm_fds = janet_malloc(sizeof(struct pollfd)); - if (NULL == janet_vm_fds) { + janet_vm.fds = janet_malloc(sizeof(struct pollfd)); + if (NULL == janet_vm.fds) { JANET_OUT_OF_MEMORY; } - janet_vm_fds[0].fd = janet_vm_selfpipe[0]; - janet_vm_fds[0].events = POLLIN; - janet_vm_fds[0].revents = 0; + janet_vm.fds[0].fd = janet_vm.selfpipe[0]; + janet_vm.fds[0].events = POLLIN; + janet_vm.fds[0].revents = 0; return; } void janet_ev_deinit(void) { janet_ev_deinit_common(); janet_ev_cleanup_selfpipe(); - janet_free(janet_vm_fds); - janet_vm_fds = NULL; + janet_free(janet_vm.fds); + janet_vm.fds = NULL; } #endif @@ -1343,6 +1900,46 @@ void janet_ev_deinit(void) { * End poll implementation */ +/* + * Generic Callback system. Post a function pointer + data to the event loop (from another + * thread or even a signal handler). Allows posting events from another thread or signal handler. + */ +void janet_ev_post_event(JanetVM *vm, JanetCallback cb, JanetEVGenericMessage msg) { + vm = vm ? vm : &janet_vm; +#ifdef JANET_WINDOWS + JanetHandle iocp = vm->iocp; + JanetSelfPipeEvent *event = janet_malloc(sizeof(JanetSelfPipeEvent)); + if (NULL == event) { + JANET_OUT_OF_MEMORY; + } + event->msg = msg; + event->cb = cb; + janet_assert(PostQueuedCompletionStatus(iocp, + sizeof(JanetSelfPipeEvent), + 0, + (LPOVERLAPPED) event), + "failed to post completion event"); +#else + JanetSelfPipeEvent event; + memset(&event, 0, sizeof(event)); + event.msg = msg; + event.cb = cb; + int fd = vm->selfpipe[1]; + /* handle a bit of back pressure before giving up. */ + int tries = 4; + while (tries > 0) { + int status; + do { + status = write(fd, &event, sizeof(event)); + } while (status == -1 && errno == EINTR); + if (status > 0) break; + sleep(0); + tries--; + } + janet_assert(tries > 0, "failed to write event to self-pipe"); +#endif +} + /* * Threaded calls */ @@ -1373,6 +1970,7 @@ static void *janet_thread_body(void *ptr) { int fd = init->write_pipe; janet_free(init); JanetSelfPipeEvent response; + memset(&response, 0, sizeof(response)); response.msg = subr(msg); response.cb = cb; /* handle a bit of back pressure before giving up. */ @@ -1400,7 +1998,7 @@ void janet_ev_threaded_call(JanetThreadedSubroutine fp, JanetEVGenericMessage ar init->cb = cb; #ifdef JANET_WINDOWS - init->write_pipe = janet_vm_iocp; + init->write_pipe = janet_vm.iocp; HANDLE thread_handle = CreateThread(NULL, 0, janet_thread_body, init, 0, NULL); if (NULL == thread_handle) { janet_free(init); @@ -1408,7 +2006,7 @@ void janet_ev_threaded_call(JanetThreadedSubroutine fp, JanetEVGenericMessage ar } CloseHandle(thread_handle); /* detach from thread */ #else - init->write_pipe = janet_vm_selfpipe[1]; + init->write_pipe = janet_vm.selfpipe[1]; pthread_t waiter_thread; int err = pthread_create(&waiter_thread, NULL, janet_thread_body, init); if (err) { @@ -1424,6 +2022,10 @@ void janet_ev_threaded_call(JanetThreadedSubroutine fp, JanetEVGenericMessage ar /* Default callback for janet_ev_threaded_await. */ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) { + janet_ev_dec_refcount(); + if (return_value.fiber == NULL) { + return; + } switch (return_value.tag) { default: case JANET_EV_TCTAG_NIL: @@ -1460,6 +2062,7 @@ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) { JANET_NO_RETURN void janet_ev_threaded_await(JanetThreadedSubroutine fp, int tag, int argi, void *argp) { JanetEVGenericMessage arguments; + memset(&arguments, 0, sizeof(arguments)); arguments.tag = tag; arguments.argi = argi; arguments.argp = argp; @@ -1639,7 +2242,7 @@ JanetAsyncStatus ev_machine_read(JanetListenerState *s, JanetAsyncEvent event) { case JANET_ASYNC_EVENT_READ: { JanetBuffer *buffer = state->buf; int32_t bytes_left = state->bytes_left; - int32_t read_limit = bytes_left > 4096 ? 4096 : bytes_left; + int32_t read_limit = state->is_chunk ? (bytes_left > 4096 ? 4096 : bytes_left) : bytes_left; janet_buffer_extra(buffer, read_limit); ssize_t nread; #ifdef JANET_NET @@ -1838,6 +2441,18 @@ JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event) } else #endif { + /* + * File handles in IOCP need to specify this if they are writing to the + * ends of files, like how this is used here. + * If the underlying resource doesn't support seeking + * byte offsets, they will be ignored + * but this otherwise writes to the end of the file in question + * Right now, os/open streams aren't seekable, so this works. + * for more details see the lpOverlapped parameter in + * https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-writefile + */ + state->overlapped.Offset = (DWORD) 0xFFFFFFFF; + state->overlapped.OffsetHigh = (DWORD) 0xFFFFFFFF; status = WriteFile(s->stream->handle, bytes, len, NULL, &state->overlapped); if (!status && (ERROR_IO_PENDING != WSAGetLastError())) { janet_cancel(s->fiber, janet_ev_lasterr()); @@ -1963,15 +2578,16 @@ void janet_ev_sendto_string(JanetStream *stream, JanetString str, void *dest, in static volatile long PipeSerialNumber; #endif +/* + * mode = 0: both sides non-blocking. + * mode = 1: only read side non-blocking: write side sent to subprocess + * mode = 2: only write side non-blocking: read side sent to subprocess + */ int janet_make_pipe(JanetHandle handles[2], int mode) { #ifdef JANET_WINDOWS /* * On windows, the built in CreatePipe function doesn't support overlapped IO * so we lift from the windows source code and modify for our own version. - * - * mode = 0: both sides non-blocking. - * mode = 1: only read side non-blocking: write side sent to subprocess - * mode = 2: only write side non-blocking: read side sent to subprocess */ JanetHandle shandle, chandle; UCHAR PipeNameBuffer[MAX_PATH]; @@ -2021,10 +2637,9 @@ int janet_make_pipe(JanetHandle handles[2], int mode) { } return 0; #else - (void) mode; if (pipe(handles)) return -1; - if (fcntl(handles[0], F_SETFL, O_NONBLOCK)) goto error; - if (fcntl(handles[1], F_SETFL, O_NONBLOCK)) goto error; + if (mode != 2 && fcntl(handles[0], F_SETFL, O_NONBLOCK)) goto error; + if (mode != 1 && fcntl(handles[1], F_SETFL, O_NONBLOCK)) goto error; return 0; error: close(handles[0]); @@ -2035,15 +2650,42 @@ error: /* C functions */ -static Janet cfun_ev_go(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_ev_go, + "(ev/go fiber &opt value supervisor)", + "Put a fiber on the event loop to be resumed later. Optionally pass " + "a value to resume with, otherwise resumes with nil. Returns the fiber. " + "An optional `core/channel` can be provided as a supervisor. When various " + "events occur in the newly scheduled fiber, an event will be pushed to the supervisor. " + "If not provided, the new fiber will inherit the current supervisor.") { janet_arity(argc, 1, 3); - JanetFiber *fiber = janet_getfiber(argv, 0); - Janet value = argc == 2 ? argv[1] : janet_wrap_nil(); - JanetChannel *supervisor_channel = janet_optabstract(argv, argc, 2, &ChannelAT, - janet_vm_root_fiber->supervisor_channel); - fiber->supervisor_channel = supervisor_channel; + Janet value = argc >= 2 ? argv[1] : janet_wrap_nil(); + void *supervisor = janet_optabstract(argv, argc, 2, &janet_channel_type, janet_vm.root_fiber->supervisor_channel); + JanetFiber *fiber; + if (janet_checktype(argv[0], JANET_FUNCTION)) { + /* Create a fiber for the user */ + JanetFunction *func = janet_unwrap_function(argv[0]); + if (func->def->min_arity > 1) { + janet_panicf("task function must accept 0 or 1 arguments"); + } + fiber = janet_fiber(func, 64, func->def->min_arity, &value); + fiber->flags |= + JANET_FIBER_MASK_ERROR | + JANET_FIBER_MASK_USER0 | + JANET_FIBER_MASK_USER1 | + JANET_FIBER_MASK_USER2 | + JANET_FIBER_MASK_USER3 | + JANET_FIBER_MASK_USER4; + if (!janet_vm.fiber->env) { + janet_vm.fiber->env = janet_table(0); + } + fiber->env = janet_table(0); + fiber->env->proto = janet_vm.fiber->env; + } else { + fiber = janet_getfiber(argv, 0); + } + fiber->supervisor_channel = supervisor; janet_schedule(fiber, value); - return argv[0]; + return janet_wrap_fiber(fiber); } /* For ev/thread - Run an interpreter in the new thread. */ @@ -2051,63 +2693,175 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { JanetBuffer *buffer = (JanetBuffer *) args.argp; const uint8_t *nextbytes = buffer->data; const uint8_t *endbytes = nextbytes + buffer->count; + uint32_t flags = args.tag; + args.tag = 0; janet_init(); JanetTryState tstate; JanetSignal signal = janet_try(&tstate); if (!signal) { - Janet aregv = janet_unmarshal(nextbytes, endbytes - nextbytes, - JANET_MARSHAL_UNSAFE, NULL, &nextbytes); - if (!janet_checktype(aregv, JANET_TABLE)) janet_panic("expected table for abstract registry"); - janet_vm_abstract_registry = janet_unwrap_table(aregv); - Janet regv = janet_unmarshal(nextbytes, endbytes - nextbytes, - JANET_MARSHAL_UNSAFE, NULL, &nextbytes); - if (!janet_checktype(regv, JANET_TABLE)) janet_panic("expected table for cfunction registry"); - janet_vm_registry = janet_unwrap_table(regv); + + /* Set abstract registry */ + if (!(flags & 0x2)) { + Janet aregv = janet_unmarshal(nextbytes, endbytes - nextbytes, + JANET_MARSHAL_UNSAFE, NULL, &nextbytes); + if (!janet_checktype(aregv, JANET_TABLE)) janet_panic("expected table for abstract registry"); + janet_vm.abstract_registry = janet_unwrap_table(aregv); + janet_gcroot(janet_wrap_table(janet_vm.abstract_registry)); + } + + /* Get supervsior */ + if (flags & 0x8) { + Janet sup = + janet_unmarshal(nextbytes, endbytes - nextbytes, + JANET_MARSHAL_UNSAFE, NULL, &nextbytes); + /* Hack - use a global variable to avoid longjmp clobber */ + janet_vm.user = janet_unwrap_pointer(sup); + } + + /* Set cfunction registry */ + if (!(flags & 0x4)) { + uint32_t count1; + memcpy(&count1, nextbytes, sizeof(count1)); + size_t count = (size_t) count1; + if (count > (endbytes - nextbytes) * sizeof(JanetCFunRegistry)) { + janet_panic("thread message invalid"); + } + janet_vm.registry_count = count; + janet_vm.registry_cap = count; + janet_vm.registry = janet_malloc(count * sizeof(JanetCFunRegistry)); + if (janet_vm.registry == NULL) { + JANET_OUT_OF_MEMORY; + } + janet_vm.registry_dirty = 1; + nextbytes += sizeof(uint32_t); + memcpy(janet_vm.registry, nextbytes, count * sizeof(JanetCFunRegistry)); + nextbytes += count * sizeof(JanetCFunRegistry); + } + Janet fiberv = janet_unmarshal(nextbytes, endbytes - nextbytes, JANET_MARSHAL_UNSAFE, NULL, &nextbytes); Janet value = janet_unmarshal(nextbytes, endbytes - nextbytes, JANET_MARSHAL_UNSAFE, NULL, &nextbytes); - if (!janet_checktype(fiberv, JANET_FIBER)) janet_panic("expected fiber"); - JanetFiber *fiber = janet_unwrap_fiber(fiberv); + JanetFiber *fiber; + if (!janet_checktype(fiberv, JANET_FIBER)) { + if (!janet_checktype(fiberv, JANET_FUNCTION)) { + janet_panicf("expected function|fiber, got %v", fiberv); + } + JanetFunction *func = janet_unwrap_function(fiberv); + if (func->def->min_arity > 1) { + janet_panicf("thread function must accept 0 or 1 arguments"); + } + fiber = janet_fiber(func, 64, func->def->min_arity, &value); + fiber->flags |= + JANET_FIBER_MASK_ERROR | + JANET_FIBER_MASK_USER0 | + JANET_FIBER_MASK_USER1 | + JANET_FIBER_MASK_USER2 | + JANET_FIBER_MASK_USER3 | + JANET_FIBER_MASK_USER4; + } else { + fiber = janet_unwrap_fiber(fiberv); + } + fiber->supervisor_channel = janet_vm.user; janet_schedule(fiber, value); janet_loop(); args.tag = JANET_EV_TCTAG_NIL; } else { - if (janet_checktype(tstate.payload, JANET_STRING)) { - args.tag = JANET_EV_TCTAG_ERR_STRINGF; - args.argp = strdup((const char *) janet_unwrap_string(tstate.payload)); + void *supervisor = janet_vm.user; + if (NULL != supervisor) { + /* Got a supervisor, write error there */ + Janet pair[] = { + janet_ckeywordv("error"), + tstate.payload + }; + janet_channel_push((JanetChannel *)supervisor, + janet_wrap_tuple(janet_tuple_n(pair, 2)), 2); + } else if (flags & 0x1) { + /* No wait, just print to stderr */ + janet_eprintf("thread start failure: %v\n", tstate.payload); } else { - args.tag = JANET_EV_TCTAG_ERR_STRING; - args.argp = "failed to start thread"; + /* Make ev/thread call from parent thread error */ + if (janet_checktype(tstate.payload, JANET_STRING)) { + args.tag = JANET_EV_TCTAG_ERR_STRINGF; + args.argp = strdup((const char *) janet_unwrap_string(tstate.payload)); + } else { + args.tag = JANET_EV_TCTAG_ERR_STRING; + args.argp = "failed to start thread"; + } } } - janet_buffer_deinit(buffer); janet_restore(&tstate); + janet_buffer_deinit(buffer); + janet_free(buffer); janet_deinit(); return args; } -static Janet cfun_ev_thread(int32_t argc, Janet *argv) { - janet_arity(argc, 1, 3); - janet_getfiber(argv, 0); - Janet value = argc == 2 ? argv[1] : janet_wrap_nil(); +JANET_CORE_FN(cfun_ev_thread, + "(ev/thread main &opt value flags supervisor)", + "Run `main` in a new operating system thread, optionally passing `value` " + "to resume with. The parameter `main` can either be a fiber, or a function that accepts " + "0 or 1 arguments. " + "Unlike `ev/go`, this function will suspend the current fiber until the thread is complete. " + "If you want to run the thread without waiting for a result, pass the `:n` flag to return nil immediately. " + "Otherwise, returns nil. Available flags:\n\n" + "* `:n` - return immediately\n" + "* `:a` - don't copy abstract registry to new thread (performance optimization)\n" + "* `:c` - don't copy cfunction registry to new thread (performance optimization)") { + janet_arity(argc, 1, 4); + Janet value = argc >= 2 ? argv[1] : janet_wrap_nil(); + if (!janet_checktype(argv[0], JANET_FUNCTION)) janet_getfiber(argv, 0); + uint64_t flags = 0; + if (argc >= 3) { + flags = janet_getflags(argv, 2, "nac"); + } + void *supervisor = janet_optabstract(argv, argc, 3, &janet_channel_type, janet_vm.root_fiber->supervisor_channel); + if (NULL != supervisor) flags |= 0x8; + /* Marshal arguments for the new thread. */ JanetBuffer *buffer = janet_malloc(sizeof(JanetBuffer)); if (NULL == buffer) { JANET_OUT_OF_MEMORY; } janet_buffer_init(buffer, 0); - janet_marshal(buffer, janet_wrap_table(janet_vm_abstract_registry), NULL, JANET_MARSHAL_UNSAFE); - janet_marshal(buffer, janet_wrap_table(janet_vm_registry), NULL, JANET_MARSHAL_UNSAFE); + if (!(flags & 0x2)) { + janet_marshal(buffer, janet_wrap_table(janet_vm.abstract_registry), NULL, JANET_MARSHAL_UNSAFE); + } + if (flags & 0x8) { + janet_marshal(buffer, janet_wrap_abstract(supervisor), NULL, JANET_MARSHAL_UNSAFE); + } + if (!(flags & 0x4)) { + janet_assert(janet_vm.registry_count <= INT32_MAX, "assert failed size check"); + uint32_t temp = (uint32_t) janet_vm.registry_count; + janet_buffer_push_bytes(buffer, (uint8_t *) &temp, sizeof(temp)); + janet_buffer_push_bytes(buffer, (uint8_t *) janet_vm.registry, (int32_t) janet_vm.registry_count * sizeof(JanetCFunRegistry)); + } janet_marshal(buffer, argv[0], NULL, JANET_MARSHAL_UNSAFE); janet_marshal(buffer, value, NULL, JANET_MARSHAL_UNSAFE); - janet_ev_threaded_await(janet_go_thread_subr, 0, argc, buffer); + if (flags & 0x1) { + /* Return immediately */ + JanetEVGenericMessage arguments; + memset(&arguments, 0, sizeof(arguments)); + arguments.tag = (uint32_t) flags; + arguments.argi = argc; + arguments.argp = buffer; + arguments.fiber = NULL; + janet_ev_threaded_call(janet_go_thread_subr, arguments, janet_ev_default_threaded_callback); + return janet_wrap_nil(); + } else { + janet_ev_threaded_await(janet_go_thread_subr, (uint32_t) flags, argc, buffer); + } } -static Janet cfun_ev_give_supervisor(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_ev_give_supervisor, + "(ev/give-supervisor tag & payload)", + "Send a message to the current supervior channel if there is one. The message will be a " + "tuple of all of the arguments combined into a single message, where the first element is tag. " + "By convention, tag should be a keyword indicating the type of message. Returns nil.") { janet_arity(argc, 1, -1); - JanetChannel *chan = janet_vm_root_fiber->supervisor_channel; - if (NULL != chan) { + void *chanv = janet_vm.root_fiber->supervisor_channel; + if (NULL != chanv) { + JanetChannel *chan = janet_channel_unwrap(chanv); if (janet_channel_push(chan, janet_wrap_tuple(janet_tuple_n(argv, argc)), 0)) { janet_await(); } @@ -2118,7 +2872,7 @@ static Janet cfun_ev_give_supervisor(int32_t argc, Janet *argv) { JANET_NO_RETURN void janet_sleep_await(double sec) { JanetTimeout to; to.when = ts_delta(ts_now(), sec); - to.fiber = janet_vm_root_fiber; + to.fiber = janet_vm.root_fiber; to.is_error = 0; to.sched_id = to.fiber->sched_id; to.curr_fiber = NULL; @@ -2126,17 +2880,24 @@ JANET_NO_RETURN void janet_sleep_await(double sec) { janet_await(); } -static Janet cfun_ev_sleep(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_ev_sleep, + "(ev/sleep sec)", + "Suspend the current fiber for sec seconds without blocking the event loop.") { janet_fixarity(argc, 1); double sec = janet_getnumber(argv, 0); janet_sleep_await(sec); } -static Janet cfun_ev_deadline(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_ev_deadline, + "(ev/deadline sec &opt tocancel tocheck)", + "Set a deadline for a fiber `tocheck`. If `tocheck` is not finished after `sec` seconds, " + "`tocancel` will be canceled as with `ev/cancel`. " + "If `tocancel` and `tocheck` are not given, they default to `(fiber/root)` and " + "`(fiber/current)` respectively. Returns `tocancel`.") { janet_arity(argc, 1, 3); double sec = janet_getnumber(argv, 0); - JanetFiber *tocancel = janet_optfiber(argv, argc, 1, janet_vm_root_fiber); - JanetFiber *tocheck = janet_optfiber(argv, argc, 2, janet_vm_fiber); + JanetFiber *tocancel = janet_optfiber(argv, argc, 1, janet_vm.root_fiber); + JanetFiber *tocheck = janet_optfiber(argv, argc, 2, janet_vm.fiber); JanetTimeout to; to.when = ts_delta(ts_now(), sec); to.fiber = tocancel; @@ -2147,7 +2908,9 @@ static Janet cfun_ev_deadline(int32_t argc, Janet *argv) { return janet_wrap_fiber(tocancel); } -static Janet cfun_ev_cancel(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_ev_cancel, + "(ev/cancel fiber err)", + "Cancel a suspended fiber in the event loop. Differs from cancel in that it returns the canceled fiber immediately.") { janet_fixarity(argc, 2); JanetFiber *fiber = janet_getfiber(argv, 0); Janet err = argv[1]; @@ -2155,14 +2918,23 @@ static Janet cfun_ev_cancel(int32_t argc, Janet *argv) { return argv[0]; } -Janet janet_cfun_stream_close(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_cfun_stream_close, + "(ev/close stream)", + "Close a stream. This should be the same as calling (:close stream) for all streams.") { janet_fixarity(argc, 1); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_close(stream); return argv[0]; } -Janet janet_cfun_stream_read(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_cfun_stream_read, + "(ev/read stream n &opt buffer timeout)", + "Read up to n bytes into a buffer asynchronously from a stream. `n` can also be the keyword " + "`:all` to read into the buffer until end of stream. " + "Optionally provide a buffer to write into " + "as well as a timeout in seconds after which to cancel the operation and raise an error. " + "Returns the buffer if the read was successful or nil if end-of-stream reached. Will raise an " + "error if there are problems with the IO operation.") { janet_arity(argc, 2, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_READABLE); @@ -2179,7 +2951,10 @@ Janet janet_cfun_stream_read(int32_t argc, Janet *argv) { janet_await(); } -Janet janet_cfun_stream_chunk(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_cfun_stream_chunk, + "(ev/chunk stream n &opt buffer timeout)", + "Same as ev/read, but will not return early if less than n bytes are available. If an end of " + "stream is reached, will also return early with the collected bytes.") { janet_arity(argc, 2, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_READABLE); @@ -2191,7 +2966,11 @@ Janet janet_cfun_stream_chunk(int32_t argc, Janet *argv) { janet_await(); } -Janet janet_cfun_stream_write(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_cfun_stream_write, + "(ev/write stream data &opt timeout)", + "Write data to a stream, suspending the current fiber until the write " + "completes. Takes an optional timeout in seconds, after which will return nil. " + "Returns nil, or raises an error if the write failed.") { janet_arity(argc, 2, 3); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_WRITABLE); @@ -2207,127 +2986,34 @@ Janet janet_cfun_stream_write(int32_t argc, Janet *argv) { janet_await(); } -static const JanetReg ev_cfuns[] = { - { - "ev/go", cfun_ev_go, - JDOC("(ev/go fiber &opt value supervisor)\n\n" - "Put a fiber on the event loop to be resumed later. Optionally pass " - "a value to resume with, otherwise resumes with nil. Returns the fiber. " - "An optional `core/channel` can be provided as well as a supervisor. When various " - "events occur in the newly scheduled fiber, an event will be pushed to the supervisor. " - "If not provided, the new fiber will inherit the current supervisor.") - }, - { - "ev/thread", cfun_ev_thread, - JDOC("(ev/thread fiber &opt value flags)\n\n" - "Resume a (copy of a) `fiber` in a new operating system thread, optionally passing `value` " - "to resume with. " - "Unlike `ev/go`, this function will suspend the current fiber until the thread is complete. " - "The the final result.") - }, - { - "ev/give-supervisor", cfun_ev_give_supervisor, - JDOC("(ev/give-supervsior tag & payload)\n\n" - "Send a message to the current supervior channel if there is one. The message will be a " - "tuple of all of the arguments combined into a single message, where the first element is tag. " - "By convention, tag should be a keyword indicating the type of message. Returns nil.") - }, - { - "ev/sleep", cfun_ev_sleep, - JDOC("(ev/sleep sec)\n\n" - "Suspend the current fiber for sec seconds without blocking the event loop.") - }, - { - "ev/deadline", cfun_ev_deadline, - JDOC("(ev/deadline sec &opt tocancel tocheck)\n\n" - "Set a deadline for a fiber `tocheck`. If `tocheck` is not finished after `sec` seconds, " - "`tocancel` will be canceled as with `ev/cancel`. " - "If `tocancel` and `tocheck` are not given, they default to `(fiber/root)` and " - "`(fiber/current)` respectively. Returns `tocancel`.") - }, - { - "ev/chan", cfun_channel_new, - JDOC("(ev/chan &opt capacity)\n\n" - "Create a new channel. capacity is the number of values to queue before " - "blocking writers, defaults to 0 if not provided. Returns a new channel.") - }, - { - "ev/give", cfun_channel_push, - JDOC("(ev/give channel value)\n\n" - "Write a value to a channel, suspending the current fiber if the channel is full.") - }, - { - "ev/take", cfun_channel_pop, - JDOC("(ev/take channel)\n\n" - "Read from a channel, suspending the current fiber if no value is available.") - }, - { - "ev/full", cfun_channel_full, - JDOC("(ev/full channel)\n\n" - "Check if a channel is full or not.") - }, - { - "ev/capacity", cfun_channel_capacity, - JDOC("(ev/capacity channel)\n\n" - "Get the number of items a channel will store before blocking writers.") - }, - { - "ev/count", cfun_channel_count, - JDOC("(ev/count channel)\n\n" - "Get the number of items currently waiting in a channel.") - }, - { - "ev/cancel", cfun_ev_cancel, - JDOC("(ev/cancel fiber err)\n\n" - "Cancel a suspended fiber in the event loop. Differs from cancel in that it returns the canceled fiber immediately") - }, - { - "ev/select", cfun_channel_choice, - JDOC("(ev/select & clauses)\n\n" - "Block until the first of several channel operations occur. Returns a tuple of the form [:give chan] or [:take chan x], where " - "a :give tuple is the result of a write and :take tuple is the result of a write. Each clause must be either a channel (for " - "a channel take operation) or a tuple [channel x] for a channel give operation. Operations are tried in order, such that the first " - "clauses will take precedence over later clauses.") - }, - { - "ev/rselect", cfun_channel_rchoice, - JDOC("(ev/rselect & clauses)\n\n" - "Similar to ev/select, but will try clauses in a random order for fairness.") - }, - { - "ev/close", janet_cfun_stream_close, - JDOC("(ev/close stream)\n\n" - "Close a stream. This should be the same as calling (:close stream) for all streams.") - }, - { - "ev/read", janet_cfun_stream_read, - JDOC("(ev/read stream n &opt buffer timeout)\n\n" - "Read up to n bytes into a buffer asynchronously from a stream. `n` can also be the keyword " - "`:all` to read into the buffer until end of stream. " - "Optionally provide a buffer to write into " - "as well as a timeout in seconds after which to cancel the operation and raise an error. " - "Returns the buffer if the read was successful or nil if end-of-stream reached. Will raise an " - "error if there are problems with the IO operation.") - }, - { - "ev/chunk", janet_cfun_stream_chunk, - JDOC("(ev/chunk stream n &opt buffer timeout)\n\n" - "Same as ev/read, but will not return early if less than n bytes are available. If an end of " - "stream is reached, will also return early with the collected bytes.") - }, - { - "ev/write", janet_cfun_stream_write, - JDOC("(ev/write stream data &opt timeout)\n\n" - "Write data to a stream, suspending the current fiber until the write " - "completes. Takes an optional timeout in seconds, after which will return nil. " - "Returns nil, or raises an error if the write failed.") - }, - {NULL, NULL, NULL} -}; - void janet_lib_ev(JanetTable *env) { - janet_core_cfuns(env, NULL, ev_cfuns); + JanetRegExt ev_cfuns_ext[] = { + JANET_CORE_REG("ev/give", cfun_channel_push), + JANET_CORE_REG("ev/take", cfun_channel_pop), + JANET_CORE_REG("ev/full", cfun_channel_full), + JANET_CORE_REG("ev/capacity", cfun_channel_capacity), + JANET_CORE_REG("ev/count", cfun_channel_count), + JANET_CORE_REG("ev/select", cfun_channel_choice), + JANET_CORE_REG("ev/rselect", cfun_channel_rchoice), + JANET_CORE_REG("ev/chan", cfun_channel_new), + JANET_CORE_REG("ev/thread-chan", cfun_channel_new_threaded), + JANET_CORE_REG("ev/chan-close", cfun_channel_close), + JANET_CORE_REG("ev/go", cfun_ev_go), + JANET_CORE_REG("ev/thread", cfun_ev_thread), + JANET_CORE_REG("ev/give-supervisor", cfun_ev_give_supervisor), + JANET_CORE_REG("ev/sleep", cfun_ev_sleep), + JANET_CORE_REG("ev/deadline", cfun_ev_deadline), + JANET_CORE_REG("ev/cancel", cfun_ev_cancel), + JANET_CORE_REG("ev/close", janet_cfun_stream_close), + JANET_CORE_REG("ev/read", janet_cfun_stream_read), + JANET_CORE_REG("ev/chunk", janet_cfun_stream_chunk), + JANET_CORE_REG("ev/write", janet_cfun_stream_write), + JANET_REG_END + }; + + janet_core_cfuns_ext(env, NULL, ev_cfuns_ext); janet_register_abstract_type(&janet_stream_type); + janet_register_abstract_type(&janet_channel_type); } #endif diff --git a/src/core/features.h b/src/core/features.h index 473660a0..363a0f99 100644 --- a/src/core/features.h +++ b/src/core/features.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/fiber.c b/src/core/fiber.c index 88a77804..31be7f11 100644 --- a/src/core/fiber.c +++ b/src/core/fiber.c @@ -57,7 +57,7 @@ static JanetFiber *fiber_alloc(int32_t capacity) { if (NULL == data) { JANET_OUT_OF_MEMORY; } - janet_vm_next_collection += sizeof(Janet) * capacity; + janet_vm.next_collection += sizeof(Janet) * capacity; fiber->data = data; return fiber; } @@ -121,7 +121,7 @@ void janet_fiber_setcapacity(JanetFiber *fiber, int32_t n) { } fiber->data = newData; fiber->capacity = n; - janet_vm_next_collection += sizeof(Janet) * diff; + janet_vm.next_collection += sizeof(Janet) * diff; } /* Grow fiber if needed */ @@ -255,7 +255,7 @@ static void janet_env_detach(JanetFuncEnv *env) { int32_t len = env->length; size_t s = sizeof(Janet) * (size_t) len; Janet *vmem = janet_malloc(s); - janet_vm_next_collection += (uint32_t) s; + janet_vm.next_collection += (uint32_t) s; if (NULL == vmem) { JANET_OUT_OF_MEMORY; } @@ -442,16 +442,19 @@ JanetFiberStatus janet_fiber_status(JanetFiber *f) { } JanetFiber *janet_current_fiber(void) { - return janet_vm_fiber; + return janet_vm.fiber; } JanetFiber *janet_root_fiber(void) { - return janet_vm_root_fiber; + return janet_vm.root_fiber; } /* CFuns */ -static Janet cfun_fiber_getenv(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_getenv, + "(fiber/getenv fiber)", + "Gets the environment for a fiber. Returns nil if no such table is " + "set yet.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); return fiber->env ? @@ -459,7 +462,10 @@ static Janet cfun_fiber_getenv(int32_t argc, Janet *argv) { janet_wrap_nil(); } -static Janet cfun_fiber_setenv(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_setenv, + "(fiber/setenv fiber table)", + "Sets the environment table for a fiber. Set to nil to remove the current " + "environment.") { janet_fixarity(argc, 2); JanetFiber *fiber = janet_getfiber(argv, 0); if (janet_checktype(argv[1], JANET_NIL)) { @@ -470,7 +476,30 @@ static Janet cfun_fiber_setenv(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_fiber_new(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_new, + "(fiber/new func &opt sigmask)", + "Create a new fiber with function body func. Can optionally " + "take a set of signals to block from the current parent fiber " + "when called. The mask is specified as a keyword where each character " + "is used to indicate a signal to block. If the ev module is enabled, and " + "this fiber is used as an argument to `ev/go`, these \"blocked\" signals " + "will result in messages being sent to the supervisor channel. " + "The default sigmask is :y. " + "For example,\n\n" + " (fiber/new myfun :e123)\n\n" + "blocks error signals and user signals 1, 2 and 3. The signals are " + "as follows:\n\n" + "* :a - block all signals\n" + "* :d - block debug signals\n" + "* :e - block error signals\n" + "* :t - block termination signals: error + user[0-4]\n" + "* :u - block user signals\n" + "* :y - block yield signals\n" + "* :0-9 - block a specific user signal\n\n" + "The sigmask argument also can take environment flags. If any mutually " + "exclusive flags are present, the last flag takes precedence.\n\n" + "* :i - inherit the environment from the current fiber\n" + "* :p - the environment table's prototype is the current environment table") { janet_arity(argc, 1, 2); JanetFunction *func = janet_getfunction(argv, 0); JanetFiber *fiber; @@ -520,17 +549,17 @@ static Janet cfun_fiber_new(int32_t argc, Janet *argv) { fiber->flags |= JANET_FIBER_MASK_YIELD; break; case 'i': - if (!janet_vm_fiber->env) { - janet_vm_fiber->env = janet_table(0); + if (!janet_vm.fiber->env) { + janet_vm.fiber->env = janet_table(0); } - fiber->env = janet_vm_fiber->env; + fiber->env = janet_vm.fiber->env; break; case 'p': - if (!janet_vm_fiber->env) { - janet_vm_fiber->env = janet_table(0); + if (!janet_vm.fiber->env) { + janet_vm.fiber->env = janet_table(0); } fiber->env = janet_table(0); - fiber->env->proto = janet_vm_fiber->env; + fiber->env->proto = janet_vm.fiber->env; break; } } @@ -539,32 +568,53 @@ static Janet cfun_fiber_new(int32_t argc, Janet *argv) { return janet_wrap_fiber(fiber); } -static Janet cfun_fiber_status(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_status, + "(fiber/status fib)", + "Get the status of a fiber. The status will be one of:\n\n" + "* :dead - the fiber has finished\n" + "* :error - the fiber has errored out\n" + "* :debug - the fiber is suspended in debug mode\n" + "* :pending - the fiber has been yielded\n" + "* :user(0-9) - the fiber is suspended by a user signal\n" + "* :alive - the fiber is currently running and cannot be resumed\n" + "* :new - the fiber has just been created and not yet run") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); uint32_t s = janet_fiber_status(fiber); return janet_ckeywordv(janet_status_names[s]); } -static Janet cfun_fiber_current(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_current, + "(fiber/current)", + "Returns the currently running fiber.") { (void) argv; janet_fixarity(argc, 0); - return janet_wrap_fiber(janet_vm_fiber); + return janet_wrap_fiber(janet_vm.fiber); } -static Janet cfun_fiber_root(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_root, + "(fiber/root)", + "Returns the current root fiber. The root fiber is the oldest ancestor " + "that does not have a parent.") { (void) argv; janet_fixarity(argc, 0); - return janet_wrap_fiber(janet_vm_root_fiber); + return janet_wrap_fiber(janet_vm.root_fiber); } -static Janet cfun_fiber_maxstack(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_maxstack, + "(fiber/maxstack fib)", + "Gets the maximum stack size in janet values allowed for a fiber. While memory for " + "the fiber's stack is not allocated up front, the fiber will not allocated more " + "than this amount and will throw a stack-overflow error if more memory is needed. ") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); return janet_wrap_integer(fiber->maxstack); } -static Janet cfun_fiber_setmaxstack(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_setmaxstack, + "(fiber/setmaxstack fib maxstack)", + "Sets the maximum stack size in janet values for a fiber. By default, the " + "maximum stack size is usually 8192.") { janet_fixarity(argc, 2); JanetFiber *fiber = janet_getfiber(argv, 0); int32_t maxs = janet_getinteger(argv, 1); @@ -575,7 +625,9 @@ static Janet cfun_fiber_setmaxstack(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_fiber_can_resume(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_can_resume, + "(fiber/can-resume? fiber)", + "Check if a fiber is finished and cannot be resumed.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); JanetFiberStatus s = janet_fiber_status(fiber); @@ -589,101 +641,28 @@ static Janet cfun_fiber_can_resume(int32_t argc, Janet *argv) { return janet_wrap_boolean(!isFinished); } -static Janet cfun_fiber_last_value(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_fiber_last_value, + "(fiber/last-value)", + "Get the last value returned or signaled from the fiber.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); return fiber->last_value; } -static const JanetReg fiber_cfuns[] = { - { - "fiber/new", cfun_fiber_new, - JDOC("(fiber/new func &opt sigmask)\n\n" - "Create a new fiber with function body func. Can optionally " - "take a set of signals to block from the current parent fiber " - "when called. The mask is specified as a keyword where each character " - "is used to indicate a signal to block. If the ev module is enabled, and " - "this fiber is used as an argument to `ev/go`, these \"blocked\" signals " - "will result in messages being sent to the supervisor channel. " - "The default sigmask is :y. " - "For example,\n\n" - " (fiber/new myfun :e123)\n\n" - "blocks error signals and user signals 1, 2 and 3. The signals are " - "as follows:\n\n" - "* :a - block all signals\n" - "* :d - block debug signals\n" - "* :e - block error signals\n" - "* :t - block termination signals: error + user[0-4]\n" - "* :u - block user signals\n" - "* :y - block yield signals\n" - "* :0-9 - block a specific user signal\n\n" - "The sigmask argument also can take environment flags. If any mutually " - "exclusive flags are present, the last flag takes precedence.\n\n" - "* :i - inherit the environment from the current fiber\n" - "* :p - the environment table's prototype is the current environment table") - }, - { - "fiber/status", cfun_fiber_status, - JDOC("(fiber/status fib)\n\n" - "Get the status of a fiber. The status will be one of:\n\n" - "* :dead - the fiber has finished\n" - "* :error - the fiber has errored out\n" - "* :debug - the fiber is suspended in debug mode\n" - "* :pending - the fiber has been yielded\n" - "* :user(0-9) - the fiber is suspended by a user signal\n" - "* :alive - the fiber is currently running and cannot be resumed\n" - "* :new - the fiber has just been created and not yet run") - }, - { - "fiber/root", cfun_fiber_root, - JDOC("(fiber/root)\n\n" - "Returns the current root fiber. The root fiber is the oldest ancestor " - "that does not have a parent.") - }, - { - "fiber/current", cfun_fiber_current, - JDOC("(fiber/current)\n\n" - "Returns the currently running fiber.") - }, - { - "fiber/maxstack", cfun_fiber_maxstack, - JDOC("(fiber/maxstack fib)\n\n" - "Gets the maximum stack size in janet values allowed for a fiber. While memory for " - "the fiber's stack is not allocated up front, the fiber will not allocated more " - "than this amount and will throw a stack-overflow error if more memory is needed. ") - }, - { - "fiber/setmaxstack", cfun_fiber_setmaxstack, - JDOC("(fiber/setmaxstack fib maxstack)\n\n" - "Sets the maximum stack size in janet values for a fiber. By default, the " - "maximum stack size is usually 8192.") - }, - { - "fiber/getenv", cfun_fiber_getenv, - JDOC("(fiber/getenv fiber)\n\n" - "Gets the environment for a fiber. Returns nil if no such table is " - "set yet.") - }, - { - "fiber/setenv", cfun_fiber_setenv, - JDOC("(fiber/setenv fiber table)\n\n" - "Sets the environment table for a fiber. Set to nil to remove the current " - "environment.") - }, - { - "fiber/can-resume?", cfun_fiber_can_resume, - JDOC("(fiber/can-resume? fiber)\n\n" - "Check if a fiber is finished and cannot be resumed.") - }, - { - "fiber/last-value", cfun_fiber_last_value, - JDOC("(fiber/last-value\n\n" - "Get the last value returned or signaled from the fiber.") - }, - {NULL, NULL, NULL} -}; - /* Module entry point */ void janet_lib_fiber(JanetTable *env) { - janet_core_cfuns(env, NULL, fiber_cfuns); + JanetRegExt fiber_cfuns[] = { + JANET_CORE_REG("fiber/new", cfun_fiber_new), + JANET_CORE_REG("fiber/status", cfun_fiber_status), + JANET_CORE_REG("fiber/root", cfun_fiber_root), + JANET_CORE_REG("fiber/current", cfun_fiber_current), + JANET_CORE_REG("fiber/maxstack", cfun_fiber_maxstack), + JANET_CORE_REG("fiber/setmaxstack", cfun_fiber_setmaxstack), + JANET_CORE_REG("fiber/getenv", cfun_fiber_getenv), + JANET_CORE_REG("fiber/setenv", cfun_fiber_setenv), + JANET_CORE_REG("fiber/can-resume?", cfun_fiber_can_resume), + JANET_CORE_REG("fiber/last-value", cfun_fiber_last_value), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, fiber_cfuns); } diff --git a/src/core/fiber.h b/src/core/fiber.h index 2df10c79..b6dcd1ba 100644 --- a/src/core/fiber.h +++ b/src/core/fiber.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -47,7 +47,6 @@ #define JANET_FIBER_MASK_USER 0x3FF0 #define JANET_FIBER_STATUS_MASK 0x3F0000 -#define JANET_FIBER_FLAG_SCHEDULED 0x800000 #define JANET_FIBER_RESUME_SIGNAL 0x400000 #define JANET_FIBER_STATUS_OFFSET 16 @@ -57,8 +56,6 @@ #define JANET_FIBER_DID_LONGJUMP 0x8000000 #define JANET_FIBER_FLAG_MASK 0xF000000 -extern JANET_THREAD_LOCAL JanetFiber *janet_vm_fiber; - #define janet_fiber_set_status(f, s) do {\ (f)->flags &= ~JANET_FIBER_STATUS_MASK;\ (f)->flags |= (s) << JANET_FIBER_STATUS_OFFSET;\ diff --git a/src/core/gc.c b/src/core/gc.c index e666fff9..a36c5ce8 100644 --- a/src/core/gc.c +++ b/src/core/gc.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -31,28 +31,6 @@ #include "vector.h" #endif -struct JanetScratch { - JanetScratchFinalizer finalize; - long long mem[]; /* for proper alignment */ -}; - -/* GC State */ -JANET_THREAD_LOCAL void *janet_vm_blocks; -JANET_THREAD_LOCAL size_t janet_vm_gc_interval; -JANET_THREAD_LOCAL size_t janet_vm_next_collection; -JANET_THREAD_LOCAL size_t janet_vm_block_count; -JANET_THREAD_LOCAL int janet_vm_gc_suspend = 0; - -/* Roots */ -JANET_THREAD_LOCAL Janet *janet_vm_roots; -JANET_THREAD_LOCAL size_t janet_vm_root_count; -JANET_THREAD_LOCAL size_t janet_vm_root_capacity; - -/* Scratch Memory */ -JANET_THREAD_LOCAL JanetScratch **janet_scratch_mem; -JANET_THREAD_LOCAL size_t janet_scratch_cap; -JANET_THREAD_LOCAL size_t janet_scratch_len; - /* Helpers for marking the various gc types */ static void janet_mark_funcenv(JanetFuncEnv *env); static void janet_mark_funcdef(JanetFuncDef *def); @@ -72,7 +50,7 @@ static JANET_THREAD_LOCAL size_t orig_rootcount; /* Hint to the GC that we may need to collect */ void janet_gcpressure(size_t s) { - janet_vm_next_collection += s; + janet_vm.next_collection += s; } /* Mark a value */ @@ -127,6 +105,14 @@ static void janet_mark_buffer(JanetBuffer *buffer) { } static void janet_mark_abstract(void *adata) { +#ifdef JANET_EV + /* Check if abstract type is a threaded abstract type. If it is, marking means + * updating the threaded_abstract table. */ + if ((janet_abstract_head(adata)->gc.flags & JANET_MEM_TYPEBITS) == JANET_MEMORY_THREADED_ABSTRACT) { + janet_table_put(&janet_vm.threaded_abstracts, janet_wrap_abstract(adata), janet_wrap_true()); + return; + } +#endif if (janet_gc_reachable(janet_abstract_head(adata))) return; janet_gc_mark(janet_abstract_head(adata)); @@ -137,6 +123,8 @@ static void janet_mark_abstract(void *adata) { /* Mark a bunch of items in memory */ static void janet_mark_many(const Janet *values, int32_t n) { + if (values == NULL) + return; const Janet *end = values + n; while (values < end) { janet_mark(*values); @@ -174,10 +162,13 @@ recur: /* Manual tail recursion */ } static void janet_mark_struct(const JanetKV *st) { +recur: if (janet_gc_reachable(janet_struct_head(st))) return; janet_gc_mark(janet_struct_head(st)); janet_mark_kvs(st, janet_struct_capacity(st)); + st = janet_struct_proto(st); + if (st) goto recur; } static void janet_mark_tuple(const Janet *tuple) { @@ -332,25 +323,61 @@ static void janet_deinit_block(JanetGCObject *mem) { * marked as reachable. Flip the gc color flag for next sweep. */ void janet_sweep() { JanetGCObject *previous = NULL; - JanetGCObject *current = janet_vm_blocks; + JanetGCObject *current = janet_vm.blocks; JanetGCObject *next; while (NULL != current) { - next = current->next; + next = current->data.next; if (current->flags & (JANET_MEM_REACHABLE | JANET_MEM_DISABLED)) { previous = current; current->flags &= ~JANET_MEM_REACHABLE; } else { - janet_vm_block_count--; + janet_vm.block_count--; janet_deinit_block(current); if (NULL != previous) { - previous->next = next; + previous->data.next = next; } else { - janet_vm_blocks = next; + janet_vm.blocks = next; } janet_free(current); } current = next; } +#ifdef JANET_EV + /* Sweep threaded abstract types for references to decrement */ + JanetKV *items = janet_vm.threaded_abstracts.data; + for (int32_t i = 0; i < janet_vm.threaded_abstracts.capacity; i++) { + if (janet_checktype(items[i].key, JANET_ABSTRACT)) { + + /* If item was not visited during the mark phase, then this + * abstract type isn't present in the heap and needs its refcount + * decremented, and shouuld be removed from table. If the refcount is + * then 0, the item will be collected. This ensures that only one interpreter + * will clean up the threaded abstract. */ + + /* If not visited... */ + if (!janet_truthy(items[i].value)) { + void *abst = janet_unwrap_abstract(items[i].key); + if (0 == janet_abstract_decref(abst)) { + /* Run finalizer */ + JanetAbstractHead *head = janet_abstract_head(abst); + if (head->type->gc) { + janet_assert(!head->type->gc(head->data, head->size), "finalizer failed"); + } + /* Mark as tombstone in place */ + items[i].key = janet_wrap_nil(); + items[i].value = janet_wrap_false(); + janet_vm.threaded_abstracts.deleted++; + janet_vm.threaded_abstracts.count--; + /* Free memory */ + janet_free(janet_abstract_head(abst)); + } + } + + /* Reset for next sweep */ + items[i].value = janet_wrap_false(); + } + } +#endif } /* Allocate some memory that is tracked for garbage collection */ @@ -358,7 +385,7 @@ void *janet_gcalloc(enum JanetMemoryType type, size_t size) { JanetGCObject *mem; /* Make sure everything is inited */ - janet_assert(NULL != janet_vm_cache, "please initialize janet before use"); + janet_assert(NULL != janet_vm.cache, "please initialize janet before use"); mem = janet_malloc(size); /* Check for bad malloc */ @@ -370,10 +397,10 @@ void *janet_gcalloc(enum JanetMemoryType type, size_t size) { mem->flags = type; /* Prepend block to heap list */ - janet_vm_next_collection += size; - mem->next = janet_vm_blocks; - janet_vm_blocks = mem; - janet_vm_block_count++; + janet_vm.next_collection += size; + mem->data.next = janet_vm.blocks; + janet_vm.blocks = mem; + janet_vm.block_count++; return (void *)mem; } @@ -387,10 +414,10 @@ static void free_one_scratch(JanetScratch *s) { /* Free all allocated scratch memory */ static void janet_free_all_scratch(void) { - for (size_t i = 0; i < janet_scratch_len; i++) { - free_one_scratch(janet_scratch_mem[i]); + for (size_t i = 0; i < janet_vm.scratch_len; i++) { + free_one_scratch(janet_vm.scratch_mem[i]); } - janet_scratch_len = 0; + janet_vm.scratch_len = 0; } static JanetScratch *janet_mem2scratch(void *mem) { @@ -401,29 +428,29 @@ static JanetScratch *janet_mem2scratch(void *mem) { /* Run garbage collection */ void janet_collect(void) { uint32_t i; - if (janet_vm_gc_suspend) return; + if (janet_vm.gc_suspend) return; depth = JANET_RECURSION_GUARD; /* Try and prevent many major collections back to back. - * A full collection will take O(janet_vm_block_count) time. + * A full collection will take O(janet_vm.block_count) time. * If we have a large heap, make sure our interval is not too * small so we won't make many collections over it. This is just a * heuristic for automatically changing the gc interval */ - if (janet_vm_block_count * 8 > janet_vm_gc_interval) { - janet_vm_gc_interval = janet_vm_block_count * sizeof(JanetGCObject); + if (janet_vm.block_count * 8 > janet_vm.gc_interval) { + janet_vm.gc_interval = janet_vm.block_count * sizeof(JanetGCObject); } - orig_rootcount = janet_vm_root_count; + orig_rootcount = janet_vm.root_count; #ifdef JANET_EV janet_ev_mark(); #endif - janet_mark_fiber(janet_vm_root_fiber); + janet_mark_fiber(janet_vm.root_fiber); for (i = 0; i < orig_rootcount; i++) - janet_mark(janet_vm_roots[i]); - while (orig_rootcount < janet_vm_root_count) { - Janet x = janet_vm_roots[--janet_vm_root_count]; + janet_mark(janet_vm.roots[i]); + while (orig_rootcount < janet_vm.root_count) { + Janet x = janet_vm.roots[--janet_vm.root_count]; janet_mark(x); } janet_sweep(); - janet_vm_next_collection = 0; + janet_vm.next_collection = 0; janet_free_all_scratch(); } @@ -431,17 +458,17 @@ void janet_collect(void) { * and all of its children. If gcroot is called on a value n times, unroot * must also be called n times to remove it as a gc root. */ void janet_gcroot(Janet root) { - size_t newcount = janet_vm_root_count + 1; - if (newcount > janet_vm_root_capacity) { + size_t newcount = janet_vm.root_count + 1; + if (newcount > janet_vm.root_capacity) { size_t newcap = 2 * newcount; - janet_vm_roots = janet_realloc(janet_vm_roots, sizeof(Janet) * newcap); - if (NULL == janet_vm_roots) { + janet_vm.roots = janet_realloc(janet_vm.roots, sizeof(Janet) * newcap); + if (NULL == janet_vm.roots) { JANET_OUT_OF_MEMORY; } - janet_vm_root_capacity = newcap; + janet_vm.root_capacity = newcap; } - janet_vm_roots[janet_vm_root_count] = root; - janet_vm_root_count = newcount; + janet_vm.roots[janet_vm.root_count] = root; + janet_vm.root_count = newcount; } /* Identity equality for GC purposes */ @@ -462,11 +489,11 @@ static int janet_gc_idequals(Janet lhs, Janet rhs) { /* Remove a root value from the GC. This allows the gc to potentially reclaim * a value and all its children. */ int janet_gcunroot(Janet root) { - Janet *vtop = janet_vm_roots + janet_vm_root_count; + Janet *vtop = janet_vm.roots + janet_vm.root_count; /* Search from top to bottom as access is most likely LIFO */ - for (Janet *v = janet_vm_roots; v < vtop; v++) { + for (Janet *v = janet_vm.roots; v < vtop; v++) { if (janet_gc_idequals(root, *v)) { - *v = janet_vm_roots[--janet_vm_root_count]; + *v = janet_vm.roots[--janet_vm.root_count]; return 1; } } @@ -475,12 +502,12 @@ int janet_gcunroot(Janet root) { /* Remove a root value from the GC. This sets the effective reference count to 0. */ int janet_gcunrootall(Janet root) { - Janet *vtop = janet_vm_roots + janet_vm_root_count; + Janet *vtop = janet_vm.roots + janet_vm.root_count; int ret = 0; /* Search from top to bottom as access is most likely LIFO */ - for (Janet *v = janet_vm_roots; v < vtop; v++) { + for (Janet *v = janet_vm.roots; v < vtop; v++) { if (janet_gc_idequals(root, *v)) { - *v = janet_vm_roots[--janet_vm_root_count]; + *v = janet_vm.roots[--janet_vm.root_count]; vtop--; ret = 1; } @@ -490,24 +517,39 @@ int janet_gcunrootall(Janet root) { /* Free all allocated memory */ void janet_clear_memory(void) { - JanetGCObject *current = janet_vm_blocks; +#ifdef JANET_EV + JanetKV *items = janet_vm.threaded_abstracts.data; + for (int32_t i = 0; i < janet_vm.threaded_abstracts.capacity; i++) { + if (janet_checktype(items[i].key, JANET_ABSTRACT)) { + void *abst = janet_unwrap_abstract(items[i].key); + if (0 == janet_abstract_decref(abst)) { + JanetAbstractHead *head = janet_abstract_head(abst); + if (head->type->gc) { + janet_assert(!head->type->gc(head->data, head->size), "finalizer failed"); + } + janet_free(janet_abstract_head(abst)); + } + } + } +#endif + JanetGCObject *current = janet_vm.blocks; while (NULL != current) { janet_deinit_block(current); - JanetGCObject *next = current->next; + JanetGCObject *next = current->data.next; janet_free(current); current = next; } - janet_vm_blocks = NULL; + janet_vm.blocks = NULL; janet_free_all_scratch(); - janet_free(janet_scratch_mem); + janet_free(janet_vm.scratch_mem); } /* Primitives for suspending GC. */ int janet_gclock(void) { - return janet_vm_gc_suspend++; + return janet_vm.gc_suspend++; } void janet_gcunlock(int handle) { - janet_vm_gc_suspend = handle; + janet_vm.gc_suspend = handle; } /* Scratch memory API */ @@ -518,16 +560,16 @@ void *janet_smalloc(size_t size) { JANET_OUT_OF_MEMORY; } s->finalize = NULL; - if (janet_scratch_len == janet_scratch_cap) { - size_t newcap = 2 * janet_scratch_cap + 2; - JanetScratch **newmem = (JanetScratch **) janet_realloc(janet_scratch_mem, newcap * sizeof(JanetScratch)); + if (janet_vm.scratch_len == janet_vm.scratch_cap) { + size_t newcap = 2 * janet_vm.scratch_cap + 2; + JanetScratch **newmem = (JanetScratch **) janet_realloc(janet_vm.scratch_mem, newcap * sizeof(JanetScratch)); if (NULL == newmem) { JANET_OUT_OF_MEMORY; } - janet_scratch_cap = newcap; - janet_scratch_mem = newmem; + janet_vm.scratch_cap = newcap; + janet_vm.scratch_mem = newmem; } - janet_scratch_mem[janet_scratch_len++] = s; + janet_vm.scratch_mem[janet_vm.scratch_len++] = s; return (char *)(s->mem); } @@ -544,14 +586,14 @@ void *janet_scalloc(size_t nmemb, size_t size) { void *janet_srealloc(void *mem, size_t size) { if (NULL == mem) return janet_smalloc(size); JanetScratch *s = janet_mem2scratch(mem); - if (janet_scratch_len) { - for (size_t i = janet_scratch_len - 1; ; i--) { - if (janet_scratch_mem[i] == s) { + if (janet_vm.scratch_len) { + for (size_t i = janet_vm.scratch_len - 1; ; i--) { + if (janet_vm.scratch_mem[i] == s) { JanetScratch *news = janet_realloc(s, size + sizeof(JanetScratch)); if (NULL == news) { JANET_OUT_OF_MEMORY; } - janet_scratch_mem[i] = news; + janet_vm.scratch_mem[i] = news; return (char *)(news->mem); } if (i == 0) break; @@ -568,10 +610,10 @@ void janet_sfinalizer(void *mem, JanetScratchFinalizer finalizer) { void janet_sfree(void *mem) { if (NULL == mem) return; JanetScratch *s = janet_mem2scratch(mem); - if (janet_scratch_len) { - for (size_t i = janet_scratch_len - 1; ; i--) { - if (janet_scratch_mem[i] == s) { - janet_scratch_mem[i] = janet_scratch_mem[--janet_scratch_len]; + if (janet_vm.scratch_len) { + for (size_t i = janet_vm.scratch_len - 1; ; i--) { + if (janet_vm.scratch_mem[i] == s) { + janet_vm.scratch_mem[i] = janet_vm.scratch_mem[--janet_vm.scratch_len]; free_one_scratch(s); return; } diff --git a/src/core/gc.h b/src/core/gc.h index 29b47332..7fd23122 100644 --- a/src/core/gc.h +++ b/src/core/gc.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -55,10 +55,11 @@ enum JanetMemoryType { JANET_MEMORY_FUNCTION, JANET_MEMORY_ABSTRACT, JANET_MEMORY_FUNCENV, - JANET_MEMORY_FUNCDEF + JANET_MEMORY_FUNCDEF, + JANET_MEMORY_THREADED_ABSTRACT, }; -/* To allocate collectable memory, one must calk janet_alloc, initialize the memory, +/* To allocate collectable memory, one must call janet_alloc, initialize the memory, * and then call when janet_enablegc when it is initailize and reachable by the gc (on the JANET stack) */ void *janet_gcalloc(enum JanetMemoryType type, size_t size); diff --git a/src/core/inttypes.c b/src/core/inttypes.c index 59cd4899..8cee9e67 100644 --- a/src/core/inttypes.c +++ b/src/core/inttypes.c @@ -193,12 +193,16 @@ Janet janet_wrap_u64(uint64_t x) { return janet_wrap_abstract(box); } -static Janet cfun_it_s64_new(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_it_s64_new, + "(int/s64 value)", + "Create a boxed signed 64 bit integer from a string value.") { janet_fixarity(argc, 1); return janet_wrap_s64(janet_unwrap_s64(argv[0])); } -static Janet cfun_it_u64_new(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_it_u64_new, + "(int/u64 value)", + "Create a boxed unsigned 64 bit integer from a string value.") { janet_fixarity(argc, 1); return janet_wrap_u64(janet_unwrap_u64(argv[0])); } @@ -505,23 +509,14 @@ static int it_u64_get(void *p, Janet key, Janet *out) { return janet_getmethod(janet_unwrap_keyword(key), it_u64_methods, out); } -static const JanetReg it_cfuns[] = { - { - "int/s64", cfun_it_s64_new, - JDOC("(int/s64 value)\n\n" - "Create a boxed signed 64 bit integer from a string value.") - }, - { - "int/u64", cfun_it_u64_new, - JDOC("(int/u64 value)\n\n" - "Create a boxed unsigned 64 bit integer from a string value.") - }, - {NULL, NULL, NULL} -}; - /* Module entry point */ void janet_lib_inttypes(JanetTable *env) { - janet_core_cfuns(env, NULL, it_cfuns); + JanetRegExt it_cfuns[] = { + JANET_CORE_REG("int/s64", cfun_it_s64_new), + JANET_CORE_REG("int/u64", cfun_it_u64_new), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, it_cfuns); janet_register_abstract_type(&janet_s64_type); janet_register_abstract_type(&janet_u64_type); } diff --git a/src/core/io.c b/src/core/io.c index 8b718051..0295b115 100644 --- a/src/core/io.c +++ b/src/core/io.c @@ -114,7 +114,12 @@ static void *makef(FILE *f, int32_t flags) { /* Open a process */ #ifndef JANET_NO_PROCESSES -static Janet cfun_io_popen(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_popen, + "(file/popen command &opt mode) (DEPRECATED for os/spawn)", + "Open a file that is backed by a process. The file must be opened in either " + "the :r (read) or the :w (write) mode. In :r mode, the stdout of the " + "process can be read from the file. In :w mode, the stdin of the process " + "can be written to. Returns the new file.") { janet_arity(argc, 1, 2); const uint8_t *fname = janet_getstring(argv, 0); const uint8_t *fmode = NULL; @@ -143,7 +148,10 @@ static Janet cfun_io_popen(int32_t argc, Janet *argv) { } #endif -static Janet cfun_io_temp(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_temp, + "(file/temp)", + "Open an anonymous temporary file that is removed on close. " + "Raises an error on failure.") { (void)argv; janet_fixarity(argc, 0); // XXX use mkostemp when we can to avoid CLOEXEC race. @@ -153,7 +161,20 @@ static Janet cfun_io_temp(int32_t argc, Janet *argv) { return janet_makefile(tmp, JANET_FILE_WRITE | JANET_FILE_READ | JANET_FILE_BINARY); } -static Janet cfun_io_fopen(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_fopen, + "(file/open path &opt mode)", + "Open a file. `path` is an absolute or relative path, and " + "`mode` is a set of flags indicating the mode to open the file in. " + "`mode` is a keyword where each character represents a flag. If the file " + "cannot be opened, returns nil, otherwise returns the new file handle. " + "Mode flags:\n\n" + "* r - allow reading from the file\n\n" + "* w - allow writing to the file\n\n" + "* a - append to the file\n\n" + "Following one of the initial flags, 0 or more of the following flags can be appended:\n\n" + "* b - open the file in binary mode (rather than text mode)\n\n" + "* + - append to the file instead of overwriting it\n\n" + "* n - error if the file cannot be opened instead of returning nil") { janet_arity(argc, 1, 2); const uint8_t *fname = janet_getstring(argv, 0); const uint8_t *fmode; @@ -184,7 +205,16 @@ static void read_chunk(JanetFile *iof, JanetBuffer *buffer, int32_t nBytesMax) { } /* Read a certain number of bytes into memory */ -static Janet cfun_io_fread(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_fread, + "(file/read f what &opt buf)", + "Read a number of bytes from a file `f` into a buffer. A buffer `buf` can " + "be provided as an optional third argument, otherwise a new buffer " + "is created. `what` can either be an integer or a keyword. Returns the " + "buffer with file contents. " + "Values for `what`:\n\n" + "* :all - read the whole file\n\n" + "* :line - read up to and including the next newline character\n\n" + "* n (integer) - read up to n bytes from the file") { janet_arity(argc, 2, 3); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) janet_panic("file is closed"); @@ -224,7 +254,10 @@ static Janet cfun_io_fread(int32_t argc, Janet *argv) { } /* Write bytes to a file */ -static Janet cfun_io_fwrite(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_fwrite, + "(file/write f bytes)", + "Writes to a file. 'bytes' must be string, buffer, or symbol. Returns the " + "file.") { janet_arity(argc, 1, -1); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) @@ -247,7 +280,10 @@ static Janet cfun_io_fwrite(int32_t argc, Janet *argv) { } /* Flush the bytes in the file */ -static Janet cfun_io_fflush(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_fflush, + "(file/flush f)", + "Flush any buffered bytes to the file system. In most files, writes are " + "buffered for efficiency reasons. Returns the file handle.") { janet_fixarity(argc, 1); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) @@ -291,7 +327,12 @@ static int cfun_io_gc(void *p, size_t len) { } /* Close a file */ -static Janet cfun_io_fclose(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_fclose, + "(file/close f)", + "Close a file and release all related resources. When you are " + "done reading a file, close it to prevent a resource leak and let " + "other processes read the file. If the file is the result of a file/popen " + "call, close waits for and returns the process exit status.") { janet_fixarity(argc, 1); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) @@ -318,7 +359,15 @@ static Janet cfun_io_fclose(int32_t argc, Janet *argv) { } /* Seek a file */ -static Janet cfun_io_fseek(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_fseek, + "(file/seek f &opt whence n)", + "Jump to a relative location in the file `f`. `whence` must be one of:\n\n" + "* :cur - jump relative to the current file location\n\n" + "* :set - jump relative to the beginning of the file\n\n" + "* :end - jump relative to the end of the file\n\n" + "By default, `whence` is :cur. Optionally a value `n` may be passed " + "for the relative number of bytes to seek in the file. `n` may be a real " + "number to handle large files of more than 4GB. Returns the file handle.") { janet_arity(argc, 2, 3); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) @@ -480,28 +529,47 @@ static Janet cfun_io_print_impl(int32_t argc, Janet *argv, return cfun_io_print_impl_x(argc, argv, newline, dflt_file, 0, x); } -static Janet cfun_io_print(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_print, + "(print & xs)", + "Print values to the console (standard out). Value are converted " + "to strings if they are not already. After printing all values, a " + "newline character is printed. Use the value of (dyn :out stdout) to determine " + "what to push characters to. Expects (dyn :out stdout) to be either a core/file or " + "a buffer. Returns nil.") { return cfun_io_print_impl(argc, argv, 1, "out", stdout); } -static Janet cfun_io_prin(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_prin, + "(prin & xs)", + "Same as print, but does not add trailing newline.") { return cfun_io_print_impl(argc, argv, 0, "out", stdout); } -static Janet cfun_io_eprint(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_eprint, + "(eprint & xs)", + "Same as print, but uses (dyn :err stderr) instead of (dyn :out stdout).") { return cfun_io_print_impl(argc, argv, 1, "err", stderr); } -static Janet cfun_io_eprin(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_eprin, + "(eprin & xs)", + "Same as prin, but uses (dyn :err stderr) instead of (dyn :out stdout).") { return cfun_io_print_impl(argc, argv, 0, "err", stderr); } -static Janet cfun_io_xprint(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_xprint, + "(xprint to & xs)", + "Print to a file or other value explicitly (no dynamic bindings) with a trailing " + "newline character. The value to print " + "to is the first argument, and is otherwise the same as print. Returns nil.") { janet_arity(argc, 1, -1); return cfun_io_print_impl_x(argc, argv, 1, NULL, 1, argv[0]); } -static Janet cfun_io_xprin(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_xprin, + "(xprin to & xs)", + "Print to a file or other value explicitly (no dynamic bindings). The value to print " + "to is the first argument, and is otherwise the same as prin. Returns nil.") { janet_arity(argc, 1, -1); return cfun_io_print_impl_x(argc, argv, 0, NULL, 1, argv[0]); } @@ -557,28 +625,40 @@ static Janet cfun_io_printf_impl(int32_t argc, Janet *argv, int newline, } -static Janet cfun_io_printf(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_printf, + "(printf fmt & xs)", + "Prints output formatted as if with (string/format fmt ;xs) to (dyn :out stdout) with a trailing newline.") { return cfun_io_printf_impl(argc, argv, 1, "out", stdout); } -static Janet cfun_io_prinf(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_prinf, + "(prinf fmt & xs)", + "Like printf but with no trailing newline.") { return cfun_io_printf_impl(argc, argv, 0, "out", stdout); } -static Janet cfun_io_eprintf(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_eprintf, + "(eprintf fmt & xs)", + "Prints output formatted as if with (string/format fmt ;xs) to (dyn :err stderr) with a trailing newline.") { return cfun_io_printf_impl(argc, argv, 1, "err", stderr); } -static Janet cfun_io_eprinf(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_eprinf, + "(eprinf fmt & xs)", + "Like eprintf but with no trailing newline.") { return cfun_io_printf_impl(argc, argv, 0, "err", stderr); } -static Janet cfun_io_xprintf(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_xprintf, + "(xprintf to fmt & xs)", + "Like printf but prints to an explicit file or value to. Returns nil.") { janet_arity(argc, 2, -1); return cfun_io_printf_impl_x(argc, argv, 1, NULL, 1, argv[0]); } -static Janet cfun_io_xprinf(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_xprinf, + "(xprinf to fmt & xs)", + "Like prinf but prints to an explicit file or value to. Returns nil.") { janet_arity(argc, 2, -1); return cfun_io_printf_impl_x(argc, argv, 0, NULL, 1, argv[0]); } @@ -601,14 +681,18 @@ static void janet_flusher(const char *name, FILE *dflt_file) { } } -static Janet cfun_io_flush(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_flush, + "(flush)", + "Flush (dyn :out stdout) if it is a file, otherwise do nothing.") { janet_fixarity(argc, 0); (void) argv; janet_flusher("out", stdout); return janet_wrap_nil(); } -static Janet cfun_io_eflush(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_io_eflush, + "(eflush)", + "Flush (dyn :err stderr) if it is a file, otherwise do nothing.") { janet_fixarity(argc, 0); (void) argv; janet_flusher("err", stderr); @@ -651,162 +735,6 @@ void janet_dynprintf(const char *name, FILE *dflt_file, const char *format, ...) return; } -static const JanetReg io_cfuns[] = { - { - "print", cfun_io_print, - JDOC("(print & xs)\n\n" - "Print values to the console (standard out). Value are converted " - "to strings if they are not already. After printing all values, a " - "newline character is printed. Use the value of (dyn :out stdout) to determine " - "what to push characters to. Expects (dyn :out stdout) to be either a core/file or " - "a buffer. Returns nil.") - }, - { - "prin", cfun_io_prin, - JDOC("(prin & xs)\n\n" - "Same as print, but does not add trailing newline.") - }, - { - "printf", cfun_io_printf, - JDOC("(printf fmt & xs)\n\n" - "Prints output formatted as if with (string/format fmt ;xs) to (dyn :out stdout) with a trailing newline.") - }, - { - "prinf", cfun_io_prinf, - JDOC("(prinf fmt & xs)\n\n" - "Like printf but with no trailing newline.") - }, - { - "eprin", cfun_io_eprin, - JDOC("(eprin & xs)\n\n" - "Same as prin, but uses (dyn :err stderr) instead of (dyn :out stdout).") - }, - { - "eprint", cfun_io_eprint, - JDOC("(eprint & xs)\n\n" - "Same as print, but uses (dyn :err stderr) instead of (dyn :out stdout).") - }, - { - "eprintf", cfun_io_eprintf, - JDOC("(eprintf fmt & xs)\n\n" - "Prints output formatted as if with (string/format fmt ;xs) to (dyn :err stderr) with a trailing newline.") - }, - { - "eprinf", cfun_io_eprinf, - JDOC("(eprinf fmt & xs)\n\n" - "Like eprintf but with no trailing newline.") - }, - { - "xprint", cfun_io_xprint, - JDOC("(xprint to & xs)\n\n" - "Print to a file or other value explicitly (no dynamic bindings) with a trailing " - "newline character. The value to print " - "to is the first argument, and is otherwise the same as print. Returns nil.") - }, - { - "xprin", cfun_io_xprin, - JDOC("(xprin to & xs)\n\n" - "Print to a file or other value explicitly (no dynamic bindings). The value to print " - "to is the first argument, and is otherwise the same as prin. Returns nil.") - }, - { - "xprintf", cfun_io_xprintf, - JDOC("(xprint to fmt & xs)\n\n" - "Like printf but prints to an explicit file or value to. Returns nil.") - }, - { - "xprinf", cfun_io_xprinf, - JDOC("(xprin to fmt & xs)\n\n" - "Like prinf but prints to an explicit file or value to. Returns nil.") - }, - { - "flush", cfun_io_flush, - JDOC("(flush)\n\n" - "Flush (dyn :out stdout) if it is a file, otherwise do nothing.") - }, - { - "eflush", cfun_io_eflush, - JDOC("(eflush)\n\n" - "Flush (dyn :err stderr) if it is a file, otherwise do nothing.") - }, - { - "file/temp", cfun_io_temp, - JDOC("(file/temp)\n\n" - "Open an anonymous temporary file that is removed on close. " - "Raises an error on failure.") - }, - { - "file/open", cfun_io_fopen, - JDOC("(file/open path &opt mode)\n\n" - "Open a file. `path` is an absolute or relative path, and " - "`mode` is a set of flags indicating the mode to open the file in. " - "`mode` is a keyword where each character represents a flag. If the file " - "cannot be opened, returns nil, otherwise returns the new file handle. " - "Mode flags:\n\n" - "* r - allow reading from the file\n\n" - "* w - allow writing to the file\n\n" - "* a - append to the file\n\n" - "Following one of the initial flags, 0 or more of the following flags can be appended:\n\n" - "* b - open the file in binary mode (rather than text mode)\n\n" - "* + - append to the file instead of overwriting it\n\n" - "* n - error if the file cannot be opened instead of returning nil") - }, - { - "file/close", cfun_io_fclose, - JDOC("(file/close f)\n\n" - "Close a file and release all related resources. When you are " - "done reading a file, close it to prevent a resource leak and let " - "other processes read the file. If the file is the result of a file/popen " - "call, close waits for and returns the process exit status.") - }, - { - "file/read", cfun_io_fread, - JDOC("(file/read f what &opt buf)\n\n" - "Read a number of bytes from a file `f` into a buffer. A buffer `buf` can " - "be provided as an optional third argument, otherwise a new buffer " - "is created. `what` can either be an integer or a keyword. Returns the " - "buffer with file contents. " - "Values for `what`:\n\n" - "* :all - read the whole file\n\n" - "* :line - read up to and including the next newline character\n\n" - "* n (integer) - read up to n bytes from the file") - }, - { - "file/write", cfun_io_fwrite, - JDOC("(file/write f bytes)\n\n" - "Writes to a file. 'bytes' must be string, buffer, or symbol. Returns the " - "file.") - }, - { - "file/flush", cfun_io_fflush, - JDOC("(file/flush f)\n\n" - "Flush any buffered bytes to the file system. In most files, writes are " - "buffered for efficiency reasons. Returns the file handle.") - }, - { - "file/seek", cfun_io_fseek, - JDOC("(file/seek f &opt whence n)\n\n" - "Jump to a relative location in the file `f`. `whence` must be one of:\n\n" - "* :cur - jump relative to the current file location\n\n" - "* :set - jump relative to the beginning of the file\n\n" - "* :end - jump relative to the end of the file\n\n" - "By default, `whence` is :cur. Optionally a value `n` may be passed " - "for the relative number of bytes to seek in the file. `n` may be a real " - "number to handle large files of more than 4GB. Returns the file handle.") - }, -#ifndef JANET_NO_PROCESSES - { - "file/popen", cfun_io_popen, - JDOC("(file/popen command &opt mode) (DEPRECATED for os/spawn)\n\n" - "Open a file that is backed by a process. The file must be opened in either " - "the :r (read) or the :w (write) mode. In :r mode, the stdout of the " - "process can be read from the file. In :w mode, the stdin of the process " - "can be written to. Returns the new file.") - }, -#endif - {NULL, NULL, NULL} -}; - /* C API */ JanetFile *janet_getjfile(const Janet *argv, int32_t n) { @@ -839,20 +767,47 @@ FILE *janet_unwrapfile(Janet j, int *flags) { /* Module entry point */ void janet_lib_io(JanetTable *env) { - janet_core_cfuns(env, NULL, io_cfuns); + JanetRegExt io_cfuns[] = { + JANET_CORE_REG("print", cfun_io_print), + JANET_CORE_REG("prin", cfun_io_prin), + JANET_CORE_REG("printf", cfun_io_printf), + JANET_CORE_REG("prinf", cfun_io_prinf), + JANET_CORE_REG("eprin", cfun_io_eprin), + JANET_CORE_REG("eprint", cfun_io_eprint), + JANET_CORE_REG("eprintf", cfun_io_eprintf), + JANET_CORE_REG("eprinf", cfun_io_eprinf), + JANET_CORE_REG("xprint", cfun_io_xprint), + JANET_CORE_REG("xprin", cfun_io_xprin), + JANET_CORE_REG("xprintf", cfun_io_xprintf), + JANET_CORE_REG("xprinf", cfun_io_xprinf), + JANET_CORE_REG("flush", cfun_io_flush), + JANET_CORE_REG("eflush", cfun_io_eflush), + JANET_CORE_REG("file/temp", cfun_io_temp), + JANET_CORE_REG("file/open", cfun_io_fopen), + JANET_CORE_REG("file/close", cfun_io_fclose), + JANET_CORE_REG("file/read", cfun_io_fread), + JANET_CORE_REG("file/write", cfun_io_fwrite), + JANET_CORE_REG("file/flush", cfun_io_fflush), + JANET_CORE_REG("file/seek", cfun_io_fseek), +#ifndef JANET_NO_PROCESSES + JANET_CORE_REG("file/popen", cfun_io_popen), +#endif + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, io_cfuns); janet_register_abstract_type(&janet_file_type); int default_flags = JANET_FILE_NOT_CLOSEABLE | JANET_FILE_SERIALIZABLE; /* stdout */ - janet_core_def(env, "stdout", + JANET_CORE_DEF(env, "stdout", janet_makefile(stdout, JANET_FILE_APPEND | default_flags), - JDOC("The standard output file.")); + "The standard output file."); /* stderr */ - janet_core_def(env, "stderr", + JANET_CORE_DEF(env, "stderr", janet_makefile(stderr, JANET_FILE_APPEND | default_flags), - JDOC("The standard error file.")); + "The standard error file."); /* stdin */ - janet_core_def(env, "stdin", + JANET_CORE_DEF(env, "stdin", janet_makefile(stdin, JANET_FILE_READ | default_flags), - JDOC("The standard input file.")); + "The standard input file."); } diff --git a/src/core/marsh.c b/src/core/marsh.c index 7fd441c9..f9fee515 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -65,6 +65,9 @@ enum { LB_UNSAFE_CFUNCTION, /* 221 */ LB_UNSAFE_POINTER, /* 222 */ LB_STRUCT_PROTO, /* 223 */ +#ifdef JANET_EV + LB_THREADED_ABSTRACT/* 224 */ +#endif } LeadBytes; /* Helper to look inside an entry in an environment */ @@ -326,6 +329,7 @@ static void marshal_one_fiber(MarshalState *st, JanetFiber *fiber, int flags) { } if (fiber->child) marshal_one(st, janet_wrap_fiber(fiber->child), flags + 1); + marshal_one(st, fiber->last_value, flags + 1); } void janet_marshal_size(JanetMarshalContext *ctx, size_t value) { @@ -370,6 +374,21 @@ void janet_marshal_abstract(JanetMarshalContext *ctx, void *abstract) { static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { void *abstract = janet_unwrap_abstract(x); +#ifdef JANET_EV + /* Threaded abstract types get passed through as pointers in the unsafe mode */ + if ((flags & JANET_MARSHAL_UNSAFE) && + (JANET_MEMORY_THREADED_ABSTRACT == (janet_abstract_head(abstract)->gc.flags & JANET_MEM_TYPEBITS))) { + + /* Increment refcount before sending message. This prevents a "death in transit" problem + * where a message is garbage collected while in transit between two threads - i.e., the sending threads + * loses the reference and runs a garbage collection before the receiving thread gets the message. */ + janet_abstract_incref(abstract); + pushbyte(st, LB_THREADED_ABSTRACT); + pushbytes(st, (uint8_t *) &abstract, sizeof(abstract)); + MARK_SEEN(); + return; + } +#endif const JanetAbstractType *at = janet_abstract_type(abstract); if (at->marshal) { pushbyte(st, LB_ABSTRACT); @@ -377,7 +396,7 @@ static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { JanetMarshalContext context = {st, NULL, flags, NULL, at}; at->marshal(abstract, &context); } else { - janet_panicf("try to marshal unregistered abstract type, cannot marshal %p", x); + janet_panicf("cannot marshal %p", x); } } @@ -545,9 +564,9 @@ static void marshal_one(MarshalState *st, Janet x, int flags) { case JANET_FUNCTION: { pushbyte(st, LB_FUNCTION); JanetFunction *func = janet_unwrap_function(x); + pushint(st, func->def->environments_length); /* Mark seen before reading def */ MARK_SEEN(); - pushint(st, func->def->environments_length); marshal_one_def(st, func->def, flags); for (int32_t i = 0; i < func->def->environments_length; i++) marshal_one_env(st, func->envs[i], flags + 1); @@ -938,6 +957,7 @@ static const uint8_t *unmarshal_one_fiber( fiber->data = NULL; fiber->child = NULL; fiber->env = NULL; + fiber->last_value = janet_wrap_nil(); #ifdef JANET_EV fiber->waiting = NULL; fiber->sched_id = 0; @@ -1049,6 +1069,9 @@ static const uint8_t *unmarshal_one_fiber( fiber->child = janet_unwrap_fiber(fiberv); } + /* Get the fiber last value */ + data = unmarshal_one(st, data, &fiber->last_value, flags + 1); + /* We have valid fiber, finally construct remaining fields. */ fiber->frame = frame; fiber->flags = fiber_flags; @@ -1106,14 +1129,18 @@ Janet janet_unmarshal_janet(JanetMarshalContext *ctx) { return ret; } -void *janet_unmarshal_abstract(JanetMarshalContext *ctx, size_t size) { +void janet_unmarshal_abstract_reuse(JanetMarshalContext *ctx, void *p) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); if (ctx->at == NULL) { janet_panicf("janet_unmarshal_abstract called more than once"); } - void *p = janet_abstract(ctx->at, size); janet_v_push(st->lookup, janet_wrap_abstract(p)); ctx->at = NULL; +} + +void *janet_unmarshal_abstract(JanetMarshalContext *ctx, size_t size) { + void *p = janet_abstract(ctx->at, size); + janet_unmarshal_abstract_reuse(ctx, p); return p; } @@ -1121,17 +1148,16 @@ static const uint8_t *unmarshal_one_abstract(UnmarshalState *st, const uint8_t * Janet key; data = unmarshal_one(st, data, &key, flags + 1); const JanetAbstractType *at = janet_get_abstract_type(key); - if (at == NULL) goto oops; + if (at == NULL) janet_panic("unknown abstract type"); if (at->unmarshal) { JanetMarshalContext context = {NULL, st, flags, data, at}; *out = janet_wrap_abstract(at->unmarshal(&context)); if (context.at != NULL) { - janet_panicf("janet_unmarshal_abstract not called"); + janet_panic("janet_unmarshal_abstract not called"); } return context.data; } -oops: - janet_panic("invalid abstract type"); + janet_panic("invalid abstract type - no unmarshal function pointer"); } static const uint8_t *unmarshal_one( @@ -1236,18 +1262,16 @@ static const uint8_t *unmarshal_one( data++; int32_t len = readnat(st, &data); if (len > 255) { - janet_panicf("invalid function"); + janet_panicf("invalid function - too many environments (%d)", len); } func = janet_gcalloc(JANET_MEMORY_FUNCTION, sizeof(JanetFunction) + len * sizeof(JanetFuncEnv)); + func->def = NULL; *out = janet_wrap_function(func); janet_v_push(st->lookup, *out); data = unmarshal_one_def(st, data, &def, flags + 1); - if (def->environments_length != len) { - janet_panicf("invalid function"); - } func->def = def; - for (int32_t i = 0; i < def->environments_length; i++) { + for (int32_t i = 0; i < len; i++) { data = unmarshal_one_env(st, data, &(func->envs[i]), flags + 1); } return data; @@ -1367,6 +1391,42 @@ static const uint8_t *unmarshal_one( janet_v_push(st->lookup, *out); return data; } +#ifdef JANET_EV + case LB_THREADED_ABSTRACT: { + MARSH_EOS(st, data + sizeof(void *)); + data++; + if (!(flags & JANET_MARSHAL_UNSAFE)) { + janet_panicf("unsafe flag not given, " + "will not unmarshal threaded abstract pointer at index %d", + (int)(data - st->start)); + } + union { + void *ptr; + uint8_t bytes[sizeof(void *)]; + } u; + memcpy(u.bytes, data, sizeof(void *)); + data += sizeof(void *); + + if (flags & JANET_MARSHAL_DECREF) { + /* Decrement immediately and don't bother putting into heap */ + janet_abstract_decref(u.ptr); + *out = janet_wrap_nil(); + } else { + *out = janet_wrap_abstract(u.ptr); + Janet check = janet_table_get(&janet_vm.threaded_abstracts, *out); + if (janet_checktype(check, JANET_NIL)) { + /* Transfers reference from threaded channel buffer to current heap */ + janet_table_put(&janet_vm.threaded_abstracts, *out, janet_wrap_false()); + } else { + /* Heap reference already accounted for, remove threaded channel reference. */ + janet_abstract_decref(u.ptr); + } + } + + janet_v_push(st->lookup, *out); + return data; + } +#endif default: { janet_panicf("unknown byte %x at index %d", *data, @@ -1374,7 +1434,6 @@ static const uint8_t *unmarshal_one( return NULL; } } -#undef EXTRA } Janet janet_unmarshal( @@ -1401,13 +1460,24 @@ Janet janet_unmarshal( /* C functions */ -static Janet cfun_env_lookup(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_env_lookup, + "(env-lookup env)", + "Creates a forward lookup table for unmarshalling from an environment. " + "To create a reverse lookup table, use the invert function to swap keys " + "and values in the returned table.") { janet_fixarity(argc, 1); JanetTable *env = janet_gettable(argv, 0); return janet_wrap_table(janet_env_lookup(env)); } -static Janet cfun_marshal(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_marshal, + "(marshal x &opt reverse-lookup buffer)", + "Marshal a value into a buffer and return the buffer. The buffer " + "can then later be unmarshalled to reconstruct the initial value. " + "Optionally, one can pass in a reverse lookup table to not marshal " + "aliased values that are found in the table. Then a forward " + "lookup table can be used to recover the original value when " + "unmarshalling.") { janet_arity(argc, 1, 3); JanetBuffer *buffer; JanetTable *rreg = NULL; @@ -1423,7 +1493,11 @@ static Janet cfun_marshal(int32_t argc, Janet *argv) { return janet_wrap_buffer(buffer); } -static Janet cfun_unmarshal(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_unmarshal, + "(unmarshal buffer &opt lookup)", + "Unmarshal a value from a buffer. An optional lookup table " + "can be provided to allow for aliases to be resolved. Returns the value " + "unmarshalled from the buffer.") { janet_arity(argc, 1, 2); JanetByteView view = janet_getbytes(argv, 0); JanetTable *reg = NULL; @@ -1433,35 +1507,13 @@ static Janet cfun_unmarshal(int32_t argc, Janet *argv) { return janet_unmarshal(view.bytes, (size_t) view.len, 0, reg, NULL); } -static const JanetReg marsh_cfuns[] = { - { - "marshal", cfun_marshal, - JDOC("(marshal x &opt reverse-lookup buffer)\n\n" - "Marshal a value into a buffer and return the buffer. The buffer " - "can then later be unmarshalled to reconstruct the initial value. " - "Optionally, one can pass in a reverse lookup table to not marshal " - "aliased values that are found in the table. Then a forward " - "lookup table can be used to recover the original value when " - "unmarshalling.") - }, - { - "unmarshal", cfun_unmarshal, - JDOC("(unmarshal buffer &opt lookup)\n\n" - "Unmarshal a value from a buffer. An optional lookup table " - "can be provided to allow for aliases to be resolved. Returns the value " - "unmarshalled from the buffer.") - }, - { - "env-lookup", cfun_env_lookup, - JDOC("(env-lookup env)\n\n" - "Creates a forward lookup table for unmarshalling from an environment. " - "To create a reverse lookup table, use the invert function to swap keys " - "and values in the returned table.") - }, - {NULL, NULL, NULL} -}; - /* Module entry point */ void janet_lib_marsh(JanetTable *env) { - janet_core_cfuns(env, NULL, marsh_cfuns); + JanetRegExt marsh_cfuns[] = { + JANET_CORE_REG("marshal", cfun_marshal), + JANET_CORE_REG("unmarshal", cfun_unmarshal), + JANET_CORE_REG("env-lookup", cfun_env_lookup), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, marsh_cfuns); } diff --git a/src/core/math.c b/src/core/math.c index 18a4affe..ce6a61fe 100644 --- a/src/core/math.c +++ b/src/core/math.c @@ -23,13 +23,12 @@ #ifndef JANET_AMALG #include "features.h" #include +#include "state.h" #include "util.h" #endif #include -static JANET_THREAD_LOCAL JanetRNG janet_vm_rng = {0, 0, 0, 0, 0}; - static int janet_rng_get(void *p, Janet key, Janet *out); static Janet janet_rng_next(void *p, Janet key); @@ -69,7 +68,7 @@ const JanetAbstractType janet_rng_type = { }; JanetRNG *janet_default_rng(void) { - return &janet_vm_rng; + return &janet_vm.rng; } void janet_rng_seed(JanetRNG *rng, uint32_t seed) { @@ -118,7 +117,12 @@ double janet_rng_double(JanetRNG *rng) { return ldexp((double)(big >> (64 - 52)), -52); } -static Janet cfun_rng_make(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_rng_make, + "(math/rng &opt seed)", + "Creates a Psuedo-Random number generator, with an optional seed. " + "The seed should be an unsigned 32 bit integer or a buffer. " + "Do not use this for cryptography. Returns a core/rng abstract type." + ) { janet_arity(argc, 0, 1); JanetRNG *rng = janet_abstract(&janet_rng_type, sizeof(JanetRNG)); if (argc == 1) { @@ -135,13 +139,20 @@ static Janet cfun_rng_make(int32_t argc, Janet *argv) { return janet_wrap_abstract(rng); } -static Janet cfun_rng_uniform(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_rng_uniform, + "(math/rng-uniform rng)", + "Extract a random number in the range [0, 1) from the RNG." + ) { janet_fixarity(argc, 1); JanetRNG *rng = janet_getabstract(argv, 0, &janet_rng_type); return janet_wrap_number(janet_rng_double(rng)); } -static Janet cfun_rng_int(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_rng_int, + "(math/rng-int rng &opt max)", + "Extract a random random integer in the range [0, max] from the RNG. If " + "no max is given, the default is 2^31 - 1." + ) { janet_arity(argc, 1, 2); JanetRNG *rng = janet_getabstract(argv, 0, &janet_rng_type); if (argc == 1) { @@ -169,7 +180,11 @@ static void rng_get_4bytes(JanetRNG *rng, uint8_t *buf) { buf[3] = (word >> 24) & 0xFF; } -static Janet cfun_rng_buffer(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_rng_buffer, + "(math/rng-buffer rng n &opt buf)", + "Get n random bytes and put them in a buffer. Creates a new buffer if no buffer is " + "provided, otherwise appends to the given buffer. Returns the buffer." + ) { janet_arity(argc, 2, 3); JanetRNG *rng = janet_getabstract(argv, 0, &janet_rng_type); int32_t n = janet_getnat(argv, 1); @@ -214,314 +229,193 @@ static Janet janet_rng_next(void *p, Janet key) { } /* Get a random number */ -static Janet janet_rand(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_rand, + "(math/random)", + "Returns a uniformly distributed random number between 0 and 1") { (void) argv; janet_fixarity(argc, 0); - return janet_wrap_number(janet_rng_double(&janet_vm_rng)); + return janet_wrap_number(janet_rng_double(&janet_vm.rng)); } /* Seed the random number generator */ -static Janet janet_srand(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_srand, + "(math/seedrandom seed)", + "Set the seed for the random number generator. seed should be " + "an integer or a buffer." + ) { janet_fixarity(argc, 1); if (janet_checkint(argv[0])) { uint32_t seed = (uint32_t)(janet_getinteger(argv, 0)); - janet_rng_seed(&janet_vm_rng, seed); + janet_rng_seed(&janet_vm.rng, seed); } else { JanetByteView bytes = janet_getbytes(argv, 0); - janet_rng_longseed(&janet_vm_rng, bytes.bytes, bytes.len); + janet_rng_longseed(&janet_vm.rng, bytes.bytes, bytes.len); } return janet_wrap_nil(); } -#define JANET_DEFINE_MATHOP(name, fop)\ -static Janet janet_##name(int32_t argc, Janet *argv) {\ +#define JANET_DEFINE_MATHOP(name, fop, doc)\ +JANET_CORE_FN(janet_##name, "(math/" #name " x)", doc) {\ janet_fixarity(argc, 1); \ double x = janet_getnumber(argv, 0); \ return janet_wrap_number(fop(x)); \ } -JANET_DEFINE_MATHOP(acos, acos) -JANET_DEFINE_MATHOP(asin, asin) -JANET_DEFINE_MATHOP(atan, atan) -JANET_DEFINE_MATHOP(cos, cos) -JANET_DEFINE_MATHOP(cosh, cosh) -JANET_DEFINE_MATHOP(acosh, acosh) -JANET_DEFINE_MATHOP(sin, sin) -JANET_DEFINE_MATHOP(sinh, sinh) -JANET_DEFINE_MATHOP(asinh, asinh) -JANET_DEFINE_MATHOP(tan, tan) -JANET_DEFINE_MATHOP(tanh, tanh) -JANET_DEFINE_MATHOP(atanh, atanh) -JANET_DEFINE_MATHOP(exp, exp) -JANET_DEFINE_MATHOP(exp2, exp2) -JANET_DEFINE_MATHOP(expm1, expm1) -JANET_DEFINE_MATHOP(log, log) -JANET_DEFINE_MATHOP(log10, log10) -JANET_DEFINE_MATHOP(log2, log2) -JANET_DEFINE_MATHOP(sqrt, sqrt) -JANET_DEFINE_MATHOP(cbrt, cbrt) -JANET_DEFINE_MATHOP(ceil, ceil) -JANET_DEFINE_MATHOP(fabs, fabs) -JANET_DEFINE_MATHOP(floor, floor) -JANET_DEFINE_MATHOP(trunc, trunc) -JANET_DEFINE_MATHOP(round, round) -JANET_DEFINE_MATHOP(gamma, lgamma) -JANET_DEFINE_MATHOP(log1p, log1p) -JANET_DEFINE_MATHOP(erf, erf) -JANET_DEFINE_MATHOP(erfc, erfc) +JANET_DEFINE_MATHOP(acos, acos, "Returns the arccosize of x.") +JANET_DEFINE_MATHOP(asin, asin, "Returns the arcsin of x.") +JANET_DEFINE_MATHOP(atan, atan, "Returns the arctangent of x.") +JANET_DEFINE_MATHOP(cos, cos, "Returns the cosine of x.") +JANET_DEFINE_MATHOP(cosh, cosh, "Returns the hyperbolic cosine of x.") +JANET_DEFINE_MATHOP(acosh, acosh, "Returns the hyperbolic arccosine of x.") +JANET_DEFINE_MATHOP(sin, sin, "Returns the sine of x.") +JANET_DEFINE_MATHOP(sinh, sinh, "Returns the hyperbolic sine of x.") +JANET_DEFINE_MATHOP(asinh, asinh, "Returns the hypberbolic arcsine of x.") +JANET_DEFINE_MATHOP(tan, tan, "Returns the tangent of x.") +JANET_DEFINE_MATHOP(tanh, tanh, "Returns the hyperbolic tangent of x.") +JANET_DEFINE_MATHOP(atanh, atanh, "Returns the hyperbolic arctangent of x.") +JANET_DEFINE_MATHOP(exp, exp, "Returns e to the power of x.") +JANET_DEFINE_MATHOP(exp2, exp2, "Returns 2 to the power of x.") +JANET_DEFINE_MATHOP(expm1, expm1, "Returns e to the power of x minus 1.") +JANET_DEFINE_MATHOP(log, log, "Returns the natural logarithm of x.") +JANET_DEFINE_MATHOP(log10, log10, "Returns the log base 10 of x.") +JANET_DEFINE_MATHOP(log2, log2, "Returns the log base 2 of x.") +JANET_DEFINE_MATHOP(sqrt, sqrt, "Returns the square root of x.") +JANET_DEFINE_MATHOP(cbrt, cbrt, "Returns the cube root of x.") +JANET_DEFINE_MATHOP(ceil, ceil, "Returns the smallest integer value number that is not less than x.") +JANET_DEFINE_MATHOP(fabs, fabs, "Return the absolute value of x.") +JANET_DEFINE_MATHOP(floor, floor, "Returns the largest integer value number that is not greater than x.") +JANET_DEFINE_MATHOP(trunc, trunc, "Returns the integer between x and 0 nearest to x.") +JANET_DEFINE_MATHOP(round, round, "Returns the integer nearest to x.") +JANET_DEFINE_MATHOP(gamma, lgamma, "Returns gamma(x).") +JANET_DEFINE_MATHOP(log1p, log1p, "Returns (log base e of x) + 1 more accurately than (+ (math/log x) 1)") +JANET_DEFINE_MATHOP(erf, erf, "Returns the error function of x.") +JANET_DEFINE_MATHOP(erfc, erfc, "Returns the complementary error function of x.") -#define JANET_DEFINE_MATH2OP(name, fop)\ -static Janet janet_##name(int32_t argc, Janet *argv) {\ +#define JANET_DEFINE_MATH2OP(name, fop, signature, doc)\ +JANET_CORE_FN(janet_##name, signature, doc) {\ janet_fixarity(argc, 2); \ double lhs = janet_getnumber(argv, 0); \ double rhs = janet_getnumber(argv, 1); \ return janet_wrap_number(fop(lhs, rhs)); \ -}\ +} -JANET_DEFINE_MATH2OP(atan2, atan2) -JANET_DEFINE_MATH2OP(pow, pow) -JANET_DEFINE_MATH2OP(hypot, hypot) -JANET_DEFINE_MATH2OP(nextafter, nextafter) +JANET_DEFINE_MATH2OP(atan2, atan2, "(math/atan2 y x)", "Returns the arctangent of y/x. Works even when x is 0.") +JANET_DEFINE_MATH2OP(pow, pow, "(math/pow a x)", "Returns a to the power of x.") +JANET_DEFINE_MATH2OP(hypot, hypot, "(math/hypot a b)", "Returns c from the equation c^2 = a^2 + b^2.") +JANET_DEFINE_MATH2OP(nextafter, nextafter, "(math/next x y)", "Returns the next representable floating point vaue after x in the direction of y.") -static Janet janet_not(int32_t argc, Janet *argv) { +JANET_CORE_FN(janet_not, "(not x)", "Returns the boolean inverse of x.") { janet_fixarity(argc, 1); return janet_wrap_boolean(!janet_truthy(argv[0])); } -static const JanetReg math_cfuns[] = { - { - "not", janet_not, - JDOC("(not x)\n\nReturns the boolean inverse of x.") - }, - { - "math/random", janet_rand, - JDOC("(math/random)\n\n" - "Returns a uniformly distributed random number between 0 and 1.") - }, - { - "math/seedrandom", janet_srand, - JDOC("(math/seedrandom seed)\n\n" - "Set the seed for the random number generator. seed should be " - "an integer or a buffer.") - }, - { - "math/cos", janet_cos, - JDOC("(math/cos x)\n\n" - "Returns the cosine of x.") - }, - { - "math/sin", janet_sin, - JDOC("(math/sin x)\n\n" - "Returns the sine of x.") - }, - { - "math/tan", janet_tan, - JDOC("(math/tan x)\n\n" - "Returns the tangent of x.") - }, - { - "math/acos", janet_acos, - JDOC("(math/acos x)\n\n" - "Returns the arccosine of x.") - }, - { - "math/asin", janet_asin, - JDOC("(math/asin x)\n\n" - "Returns the arcsine of x.") - }, - { - "math/atan", janet_atan, - JDOC("(math/atan x)\n\n" - "Returns the arctangent of x.") - }, - { - "math/exp", janet_exp, - JDOC("(math/exp x)\n\n" - "Returns e to the power of x.") - }, - { - "math/log", janet_log, - JDOC("(math/log x)\n\n" - "Returns log base natural number of x.") - }, - { - "math/log10", janet_log10, - JDOC("(math/log10 x)\n\n" - "Returns log base 10 of x.") - }, - { - "math/log2", janet_log2, - JDOC("(math/log2 x)\n\n" - "Returns log base 2 of x.") - }, - { - "math/sqrt", janet_sqrt, - JDOC("(math/sqrt x)\n\n" - "Returns the square root of x.") - }, - { - "math/cbrt", janet_cbrt, - JDOC("(math/cbrt x)\n\n" - "Returns the cube root of x.") - }, - { - "math/floor", janet_floor, - JDOC("(math/floor x)\n\n" - "Returns the largest integer value number that is not greater than x.") - }, - { - "math/ceil", janet_ceil, - JDOC("(math/ceil x)\n\n" - "Returns the smallest integer value number that is not less than x.") - }, - { - "math/pow", janet_pow, - JDOC("(math/pow a x)\n\n" - "Return a to the power of x.") - }, - { - "math/abs", janet_fabs, - JDOC("(math/abs x)\n\n" - "Return the absolute value of x.") - }, - { - "math/sinh", janet_sinh, - JDOC("(math/sinh x)\n\n" - "Return the hyperbolic sine of x.") - }, - { - "math/cosh", janet_cosh, - JDOC("(math/cosh x)\n\n" - "Return the hyperbolic cosine of x.") - }, - { - "math/tanh", janet_tanh, - JDOC("(math/tanh x)\n\n" - "Return the hyperbolic tangent of x.") - }, - { - "math/atanh", janet_atanh, - JDOC("(math/atanh x)\n\n" - "Return the hyperbolic arctangent of x.") - }, - { - "math/asinh", janet_asinh, - JDOC("(math/asinh x)\n\n" - "Return the hyperbolic arcsine of x.") - }, - { - "math/acosh", janet_acosh, - JDOC("(math/acosh x)\n\n" - "Return the hyperbolic arccosine of x.") - }, - { - "math/atan2", janet_atan2, - JDOC("(math/atan2 y x)\n\n" - "Return the arctangent of y/x. Works even when x is 0.") - }, - { - "math/rng", cfun_rng_make, - JDOC("(math/rng &opt seed)\n\n" - "Creates a Psuedo-Random number generator, with an optional seed. " - "The seed should be an unsigned 32 bit integer or a buffer. " - "Do not use this for cryptography. Returns a core/rng abstract type.") - }, - { - "math/rng-uniform", cfun_rng_uniform, - JDOC("(math/rng-seed rng seed)\n\n" - "Extract a random number in the range [0, 1) from the RNG.") - }, - { - "math/rng-int", cfun_rng_int, - JDOC("(math/rng-int rng &opt max)\n\n" - "Extract a random random integer in the range [0, max] from the RNG. If " - "no max is given, the default is 2^31 - 1.") - }, - { - "math/rng-buffer", cfun_rng_buffer, - JDOC("(math/rng-buffer rng n &opt buf)\n\n" - "Get n random bytes and put them in a buffer. Creates a new buffer if no buffer is " - "provided, otherwise appends to the given buffer. Returns the buffer.") - }, - { - "math/hypot", janet_hypot, - JDOC("(math/hypot a b)\n\n" - "Returns the c from the equation c^2 = a^2 + b^2") - }, - { - "math/exp2", janet_exp2, - JDOC("(math/exp2 x)\n\n" - "Returns 2 to the power of x.") - }, - { - "math/log1p", janet_log1p, - JDOC("(math/log1p x)\n\n" - "Returns (log base e of x) + 1 more accurately than (+ (math/log x) 1)") - }, - { - "math/gamma", janet_gamma, - JDOC("(math/gamma x)\n\n" - "Returns gamma(x).") - }, - { - "math/erfc", janet_erfc, - JDOC("(math/erfc x)\n\n" - "Returns the complementary error function of x.") - }, - { - "math/erf", janet_erf, - JDOC("(math/erf x)\n\n" - "Returns the error function of x.") - }, - { - "math/expm1", janet_expm1, - JDOC("(math/expm1 x)\n\n" - "Returns e to the power of x minus 1.") - }, - { - "math/trunc", janet_trunc, - JDOC("(math/trunc x)\n\n" - "Returns the integer between x and 0 nearest to x.") - }, - { - "math/round", janet_round, - JDOC("(math/round x)\n\n" - "Returns the integer nearest to x.") - }, - { - "math/next", janet_nextafter, - JDOC("(math/next x y)\n\n" - "Returns the next representable floating point value after x in the direction of y.") - }, - {NULL, NULL, NULL} -}; +static double janet_gcd(double x, double y) { + if (isnan(x) || isnan(y)) { +#ifdef NAN + return NAN; +#else + return 0.0 \ 0.0; +#endif + } + if (isinf(x) || isinf(y)) return INFINITY; + while (y != 0) { + double temp = y; + y = fmod(x, y); + x = temp; + } + return x; +} + +static double janet_lcm(double x, double y) { + return (x / janet_gcd(x, y)) * y; +} + +JANET_CORE_FN(janet_cfun_gcd, "(math/gcd x y)", + "Returns the greatest common divisor between x and y.") { + janet_fixarity(argc, 2); + double x = janet_getnumber(argv, 0); + double y = janet_getnumber(argv, 1); + return janet_wrap_number(janet_gcd(x, y)); +} + +JANET_CORE_FN(janet_cfun_lcm, "(math/lcm x y)", + "Returns the least common multiple of x and y.") { + janet_fixarity(argc, 2); + double x = janet_getnumber(argv, 0); + double y = janet_getnumber(argv, 1); + return janet_wrap_number(janet_lcm(x, y)); +} /* Module entry point */ void janet_lib_math(JanetTable *env) { - janet_core_cfuns(env, NULL, math_cfuns); + JanetRegExt math_cfuns[] = { + JANET_CORE_REG("not", janet_not), + JANET_CORE_REG("math/random", janet_rand), + JANET_CORE_REG("math/seedrandom", janet_srand), + JANET_CORE_REG("math/cos", janet_cos), + JANET_CORE_REG("math/sin", janet_sin), + JANET_CORE_REG("math/tan", janet_tan), + JANET_CORE_REG("math/acos", janet_acos), + JANET_CORE_REG("math/asin", janet_asin), + JANET_CORE_REG("math/atan", janet_atan), + JANET_CORE_REG("math/exp", janet_exp), + JANET_CORE_REG("math/log", janet_log), + JANET_CORE_REG("math/log10", janet_log10), + JANET_CORE_REG("math/log2", janet_log2), + JANET_CORE_REG("math/sqrt", janet_sqrt), + JANET_CORE_REG("math/cbrt", janet_cbrt), + JANET_CORE_REG("math/floor", janet_floor), + JANET_CORE_REG("math/ceil", janet_ceil), + JANET_CORE_REG("math/pow", janet_pow), + JANET_CORE_REG("math/abs", janet_fabs), + JANET_CORE_REG("math/sinh", janet_sinh), + JANET_CORE_REG("math/cosh", janet_cosh), + JANET_CORE_REG("math/tanh", janet_tanh), + JANET_CORE_REG("math/atanh", janet_atanh), + JANET_CORE_REG("math/asinh", janet_asinh), + JANET_CORE_REG("math/acosh", janet_acosh), + JANET_CORE_REG("math/atan2", janet_atan2), + JANET_CORE_REG("math/rng", cfun_rng_make), + JANET_CORE_REG("math/rng-uniform", cfun_rng_uniform), + JANET_CORE_REG("math/rng-int", cfun_rng_int), + JANET_CORE_REG("math/rng-buffer", cfun_rng_buffer), + JANET_CORE_REG("math/hypot", janet_hypot), + JANET_CORE_REG("math/exp2", janet_exp2), + JANET_CORE_REG("math/log1p", janet_log1p), + JANET_CORE_REG("math/gamma", janet_gamma), + JANET_CORE_REG("math/erfc", janet_erfc), + JANET_CORE_REG("math/erf", janet_erf), + JANET_CORE_REG("math/expm1", janet_expm1), + JANET_CORE_REG("math/trunc", janet_trunc), + JANET_CORE_REG("math/round", janet_round), + JANET_CORE_REG("math/next", janet_nextafter), + JANET_CORE_REG("math/gcd", janet_cfun_gcd), + JANET_CORE_REG("math/lcm", janet_cfun_lcm), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, math_cfuns); janet_register_abstract_type(&janet_rng_type); #ifdef JANET_BOOTSTRAP - janet_def(env, "math/pi", janet_wrap_number(3.1415926535897931), - JDOC("The value pi.")); - janet_def(env, "math/e", janet_wrap_number(2.7182818284590451), - JDOC("The base of the natural log.")); - janet_def(env, "math/inf", janet_wrap_number(INFINITY), - JDOC("The number representing positive infinity")); - janet_def(env, "math/-inf", janet_wrap_number(-INFINITY), - JDOC("The number representing negative infinity")); - janet_def(env, "math/int32-min", janet_wrap_number(INT32_MIN), - JDOC("The minimum contiguous integer representable by a 32 bit signed integer")); - janet_def(env, "math/int32-max", janet_wrap_number(INT32_MAX), - JDOC("The maximum contiguous integer represtenable by a 32 bit signed integer")); - janet_def(env, "math/int-min", janet_wrap_number(JANET_INTMIN_DOUBLE), - JDOC("The minimum contiguous integer representable by a double (2^53)")); - janet_def(env, "math/int-max", janet_wrap_number(JANET_INTMAX_DOUBLE), - JDOC("The maximum contiguous integer represtenable by a double (-(2^53))")); + JANET_CORE_DEF(env, "math/pi", janet_wrap_number(3.1415926535897931), + "The value pi."); + JANET_CORE_DEF(env, "math/e", janet_wrap_number(2.7182818284590451), + "The base of the natural log."); + JANET_CORE_DEF(env, "math/inf", janet_wrap_number(INFINITY), + "The number representing positive infinity"); + JANET_CORE_DEF(env, "math/-inf", janet_wrap_number(-INFINITY), + "The number representing negative infinity"); + JANET_CORE_DEF(env, "math/int32-min", janet_wrap_number(INT32_MIN), + "The minimum contiguous integer representable by a 32 bit signed integer"); + JANET_CORE_DEF(env, "math/int32-max", janet_wrap_number(INT32_MAX), + "The maximum contiguous integer represtenable by a 32 bit signed integer"); + JANET_CORE_DEF(env, "math/int-min", janet_wrap_number(JANET_INTMIN_DOUBLE), + "The minimum contiguous integer representable by a double (2^53)"); + JANET_CORE_DEF(env, "math/int-max", janet_wrap_number(JANET_INTMAX_DOUBLE), + "The maximum contiguous integer represtenable by a double (-(2^53))"); #ifdef NAN - janet_def(env, "math/nan", janet_wrap_number(NAN), + JANET_CORE_DEF(env, "math/nan", janet_wrap_number(NAN), "Not a number (IEEE-754 NaN)"); #else - janet_def(env, "math/nan", janet_wrap_number(0.0 / 0.0), + JANET_CORE_DEF(env, "math/nan", janet_wrap_number(0.0 / 0.0), "Not a number (IEEE-754 NaN)"); #endif - JDOC("Not a number (IEEE-754 NaN)")); #endif } diff --git a/src/core/net.c b/src/core/net.c index 99053131..018a340c 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -38,6 +38,7 @@ #pragma comment (lib, "Mswsock.lib") #pragma comment (lib, "Advapi32.lib") #else +#include #include #include #include @@ -73,6 +74,15 @@ const JanetAbstractType janet_address_type = { #endif #endif +/* maximum number of bytes in a socket address host (post name resolution) */ +#ifdef JANET_WINDOWS +#define SA_ADDRSTRLEN (INET6_ADDRSTRLEN + 1) +typedef unsigned short in_port_t; +#else +#define JANET_SA_MAX(a, b) (((a) > (b))? (a) : (b)) +#define SA_ADDRSTRLEN JANET_SA_MAX(INET6_ADDRSTRLEN + 1, (sizeof ((struct sockaddr_un *)0)->sun_path) + 1) +#endif + static JanetStream *make_stream(JSock handle, uint32_t flags); /* We pass this flag to all send calls to prevent sigpipe */ @@ -259,7 +269,8 @@ static int janet_get_sockettype(Janet *argv, int32_t argc, int32_t n) { } /* Needs argc >= offset + 2 */ -/* For unix paths, just rertuns a single sockaddr and sets *is_unix to 1, otherwise 0 */ +/* For unix paths, just rertuns a single sockaddr and sets *is_unix to 1, + * otherwise 0. Also, ignores is_bind when is a unix socket. */ static struct addrinfo *janet_get_addrinfo(Janet *argv, int32_t offset, int socktype, int passive, int *is_unix) { /* Unix socket support - not yet supported on windows. */ #ifndef JANET_WINDOWS @@ -285,12 +296,12 @@ static struct addrinfo *janet_get_addrinfo(Janet *argv, int32_t offset, int sock } #endif /* Get host and port */ - const char *host = janet_getcstring(argv, offset); - const char *port; + char *host = (char *)janet_getcstring(argv, offset); + char *port = NULL; if (janet_checkint(argv[offset + 1])) { - port = (const char *)janet_to_string(argv[offset + 1]); + port = (char *)janet_to_string(argv[offset + 1]); } else { - port = janet_optcstring(argv, offset + 2, offset + 1, NULL); + port = (char *)janet_optcstring(argv, offset + 2, offset + 1, NULL); } /* getaddrinfo */ struct addrinfo *ai = NULL; @@ -311,7 +322,14 @@ static struct addrinfo *janet_get_addrinfo(Janet *argv, int32_t offset, int sock * C Funs */ -static Janet cfun_net_sockaddr(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_net_sockaddr, + "(net/address host port &opt type multi)", + "Look up the connection information for a given hostname, port, and connection type. Returns " + "a handle that can be used to send datagrams over network without establishing a connection. " + "On Posix platforms, you can use :unix for host to connect to a unix domain socket, where the name is " + "given in the port argument. On Linux, abstract " + "unix domain sockets are specified with a leading '@' character in port. If `multi` is truthy, will " + "return all address that match in an array instead of just the first.") { janet_arity(argc, 2, 4); int socktype = janet_get_sockettype(argv, argc, 2); int is_unix = 0; @@ -350,13 +368,49 @@ static Janet cfun_net_sockaddr(int32_t argc, Janet *argv) { } } -static Janet cfun_net_connect(int32_t argc, Janet *argv) { - janet_arity(argc, 2, 3); +JANET_CORE_FN(cfun_net_connect, + "(net/connect host port &opt type bindhost bindport)", + "Open a connection to communicate with a server. Returns a duplex stream " + "that can be used to communicate with the server. Type is an optional keyword " + "to specify a connection type, either :stream or :datagram. The default is :stream. " + "Bindhost is an optional string to select from what address to make the outgoing " + "connection, with the default being the same as using the OS's preferred address. ") { + janet_arity(argc, 2, 5); + /* Check arguments */ int socktype = janet_get_sockettype(argv, argc, 2); int is_unix = 0; + char *bindhost = (char *) janet_optcstring(argv, argc, 3, NULL); + char *bindport = NULL; + if (janet_checkint(argv[4])) { + bindport = (char *)janet_to_string(argv[4]); + } else { + bindport = (char *)janet_optcstring(argv, argc, 4, NULL); + } + + /* Where we're connecting to */ struct addrinfo *ai = janet_get_addrinfo(argv, 0, socktype, 0, &is_unix); + /* Check if we're binding address */ + struct addrinfo *binding = NULL; + if (bindhost != NULL) { + if (is_unix) { + freeaddrinfo(ai); + janet_panic("bindhost not supported for unix domain sockets"); + } + /* getaddrinfo */ + struct addrinfo hints; + memset(&hints, 0, sizeof(hints)); + hints.ai_family = AF_UNSPEC; + hints.ai_socktype = socktype; + hints.ai_flags = 0; + int status = getaddrinfo(bindhost, bindport, &hints, &binding); + if (status) { + freeaddrinfo(ai); + janet_panicf("could not get address info for bindhost: %s", gai_strerror(status)); + } + } + /* Create socket */ JSock sock = JSOCKDEFAULT; void *addr = NULL; @@ -365,7 +419,9 @@ static Janet cfun_net_connect(int32_t argc, Janet *argv) { if (is_unix) { sock = socket(AF_UNIX, socktype | JSOCKFLAGS, 0); if (!JSOCKVALID(sock)) { - janet_panicf("could not create socket: %V", janet_ev_lasterr()); + Janet v = janet_ev_lasterr(); + janet_free(ai); + janet_panicf("could not create socket: %V", v); } addr = (void *) ai; addrlen = sizeof(struct sockaddr_un); @@ -386,17 +442,42 @@ static Janet cfun_net_connect(int32_t argc, Janet *argv) { } } if (NULL == addr) { + Janet v = janet_ev_lasterr(); + if (binding) freeaddrinfo(binding); freeaddrinfo(ai); - janet_panicf("could not create socket: %V", janet_ev_lasterr()); + janet_panicf("could not create socket: %V", v); + } + } + + /* Bind to bindhost and bindport if given */ + if (binding) { + struct addrinfo *rp = NULL; + int did_bind = 0; + for (rp = ai; rp != NULL; rp = rp->ai_next) { + if (bind(sock, rp->ai_addr, (int) rp->ai_addrlen) == 0) { + did_bind = 1; + break; + } + } + if (!did_bind) { + Janet v = janet_ev_lasterr(); + freeaddrinfo(binding); + freeaddrinfo(ai); + JSOCKCLOSE(sock); + janet_panicf("could not bind outgoing address: %V", v); + } else { + freeaddrinfo(binding); } } /* Connect to socket */ #ifdef JANET_WINDOWS int status = WSAConnect(sock, addr, addrlen, NULL, NULL, NULL, NULL); + Janet lasterr = janet_ev_lasterr(); freeaddrinfo(ai); #else int status = connect(sock, addr, addrlen); + Janet lasterr = janet_ev_lasterr(); if (is_unix) { janet_free(ai); } else { @@ -406,7 +487,7 @@ static Janet cfun_net_connect(int32_t argc, Janet *argv) { if (status == -1) { JSOCKCLOSE(sock); - janet_panicf("could not connect to socket: %V", janet_ev_lasterr()); + janet_panicf("could not connect socket: %V", lasterr); } /* Set up the socket for non-blocking IO after connect - TODO - non-blocking connect? */ @@ -442,7 +523,14 @@ static const char *serverify_socket(JSock sfd) { #define JANET_SHUTDOWN_W SHUT_WR #endif -static Janet cfun_net_shutdown(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_net_shutdown, + "(net/shutdown stream &opt mode)", + "Stop communication on this socket in a graceful manner, either in both directions or just " + "reading/writing from the stream. The `mode` parameter controls which communication to stop on the socket. " + "\n\n* `:wr` is the default and prevents both reading new data from the socket and writing new data to the socket.\n" + "* `:r` disables reading new data from the socket.\n" + "* `:w` disable writing data to the socket.\n\n" + "Returns the original socket.") { janet_arity(argc, 1, 2); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_SOCKET); @@ -473,7 +561,13 @@ static Janet cfun_net_shutdown(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_net_listen(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_net_listen, + "(net/listen host port &opt type)", + "Creates a server. Returns a new stream that is neither readable nor " + "writeable. Use net/accept or net/accept-loop be to handle connections and start the server. " + "The type parameter specifies the type of network connection, either " + "a :stream (usually tcp), or :datagram (usually udp). If not specified, the default is " + ":stream. The host and port arguments are the same as in net/address.") { janet_arity(argc, 2, 3); /* Get host, port, and handler*/ @@ -547,7 +641,98 @@ static Janet cfun_net_listen(int32_t argc, Janet *argv) { } } -static Janet cfun_stream_accept_loop(int32_t argc, Janet *argv) { +/* Types of socket's we need to deal with - relevant type puns below. +struct sockaddr *sa; // Common base structure +struct sockaddr_storage *ss; // Size of largest socket address type +struct sockaddr_in *sin; // IPv4 address + port +struct sockaddr_in6 *sin6; // IPv6 address + port +struct sockaddr_un *sun; // Unix Domain Socket Address +*/ + +/* Turn a socket address into a host, port pair (port is optional). + * For unix domain sockets, returned tuple will have only a single element, the path string. */ +static Janet janet_so_getname(const void *sa_any) { + const struct sockaddr *sa = sa_any; + char buffer[SA_ADDRSTRLEN]; + switch (sa->sa_family) { + default: + janet_panic("unknown address family"); + case AF_INET: { + const struct sockaddr_in *sai = sa_any; + if (!inet_ntop(AF_INET, &(sai->sin_addr), buffer, sizeof(buffer))) { + janet_panic("unable to decode ipv4 host address"); + } + Janet pair[2] = {janet_cstringv(buffer), janet_wrap_integer(ntohs(sai->sin_port))}; + return janet_wrap_tuple(janet_tuple_n(pair, sai->sin_port ? 2 : 1)); + } + case AF_INET6: { + const struct sockaddr_in6 *sai6 = sa_any; + if (!inet_ntop(AF_INET6, &(sai6->sin6_addr), buffer, sizeof(buffer))) { + janet_panic("unable to decode ipv4 host address"); + } + Janet pair[2] = {janet_cstringv(buffer), janet_wrap_integer(ntohs(sai6->sin6_port))}; + return janet_wrap_tuple(janet_tuple_n(pair, sai6->sin6_port ? 2 : 1)); + } +#ifndef JANET_WINDOWS + case AF_UNIX: { + const struct sockaddr_un *sun = sa_any; + Janet pathname; + if (sun->sun_path[0] == '\0') { + memcpy(buffer, sun->sun_path, sizeof(sun->sun_path)); + buffer[0] = '@'; + pathname = janet_cstringv(buffer); + } else { + pathname = janet_cstringv(sun->sun_path); + } + return janet_wrap_tuple(janet_tuple_n(&pathname, 1)); + } +#endif + } +} + +JANET_CORE_FN(cfun_net_getsockname, + "(net/localname stream)", + "Gets the local address and port in a tuple in that order.") { + janet_fixarity(argc, 1); + JanetStream *js = janet_getabstract(argv, 0, &janet_stream_type); + struct sockaddr_storage ss; + socklen_t slen = sizeof(ss); + memset(&ss, 0, slen); + if (getsockname((JSock)js->handle, (struct sockaddr *) &ss, &slen)) { + janet_panicf("Failed to get localname on %v: %V", argv[0], janet_ev_lasterr()); + } + janet_assert(slen <= sizeof(ss), "socket address truncated"); + return janet_so_getname(&ss); +} + +JANET_CORE_FN(cfun_net_getpeername, + "(net/peername stream)", + "Gets the remote peer's address and port in a tuple in that order.") { + janet_fixarity(argc, 1); + JanetStream *js = janet_getabstract(argv, 0, &janet_stream_type); + struct sockaddr_storage ss; + socklen_t slen = sizeof(ss); + memset(&ss, 0, slen); + if (getpeername((JSock)js->handle, (struct sockaddr *)&ss, &slen)) { + janet_panicf("Failed to get peername on %v: %V", argv[0], janet_ev_lasterr()); + } + janet_assert(slen <= sizeof(ss), "socket address truncated"); + return janet_so_getname(&ss); +} + +JANET_CORE_FN(cfun_net_address_unpack, + "(net/address-unpack address)", + "Given an address returned by net/adress, return a host, port pair. Unix domain sockets " + "will have only the path in the returned tuple.") { + janet_fixarity(argc, 1); + struct sockaddr *sa = janet_getabstract(argv, 0, &janet_address_type); + return janet_so_getname(sa); +} + +JANET_CORE_FN(cfun_stream_accept_loop, + "(net/accept-loop stream handler)", + "Shorthand for running a server stream that will continuously accept new connections. " + "Blocks the current fiber until the stream is closed, and will return the stream.") { janet_fixarity(argc, 2); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_ACCEPTABLE | JANET_STREAM_SOCKET); @@ -555,7 +740,11 @@ static Janet cfun_stream_accept_loop(int32_t argc, Janet *argv) { janet_sched_accept(stream, fun); } -static Janet cfun_stream_accept(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_stream_accept, + "(net/accept stream &opt timeout)", + "Get the next connection on a server stream. This would usually be called in a loop in a dedicated fiber. " + "Takes an optional timeout in seconds, after which will return nil. " + "Returns a new duplex stream which represents a connection to the client.") { janet_arity(argc, 1, 2); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_ACCEPTABLE | JANET_STREAM_SOCKET); @@ -564,7 +753,13 @@ static Janet cfun_stream_accept(int32_t argc, Janet *argv) { janet_sched_accept(stream, NULL); } -static Janet cfun_stream_read(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_stream_read, + "(net/read stream nbytes &opt buf timeout)", + "Read up to n bytes from a stream, suspending the current fiber until the bytes are available. " + "`n` can also be the keyword `:all` to read into the buffer until end of stream. " + "If less than n bytes are available (and more than 0), will push those bytes and return early. " + "Takes an optional timeout in seconds, after which will return nil. " + "Returns a buffer with up to n more bytes in it, or raises an error if the read failed.") { janet_arity(argc, 2, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_READABLE | JANET_STREAM_SOCKET); @@ -581,7 +776,10 @@ static Janet cfun_stream_read(int32_t argc, Janet *argv) { janet_await(); } -static Janet cfun_stream_chunk(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_stream_chunk, + "(net/chunk stream nbytes &opt buf timeout)", + "Same a net/read, but will wait for all n bytes to arrive rather than return early. " + "Takes an optional timeout in seconds, after which will return nil.") { janet_arity(argc, 2, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_READABLE | JANET_STREAM_SOCKET); @@ -593,7 +791,10 @@ static Janet cfun_stream_chunk(int32_t argc, Janet *argv) { janet_await(); } -static Janet cfun_stream_recv_from(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_stream_recv_from, + "(net/recv-from stream nbytes buf &opt timoeut)", + "Receives data from a server stream and puts it into a buffer. Returns the socket-address the " + "packet came from. Takes an optional timeout in seconds, after which will return nil.") { janet_arity(argc, 3, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_UDPSERVER | JANET_STREAM_SOCKET); @@ -605,7 +806,11 @@ static Janet cfun_stream_recv_from(int32_t argc, Janet *argv) { janet_await(); } -static Janet cfun_stream_write(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_stream_write, + "(net/write stream data &opt timeout)", + "Write data to a stream, suspending the current fiber until the write " + "completes. Takes an optional timeout in seconds, after which will return nil. " + "Returns nil, or raises an error if the write failed.") { janet_arity(argc, 2, 3); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_WRITABLE | JANET_STREAM_SOCKET); @@ -621,7 +826,11 @@ static Janet cfun_stream_write(int32_t argc, Janet *argv) { janet_await(); } -static Janet cfun_stream_send_to(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_stream_send_to, + "(net/send-to stream dest data &opt timeout)", + "Writes a datagram to a server stream. dest is a the destination address of the packet. " + "Takes an optional timeout in seconds, after which will return nil. " + "Returns stream.") { janet_arity(argc, 3, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_UDPSERVER | JANET_STREAM_SOCKET); @@ -638,7 +847,10 @@ static Janet cfun_stream_send_to(int32_t argc, Janet *argv) { janet_await(); } -static Janet cfun_stream_flush(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_stream_flush, + "(net/flush stream)", + "Make sure that a stream is not buffering any data. This temporarily disables Nagle's algorithm. " + "Use this to make sure data is sent without delay. Returns stream.") { janet_fixarity(argc, 1); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_WRITABLE | JANET_STREAM_SOCKET); @@ -660,7 +872,6 @@ static const JanetMethod net_stream_methods[] = { {"accept-loop", cfun_stream_accept_loop}, {"send-to", cfun_stream_send_to}, {"recv-from", cfun_stream_recv_from}, - {"recv-from", cfun_stream_recv_from}, {"evread", janet_cfun_stream_read}, {"evchunk", janet_cfun_stream_chunk}, {"evwrite", janet_cfun_stream_write}, @@ -672,101 +883,27 @@ static JanetStream *make_stream(JSock handle, uint32_t flags) { return janet_stream((JanetHandle) handle, flags | JANET_STREAM_SOCKET, net_stream_methods); } -static const JanetReg net_cfuns[] = { - { - "net/address", cfun_net_sockaddr, - JDOC("(net/address host port &opt type)\n\n" - "Look up the connection information for a given hostname, port, and connection type. Returns " - "a handle that can be used to send datagrams over network without establishing a connection. " - "On Posix platforms, you can use :unix for host to connect to a unix domain socket, where the name is " - "given in the port argument. On Linux, abstract " - "unix domain sockets are specified with a leading '@' character in port.") - }, - { - "net/listen", cfun_net_listen, - JDOC("(net/listen host port &opt type)\n\n" - "Creates a server. Returns a new stream that is neither readable nor " - "writeable. Use net/accept or net/accept-loop be to handle connections and start the server. " - "The type parameter specifies the type of network connection, either " - "a :stream (usually tcp), or :datagram (usually udp). If not specified, the default is " - ":stream. The host and port arguments are the same as in net/address.") - }, - { - "net/accept", cfun_stream_accept, - JDOC("(net/accept stream &opt timeout)\n\n" - "Get the next connection on a server stream. This would usually be called in a loop in a dedicated fiber. " - "Takes an optional timeout in seconds, after which will return nil. " - "Returns a new duplex stream which represents a connection to the client.") - }, - { - "net/accept-loop", cfun_stream_accept_loop, - JDOC("(net/accept-loop stream handler)\n\n" - "Shorthand for running a server stream that will continuously accept new connections. " - "Blocks the current fiber until the stream is closed, and will return the stream.") - }, - { - "net/read", cfun_stream_read, - JDOC("(net/read stream nbytes &opt buf timeout)\n\n" - "Read up to n bytes from a stream, suspending the current fiber until the bytes are available. " - "`n` can also be the keyword `:all` to read into the buffer until end of stream. " - "If less than n bytes are available (and more than 0), will push those bytes and return early. " - "Takes an optional timeout in seconds, after which will return nil. " - "Returns a buffer with up to n more bytes in it, or raises an error if the read failed.") - }, - { - "net/chunk", cfun_stream_chunk, - JDOC("(net/chunk stream nbytes &opt buf timeout)\n\n" - "Same a net/read, but will wait for all n bytes to arrive rather than return early. " - "Takes an optional timeout in seconds, after which will return nil.") - }, - { - "net/write", cfun_stream_write, - JDOC("(net/write stream data &opt timeout)\n\n" - "Write data to a stream, suspending the current fiber until the write " - "completes. Takes an optional timeout in seconds, after which will return nil. " - "Returns nil, or raises an error if the write failed.") - }, - { - "net/send-to", cfun_stream_send_to, - JDOC("(net/send-to stream dest data &opt timeout)\n\n" - "Writes a datagram to a server stream. dest is a the destination address of the packet. " - "Takes an optional timeout in seconds, after which will return nil. " - "Returns stream.") - }, - { - "net/recv-from", cfun_stream_recv_from, - JDOC("(net/recv-from stream nbytes buf &opt timoeut)\n\n" - "Receives data from a server stream and puts it into a buffer. Returns the socket-address the " - "packet came from. Takes an optional timeout in seconds, after which will return nil.") - }, - { - "net/flush", cfun_stream_flush, - JDOC("(net/flush stream)\n\n" - "Make sure that a stream is not buffering any data. This temporarily disables Nagle's algorithm. " - "Use this to make sure data is sent without delay. Returns stream.") - }, - { - "net/connect", cfun_net_connect, - JDOC("(net/connect host port &opt type)\n\n" - "Open a connection to communicate with a server. Returns a duplex stream " - "that can be used to communicate with the server. Type is an optional keyword " - "to specify a connection type, either :stream or :datagram. The default is :stream. ") - }, - { - "net/shutdown", cfun_net_shutdown, - JDOC("(net/shutdown stream &opt mode)\n\n" - "Stop communication on this socket in a graceful manner, either in both directions or just " - "reading/writing from the stream. The `mode` parameter controls which communication to stop on the socket. " - "\n\n* `:wr` is the default and prevents both reading new data from the socket and writing new data to the socket.\n" - "* `:r` disables reading new data from the socket.\n" - "* `:w` disable writing data to the socket.\n\n" - "Returns the original socket.") - }, - {NULL, NULL, NULL} -}; void janet_lib_net(JanetTable *env) { - janet_core_cfuns(env, NULL, net_cfuns); + JanetRegExt net_cfuns[] = { + JANET_CORE_REG("net/address", cfun_net_sockaddr), + JANET_CORE_REG("net/listen", cfun_net_listen), + JANET_CORE_REG("net/accept", cfun_stream_accept), + JANET_CORE_REG("net/accept-loop", cfun_stream_accept_loop), + JANET_CORE_REG("net/read", cfun_stream_read), + JANET_CORE_REG("net/chunk", cfun_stream_chunk), + JANET_CORE_REG("net/write", cfun_stream_write), + JANET_CORE_REG("net/send-to", cfun_stream_send_to), + JANET_CORE_REG("net/recv-from", cfun_stream_recv_from), + JANET_CORE_REG("net/flush", cfun_stream_flush), + JANET_CORE_REG("net/connect", cfun_net_connect), + JANET_CORE_REG("net/shutdown", cfun_net_shutdown), + JANET_CORE_REG("net/peername", cfun_net_getpeername), + JANET_CORE_REG("net/localname", cfun_net_getsockname), + JANET_CORE_REG("net/address-unpack", cfun_net_address_unpack), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, net_cfuns); } void janet_net_init(void) { diff --git a/src/core/os.c b/src/core/os.c index 4531bec9..8c75eac0 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -84,7 +84,6 @@ time_t timegm(struct tm *tm); * setenv/getenv are not thread safe. */ #ifdef JANET_THREADS # ifdef JANET_WINDOWS -static int env_lock_initialized = 0; static CRITICAL_SECTION env_lock; static void janet_lock_environ(void) { EnterCriticalSection(&env_lock); @@ -117,7 +116,18 @@ static void janet_unlock_environ(void) { #define janet_stringify1(x) #x #define janet_stringify(x) janet_stringify1(x) -static Janet os_which(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_which, + "(os/which)", + "Check the current operating system. Returns one of:\n\n" + "* :windows\n\n" + "* :macos\n\n" + "* :web - Web assembly (emscripten)\n\n" + "* :linux\n\n" + "* :freebsd\n\n" + "* :openbsd\n\n" + "* :netbsd\n\n" + "* :posix - A POSIX compatible system (default)\n\n" + "May also return a custom keyword specified at build time.") { janet_fixarity(argc, 0); (void) argv; #if defined(JANET_OS_NAME) @@ -144,7 +154,16 @@ static Janet os_which(int32_t argc, Janet *argv) { } /* Detect the ISA we are compiled for */ -static Janet os_arch(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_arch, + "(os/arch)", + "Check the ISA that janet was compiled for. Returns one of:\n\n" + "* :x86\n\n" + "* :x64\n\n" + "* :arm\n\n" + "* :aarch64\n\n" + "* :sparc\n\n" + "* :wasm\n\n" + "* :unknown\n") { janet_fixarity(argc, 0); (void) argv; /* Check 64-bit vs 32-bit */ @@ -172,7 +191,10 @@ static Janet os_arch(int32_t argc, Janet *argv) { #undef janet_stringify1 #undef janet_stringify -static Janet os_exit(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_exit, + "(os/exit &opt x)", + "Exit from janet with an exit code equal to x. If x is not an integer, " + "the exit with status equal the hash of x.") { janet_arity(argc, 0, 1); int status; if (argc == 0) { @@ -353,6 +375,7 @@ static const JanetAbstractType ProcAT; #define JANET_PROC_OWNS_STDIN 16 #define JANET_PROC_OWNS_STDOUT 32 #define JANET_PROC_OWNS_STDERR 64 +#define JANET_PROC_ALLOW_ZOMBIE 128 typedef struct { int flags; #ifdef JANET_WINDOWS @@ -410,6 +433,7 @@ static JanetEVGenericMessage janet_proc_wait_subr(JanetEVGenericMessage args) { /* Callback that is called in main thread when subroutine completes. */ static void janet_proc_wait_cb(JanetEVGenericMessage args) { + janet_ev_dec_refcount(); int status = args.argi; JanetProc *proc = (JanetProc *) args.argp; if (NULL != proc) { @@ -434,11 +458,14 @@ static int janet_proc_gc(void *p, size_t s) { JanetProc *proc = (JanetProc *) p; #ifdef JANET_WINDOWS if (!(proc->flags & JANET_PROC_CLOSED)) { + if (!(proc->flags & JANET_PROC_ALLOW_ZOMBIE)) { + TerminateProcess(proc->pHandle, 1); + } CloseHandle(proc->pHandle); CloseHandle(proc->tHandle); } #else - if (!(proc->flags & JANET_PROC_WAITED)) { + if (!(proc->flags & (JANET_PROC_WAITED | JANET_PROC_ALLOW_ZOMBIE))) { /* Kill and wait to prevent zombies */ kill(proc->pid, SIGKILL); int status; @@ -497,7 +524,9 @@ os_proc_wait_impl(JanetProc *proc) { #endif } -static Janet os_proc_wait(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_proc_wait, + "(os/proc-wait proc)", + "Block until the subprocess completes. Returns the subprocess return code.") { janet_fixarity(argc, 1); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); #ifdef JANET_EV @@ -508,7 +537,11 @@ static Janet os_proc_wait(int32_t argc, Janet *argv) { #endif } -static Janet os_proc_kill(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_proc_kill, + "(os/proc-kill proc &opt wait)", + "Kill a subprocess by sending SIGKILL to it on posix systems, or by closing the process " + "handle on windows. If wait is truthy, will wait for the process to finsih and " + "returns the exit code. Otherwise, returns proc.") { janet_arity(argc, 1, 2); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); if (proc->flags & JANET_PROC_WAITED) { @@ -519,6 +552,7 @@ static Janet os_proc_kill(int32_t argc, Janet *argv) { janet_panicf("cannot close process handle that is already closed"); } proc->flags |= JANET_PROC_CLOSED; + TerminateProcess(proc->pHandle, 1); CloseHandle(proc->pHandle); CloseHandle(proc->tHandle); #else @@ -540,7 +574,10 @@ static Janet os_proc_kill(int32_t argc, Janet *argv) { } } -static Janet os_proc_close(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_proc_close, + "(os/proc-close proc)", + "Wait on a process if it has not been waited on, and close pipes created by `os/spawn` " + "if they have not been closed. Returns nil.") { janet_fixarity(argc, 1); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); #ifdef JANET_EV @@ -757,7 +794,7 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) { /* Get flags */ uint64_t flags = 0; if (argc > 1) { - flags = janet_getflags(argv, 1, "epx"); + flags = janet_getflags(argv, 1, "epxd"); } /* Get environment */ @@ -775,7 +812,7 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) { JanetHandle new_in = JANET_HANDLE_NONE, new_out = JANET_HANDLE_NONE, new_err = JANET_HANDLE_NONE; JanetHandle pipe_in = JANET_HANDLE_NONE, pipe_out = JANET_HANDLE_NONE, pipe_err = JANET_HANDLE_NONE; int pipe_errflag = 0; /* Track errors setting up pipes */ - int pipe_owner_flags = 0; + int pipe_owner_flags = (is_spawn && (flags & 0x8)) ? JANET_PROC_ALLOW_ZOMBIE : 0; /* Get optional redirections */ if (argc > 2) { @@ -991,11 +1028,32 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) { } } -static Janet os_execute(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_execute, + "(os/execute args &opt flags env)", + "Execute a program on the system and pass it string arguments. `flags` " + "is a keyword that modifies how the program will execute.\n" + "* :e - enables passing an environment to the program. Without :e, the " + "current environment is inherited.\n" + "* :p - allows searching the current PATH for the binary to execute. " + "Without this flag, binaries must use absolute paths.\n" + "* :x - raise error if exit code is non-zero.\n" + "* :d - Don't try and terminate the process on garbage collection (allow spawning zombies).\n" + "`env` is a table or struct mapping environment variables to values. It can also " + "contain the keys :in, :out, and :err, which allow redirecting stdio in the subprocess. " + "These arguments should be core/file values. " + "One can also pass in the :pipe keyword " + "for these arguments to create files that will read (for :err and :out) or write (for :in) " + "to the file descriptor of the subprocess. This is only useful in `os/spawn`, which takes " + "the same parameters as `os/execute`, but will return an object that contains references to these " + "files via (return-value :in), (return-value :out), and (return-value :err). " + "Returns the exit status of the program.") { return os_execute_impl(argc, argv, 0); } -static Janet os_spawn(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_spawn, + "(os/spawn args &opt flags env)", + "Execute a program on the system and return a handle to the process. Otherwise, the " + "same arguments as os/execute. Does not wait for the process.") { return os_execute_impl(argc, argv, 1); } @@ -1014,7 +1072,9 @@ static JanetEVGenericMessage os_shell_subr(JanetEVGenericMessage args) { } #endif -static Janet os_shell(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_shell, + "(os/shell str)", + "Pass a command string str directly to the system shell.") { janet_arity(argc, 0, 1); const char *cmd = argc ? janet_getcstring(argv, 0) @@ -1031,7 +1091,9 @@ static Janet os_shell(int32_t argc, Janet *argv) { #endif /* JANET_NO_PROCESSES */ -static Janet os_environ(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_environ, + "(os/environ)", + "Get a copy of the os environment table.") { (void) argv; janet_fixarity(argc, 0); int32_t nenv = 0; @@ -1060,7 +1122,9 @@ static Janet os_environ(int32_t argc, Janet *argv) { return janet_wrap_table(t); } -static Janet os_getenv(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_getenv, + "(os/getenv variable &opt dflt)", + "Get the string value of an environment variable.") { janet_arity(argc, 1, 2); const char *cstr = janet_getcstring(argv, 0); const char *res = getenv(cstr); @@ -1074,7 +1138,9 @@ static Janet os_getenv(int32_t argc, Janet *argv) { return ret; } -static Janet os_setenv(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_setenv, + "(os/setenv variable value)", + "Set an environment variable.") { #ifdef JANET_WINDOWS #define SETENV(K,V) _putenv_s(K, V) #define UNSETENV(K) _putenv_s(K, "") @@ -1095,14 +1161,20 @@ static Janet os_setenv(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet os_time(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_time, + "(os/time)", + "Get the current time expressed as the number of whole seconds since " + "January 1, 1970, the Unix epoch. Returns a real number.") { janet_fixarity(argc, 0); (void) argv; double dtime = (double)(time(NULL)); return janet_wrap_number(dtime); } -static Janet os_clock(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_clock, + "(os/clock)", + "Return the number of whole + fractional seconds since some fixed point in time. The clock " + "is guaranteed to be non decreasing in real time.") { janet_fixarity(argc, 0); (void) argv; struct timespec tv; @@ -1111,7 +1183,10 @@ static Janet os_clock(int32_t argc, Janet *argv) { return janet_wrap_number(dtime); } -static Janet os_sleep(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_sleep, + "(os/sleep n)", + "Suspend the program for n seconds. 'nsec' can be a real number. Returns " + "nil.") { janet_fixarity(argc, 1); double delay = janet_getnumber(argv, 0); if (delay < 0) janet_panic("invalid argument to sleep"); @@ -1129,7 +1204,9 @@ static Janet os_sleep(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet os_cwd(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_cwd, + "(os/cwd)", + "Returns the current working directory.") { janet_fixarity(argc, 0); (void) argv; char buf[FILENAME_MAX]; @@ -1143,7 +1220,9 @@ static Janet os_cwd(int32_t argc, Janet *argv) { return janet_cstringv(ptr); } -static Janet os_cryptorand(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_cryptorand, + "(os/cryptorand n &opt buf)", + "Get or append n bytes of good quality random data provided by the OS. Returns a new buffer or buf.") { JanetBuffer *buffer; janet_arity(argc, 1, 2); int32_t offset; @@ -1165,7 +1244,21 @@ static Janet os_cryptorand(int32_t argc, Janet *argv) { return janet_wrap_buffer(buffer); } -static Janet os_date(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_date, + "(os/date &opt time local)", + "Returns the given time as a date struct, or the current time if `time` is not given. " + "Returns a struct with following key values. Note that all numbers are 0-indexed. " + "Date is given in UTC unless `local` is truthy, in which case the date is formatted for " + "the local timezone.\n\n" + "* :seconds - number of seconds [0-61]\n\n" + "* :minutes - number of minutes [0-59]\n\n" + "* :hours - number of hours [0-23]\n\n" + "* :month-day - day of month [0-30]\n\n" + "* :month - month of year [0, 11]\n\n" + "* :year - years since year 0 (e.g. 2019)\n\n" + "* :week-day - day of the week [0-6]\n\n" + "* :year-day - day of the year [0-365]\n\n" + "* :dst - if Day Light Savings is in effect") { janet_arity(argc, 0, 2); (void) argv; time_t t; @@ -1263,7 +1356,14 @@ static timeint_t entry_getint(Janet env_entry, char *field) { return (timeint_t)janet_unwrap_number(i); } -static Janet os_mktime(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_mktime, + "(os/mktime date-struct &opt local)", + "Get the broken down date-struct time expressed as the number " + " of seconds since January 1, 1970, the Unix epoch. " + "Returns a real number. " + "Date is given in UTC unless local is truthy, in which case the " + "date is computed for the local timezone.\n\n" + "Inverse function to os/date.") { janet_arity(argc, 1, 2); time_t t; struct tm t_info; @@ -1309,7 +1409,12 @@ static Janet os_mktime(int32_t argc, Janet *argv) { #define j_symlink symlink #endif -static Janet os_link(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_link, + "(os/link oldpath newpath &opt symlink)", + "Create a link at newpath that points to oldpath and returns nil. " + "Iff symlink is truthy, creates a symlink. " + "Iff symlink is falsey or not provided, " + "creates a hard link. Does not work on Windows.") { janet_arity(argc, 2, 3); #ifdef JANET_WINDOWS (void) argc; @@ -1325,7 +1430,9 @@ static Janet os_link(int32_t argc, Janet *argv) { #endif } -static Janet os_symlink(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_symlink, + "(os/symlink oldpath newpath)", + "Create a symlink from oldpath to newpath, returning nil. Same as (os/link oldpath newpath true).") { janet_fixarity(argc, 2); #ifdef JANET_WINDOWS (void) argc; @@ -1343,7 +1450,11 @@ static Janet os_symlink(int32_t argc, Janet *argv) { #undef j_symlink -static Janet os_mkdir(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_mkdir, + "(os/mkdir path)", + "Create a new directory. The path will be relative to the current directory if relative, otherwise " + "it will be an absolute path. Returns true if the directory was created, false if the directory already exists, and " + "errors otherwise.") { janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); #ifdef JANET_WINDOWS @@ -1356,7 +1467,9 @@ static Janet os_mkdir(int32_t argc, Janet *argv) { janet_panicf("%s: %s", strerror(errno), path); } -static Janet os_rmdir(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_rmdir, + "(os/rmdir path)", + "Delete a directory. The directory must be empty to succeed.") { janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); #ifdef JANET_WINDOWS @@ -1368,7 +1481,9 @@ static Janet os_rmdir(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet os_cd(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_cd, + "(os/cd path)", + "Change current directory to path. Returns nil on success, errors on failure.") { janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); #ifdef JANET_WINDOWS @@ -1380,7 +1495,10 @@ static Janet os_cd(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet os_touch(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_touch, + "(os/touch path &opt actime modtime)", + "Update the access time and modification times for a file. By default, sets " + "times to the current time.") { janet_arity(argc, 1, 3); const char *path = janet_getcstring(argv, 0); struct utimbuf timebuf, *bufp; @@ -1400,7 +1518,9 @@ static Janet os_touch(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet os_remove(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_remove, + "(os/rm path)", + "Delete a file. Returns nil.") { janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); int status = remove(path); @@ -1409,7 +1529,9 @@ static Janet os_remove(int32_t argc, Janet *argv) { } #ifndef JANET_NO_SYMLINKS -static Janet os_readlink(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_readlink, + "(os/readlink path)", + "Read the contents of a symbolic link. Does not work on Windows.\n") { janet_fixarity(argc, 1); #ifdef JANET_WINDOWS (void) argc; @@ -1674,15 +1796,39 @@ static Janet os_stat_or_lstat(int do_lstat, int32_t argc, Janet *argv) { } } -static Janet os_stat(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_stat, + "(os/stat path &opt tab|key)", + "Gets information about a file or directory. Returns a table if the second argument is a keyword, returns " + " only that information from stat. If the file or directory does not exist, returns nil. The keys are:\n\n" + "* :dev - the device that the file is on\n\n" + "* :mode - the type of file, one of :file, :directory, :block, :character, :fifo, :socket, :link, or :other\n\n" + "* :int-permissions - A Unix permission integer like 8r744\n\n" + "* :permissions - A Unix permission string like \"rwxr--r--\"\n\n" + "* :uid - File uid\n\n" + "* :gid - File gid\n\n" + "* :nlink - number of links to file\n\n" + "* :rdev - Real device of file. 0 on windows.\n\n" + "* :size - size of file in bytes\n\n" + "* :blocks - number of blocks in file. 0 on windows\n\n" + "* :blocksize - size of blocks in file. 0 on windows\n\n" + "* :accessed - timestamp when file last accessed\n\n" + "* :changed - timestamp when file last changed (permissions changed)\n\n" + "* :modified - timestamp when file last modified (content changed)\n") { return os_stat_or_lstat(0, argc, argv); } -static Janet os_lstat(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_lstat, + "(os/lstat path &opt tab|key)", + "Like os/stat, but don't follow symlinks.\n") { return os_stat_or_lstat(1, argc, argv); } -static Janet os_chmod(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_chmod, + "(os/chmod path mode)", + "Change file permissions, where mode is a permission string as returned by " + "os/perm-string, or an integer as returned by os/perm-int. " + "When mode is an integer, it is interpreted as a Unix permission value, best specified in octal, like " + "8r666 or 8r400. Windows will not differentiate between user, group, and other permissions, and thus will combine all of these permissions. Returns nil.") { janet_fixarity(argc, 2); const char *path = janet_getcstring(argv, 0); #ifdef JANET_WINDOWS @@ -1695,7 +1841,9 @@ static Janet os_chmod(int32_t argc, Janet *argv) { } #ifndef JANET_NO_UMASK -static Janet os_umask(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_umask, + "(os/umask mask)", + "Set a new umask, returns the old umask.") { janet_fixarity(argc, 1); int mask = (int) os_getmode(argv, 0); #ifdef JANET_WINDOWS @@ -1707,7 +1855,10 @@ static Janet os_umask(int32_t argc, Janet *argv) { } #endif -static Janet os_dir(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_dir, + "(os/dir dir &opt array)", + "Iterate over files and subdirectories in a directory. Returns an array of paths parts, " + "with only the file name or directory name and no prefix.") { janet_arity(argc, 1, 2); const char *dir = janet_getcstring(argv, 0); JanetArray *paths = (argc == 2) ? janet_getarray(argv, 1) : janet_array(0); @@ -1742,7 +1893,9 @@ static Janet os_dir(int32_t argc, Janet *argv) { return janet_wrap_array(paths); } -static Janet os_rename(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_rename, + "(os/rename oldname newname)", + "Rename a file on disk to a new path. Returns nil.") { janet_fixarity(argc, 2); const char *src = janet_getcstring(argv, 0); const char *dest = janet_getcstring(argv, 1); @@ -1753,7 +1906,10 @@ static Janet os_rename(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet os_realpath(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_realpath, + "(os/realpath path)", + "Get the absolute path for a given path, following ../, ./, and symlinks. " + "Returns an absolute path as a string. Will raise an error on Windows.") { janet_fixarity(argc, 1); const char *src = janet_getcstring(argv, 0); #ifdef JANET_NO_REALPATH @@ -1771,12 +1927,19 @@ static Janet os_realpath(int32_t argc, Janet *argv) { #endif } -static Janet os_permission_string(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_permission_string, + "(os/perm-string int)", + "Convert a Unix octal permission value from a permission integer as returned by os/stat " + "to a human readable string, that follows the formatting " + "of unix tools like ls. Returns the string as a 9 character string of r, w, x and - characters. Does not " + "include the file/directory/symlink character as rendered by `ls`.") { janet_fixarity(argc, 1); return os_make_permstring(os_get_unix_mode(argv, 0)); } -static Janet os_permission_int(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_permission_int, + "(os/perm-int bytes)", + "Parse a 9 character permission string and return an integer that can be used by chmod.") { janet_fixarity(argc, 1); return janet_wrap_integer(os_get_unix_mode(argv, 0)); } @@ -1792,7 +1955,31 @@ static jmode_t os_optmode(int32_t argc, const Janet *argv, int32_t n, int32_t df return janet_perm_from_unix(dflt); } -static Janet os_open(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_open, + "(os/open path &opt flags mode)", + "Create a stream from a file, like the POSIX open system call. Returns a new stream. " + "mode should be a file mode as passed to os/chmod, but only if the create flag is given. " + "The default mode is 8r666. " + "Allowed flags are as follows:\n\n" + " * :r - open this file for reading\n" + " * :w - open this file for writing\n" + " * :c - create a new file (O_CREATE)\n" + " * :e - fail if the file exists (O_EXCL)\n" + " * :t - shorten an existing file to length 0 (O_TRUNC)\n\n" + "Posix only flags:\n\n" + " * :a - append to a file (O_APPEND)\n" + " * :x - O_SYNC\n" + " * :C - O_NOCTTY\n\n" + "Windows only flags:\n\n" + " * :R - share reads (FILE_SHARE_READ)\n" + " * :W - share writes (FILE_SHARE_WRITE)\n" + " * :D - share deletes (FILE_SHARE_DELETE)\n" + " * :H - FILE_ATTRIBUTE_HIDDEN\n" + " * :O - FILE_ATTRIBUTE_READONLY\n" + " * :F - FILE_ATTRIBUTE_OFFLINE\n" + " * :T - FILE_ATTRIBUTE_TEMPORARY\n" + " * :d - FILE_FLAG_DELETE_ON_CLOSE\n" + " * :b - FILE_FLAG_NO_BUFFERING\n") { janet_arity(argc, 1, 3); const char *path = janet_getcstring(argv, 0); const uint8_t *opt_flags = janet_optkeyword(argv, argc, 1, (const uint8_t *) "r"); @@ -1934,7 +2121,11 @@ static Janet os_open(int32_t argc, Janet *argv) { return janet_wrap_abstract(janet_stream(fd, stream_flags, NULL)); } -static Janet os_pipe(int32_t argc, Janet *argv) { +JANET_CORE_FN(os_pipe, + "(os/pipe)", + "Create a readable stream and a writable stream that are connected. Returns a two element " + "tuple where the first element is a readable stream and the second element is the writable " + "stream.") { (void) argv; janet_fixarity(argc, 0); JanetHandle fds[2]; @@ -1949,330 +2140,75 @@ static Janet os_pipe(int32_t argc, Janet *argv) { #endif /* JANET_REDUCED_OS */ -static const JanetReg os_cfuns[] = { - { - "os/exit", os_exit, - JDOC("(os/exit &opt x)\n\n" - "Exit from janet with an exit code equal to x. If x is not an integer, " - "the exit with status equal the hash of x.") - }, - { - "os/which", os_which, - JDOC("(os/which)\n\n" - "Check the current operating system. Returns one of:\n\n" - "* :windows\n\n" - "* :macos\n\n" - "* :web - Web assembly (emscripten)\n\n" - "* :linux\n\n" - "* :freebsd\n\n" - "* :openbsd\n\n" - "* :netbsd\n\n" - "* :posix - A POSIX compatible system (default)\n\n" - "May also return a custom keyword specified at build time.") - }, - { - "os/arch", os_arch, - JDOC("(os/arch)\n\n" - "Check the ISA that janet was compiled for. Returns one of:\n\n" - "* :x86\n\n" - "* :x86-64\n\n" - "* :arm\n\n" - "* :aarch64\n\n" - "* :sparc\n\n" - "* :wasm\n\n" - "* :unknown\n") - }, -#ifndef JANET_REDUCED_OS - { - "os/environ", os_environ, - JDOC("(os/environ)\n\n" - "Get a copy of the os environment table.") - }, - { - "os/getenv", os_getenv, - JDOC("(os/getenv variable &opt dflt)\n\n" - "Get the string value of an environment variable.") - }, - { - "os/dir", os_dir, - JDOC("(os/dir dir &opt array)\n\n" - "Iterate over files and subdirectories in a directory. Returns an array of paths parts, " - "with only the file name or directory name and no prefix.") - }, - { - "os/stat", os_stat, - JDOC("(os/stat path &opt tab|key)\n\n" - "Gets information about a file or directory. Returns a table if the second argument is a keyword, returns " - " only that information from stat. If the file or directory does not exist, returns nil. The keys are:\n\n" - "* :dev - the device that the file is on\n\n" - "* :mode - the type of file, one of :file, :directory, :block, :character, :fifo, :socket, :link, or :other\n\n" - "* :int-permissions - A Unix permission integer like 8r744\n\n" - "* :permissions - A Unix permission string like \"rwxr--r--\"\n\n" - "* :uid - File uid\n\n" - "* :gid - File gid\n\n" - "* :nlink - number of links to file\n\n" - "* :rdev - Real device of file. 0 on windows.\n\n" - "* :size - size of file in bytes\n\n" - "* :blocks - number of blocks in file. 0 on windows\n\n" - "* :blocksize - size of blocks in file. 0 on windows\n\n" - "* :accessed - timestamp when file last accessed\n\n" - "* :changed - timestamp when file last changed (permissions changed)\n\n" - "* :modified - timestamp when file last modified (content changed)\n") - }, - { - "os/lstat", os_lstat, - JDOC("(os/lstat path &opt tab|key)\n\n" - "Like os/stat, but don't follow symlinks.\n") - }, - { - "os/chmod", os_chmod, - JDOC("(os/chmod path mode)\n\n" - "Change file permissions, where mode is a permission string as returned by " - "os/perm-string, or an integer as returned by os/perm-int. " - "When mode is an integer, it is interpreted as a Unix permission value, best specified in octal, like " - "8r666 or 8r400. Windows will not differentiate between user, group, and other permissions, and thus will combine all of these permissions. Returns nil.") - }, - { - "os/touch", os_touch, - JDOC("(os/touch path &opt actime modtime)\n\n" - "Update the access time and modification times for a file. By default, sets " - "times to the current time.") - }, - { - "os/cd", os_cd, - JDOC("(os/cd path)\n\n" - "Change current directory to path. Returns nil on success, errors on failure.") - }, -#ifndef JANET_NO_UMASK - { - "os/umask", os_umask, - JDOC("(os/umask mask)\n\n" - "Set a new umask, returns the old umask.") - }, -#endif - { - "os/mkdir", os_mkdir, - JDOC("(os/mkdir path)\n\n" - "Create a new directory. The path will be relative to the current directory if relative, otherwise " - "it will be an absolute path. Returns true if the directory was created, false if the directory already exists, and " - "errors otherwise.") - }, - { - "os/rmdir", os_rmdir, - JDOC("(os/rmdir path)\n\n" - "Delete a directory. The directory must be empty to succeed.") - }, - { - "os/rm", os_remove, - JDOC("(os/rm path)\n\n" - "Delete a file. Returns nil.") - }, - { - "os/link", os_link, - JDOC("(os/link oldpath newpath &opt symlink)\n\n" - "Create a link at newpath that points to oldpath and returns nil. " - "Iff symlink is truthy, creates a symlink. " - "Iff symlink is falsey or not provided, " - "creates a hard link. Does not work on Windows.") - }, -#ifndef JANET_NO_SYMLINKS - { - "os/symlink", os_symlink, - JDOC("(os/symlink oldpath newpath)\n\n" - "Create a symlink from oldpath to newpath, returning nil. Same as (os/link oldpath newpath true).") - }, - { - "os/readlink", os_readlink, - JDOC("(os/readlink path)\n\n" - "Read the contents of a symbolic link. Does not work on Windows.\n") - }, -#endif -#ifndef JANET_NO_PROCESSES - { - "os/execute", os_execute, - JDOC("(os/execute args &opt flags env)\n\n" - "Execute a program on the system and pass it string arguments. `flags` " - "is a keyword that modifies how the program will execute.\n\n" - "* :e - enables passing an environment to the program. Without :e, the " - "current environment is inherited.\n\n" - "* :p - allows searching the current PATH for the binary to execute. " - "Without this flag, binaries must use absolute paths.\n\n" - "* :x - raise error if exit code is non-zero.\n\n" - "`env` is a table or struct mapping environment variables to values. It can also " - "contain the keys :in, :out, and :err, which allow redirecting stdio in the subprocess. " - "These arguments should be core/file values. " - "One can also pass in the :pipe keyword " - "for these arguments to create files that will read (for :err and :out) or write (for :in) " - "to the file descriptor of the subprocess. This is only useful in `os/spawn`, which takes " - "the same parameters as `os/execute`, but will return an object that contains references to these " - "files via (return-value :in), (return-value :out), and (return-value :err). " - "Returns the exit status of the program.") - }, - { - "os/spawn", os_spawn, - JDOC("(os/spawn args &opt flags env)\n\n" - "Execute a program on the system and return a handle to the process. Otherwise, the " - "same arguments as os/execute. Does not wait for the process.") - }, - { - "os/shell", os_shell, - JDOC("(os/shell str)\n\n" - "Pass a command string str directly to the system shell.") - }, - { - "os/proc-wait", os_proc_wait, - JDOC("(os/proc-wait proc)\n\n" - "Block until the subprocess completes. Returns the subprocess return code.") - }, - { - "os/proc-kill", os_proc_kill, - JDOC("(os/proc-kill proc &opt wait)\n\n" - "Kill a subprocess by sending SIGKILL to it on posix systems, or by closing the process " - "handle on windows. If wait is truthy, will wait for the process to finsih and " - "returns the exit code. Otherwise, returns proc.") - }, - { - "os/proc-close", os_proc_close, - JDOC("(os/proc-close proc)\n\n" - "Wait on a process if it has not been waited on, and close pipes created by `os/spawn` " - "if they have not been closed. Returns nil.") - }, -#endif - { - "os/setenv", os_setenv, - JDOC("(os/setenv variable value)\n\n" - "Set an environment variable.") - }, - { - "os/time", os_time, - JDOC("(os/time)\n\n" - "Get the current time expressed as the number of seconds since " - "January 1, 1970, the Unix epoch. Returns a real number.") - }, - { - "os/mktime", os_mktime, - JDOC("(os/mktime date-struct &opt local)\n\n" - "Get the broken down date-struct time expressed as the number " - " of seconds since January 1, 1970, the Unix epoch. " - "Returns a real number. " - "Date is given in UTC unless local is truthy, in which case the " - "date is computed for the local timezone.\n\n" - "Inverse function to os/date.") - }, - { - "os/clock", os_clock, - JDOC("(os/clock)\n\n" - "Return the number of seconds since some fixed point in time. The clock " - "is guaranteed to be non decreasing in real time.") - }, - { - "os/sleep", os_sleep, - JDOC("(os/sleep n)\n\n" - "Suspend the program for n seconds. 'nsec' can be a real number. Returns " - "nil.") - }, - { - "os/cwd", os_cwd, - JDOC("(os/cwd)\n\n" - "Returns the current working directory.") - }, - { - "os/cryptorand", os_cryptorand, - JDOC("(os/cryptorand n &opt buf)\n\n" - "Get or append n bytes of good quality random data provided by the OS. Returns a new buffer or buf.") - }, - { - "os/date", os_date, - JDOC("(os/date &opt time local)\n\n" - "Returns the given time as a date struct, or the current time if `time` is not given. " - "Returns a struct with following key values. Note that all numbers are 0-indexed. " - "Date is given in UTC unless `local` is truthy, in which case the date is formatted for " - "the local timezone.\n\n" - "* :seconds - number of seconds [0-61]\n\n" - "* :minutes - number of minutes [0-59]\n\n" - "* :hours - number of hours [0-23]\n\n" - "* :month-day - day of month [0-30]\n\n" - "* :month - month of year [0, 11]\n\n" - "* :year - years since year 0 (e.g. 2019)\n\n" - "* :week-day - day of the week [0-6]\n\n" - "* :year-day - day of the year [0-365]\n\n" - "* :dst - if Day Light Savings is in effect") - }, - { - "os/rename", os_rename, - JDOC("(os/rename oldname newname)\n\n" - "Rename a file on disk to a new path. Returns nil.") - }, - { - "os/realpath", os_realpath, - JDOC("(os/realpath path)\n\n" - "Get the absolute path for a given path, following ../, ./, and symlinks. " - "Returns an absolute path as a string. Will raise an error on Windows.") - }, - { - "os/perm-string", os_permission_string, - JDOC("(os/perm-string int)\n\n" - "Convert a Unix octal permission value from a permission integer as returned by os/stat " - "to a human readable string, that follows the formatting " - "of unix tools like ls. Returns the string as a 9 character string of r, w, x and - characters. Does not " - "include the file/directory/symlink character as rendered by `ls`.") - }, - { - "os/perm-int", os_permission_int, - JDOC("(os/perm-int bytes)\n\n" - "Parse a 9 character permission string and return an integer that can be used by chmod.") - }, -#ifdef JANET_EV - { - "os/open", os_open, - JDOC("(os/open path &opt flags mode)\n\n" - "Create a stream from a file, like the POSIX open system call. Returns a new stream. " - "mode should be a file mode as passed to os/chmod, but only if the create flag is given. " - "The default mode is 8r666. " - "Allowed flags are as follows:\n\n" - " * :r - open this file for reading\n" - " * :w - open this file for writing\n" - " * :c - create a new file (O_CREATE)\n" - " * :e - fail if the file exists (O_EXCL)\n" - " * :t - shorten an existing file to length 0 (O_TRUNC)\n\n" - "Posix only flags:\n\n" - " * :a - append to a file (O_APPEND)\n" - " * :x - O_SYNC\n" - " * :C - O_NOCTTY\n\n" - "Windows only flags:\n\n" - " * :R - share reads (FILE_SHARE_READ)\n" - " * :W - share writes (FILE_SHARE_WRITE)\n" - " * :D - share deletes (FILE_SHARE_DELETE)\n" - " * :H - FILE_ATTRIBUTE_HIDDEN\n" - " * :O - FILE_ATTRIBUTE_READONLY\n" - " * :F - FILE_ATTRIBUTE_OFFLINE\n" - " * :T - FILE_ATTRIBUTE_TEMPORARY\n" - " * :d - FILE_FLAG_DELETE_ON_CLOSE\n" - " * :b - FILE_FLAG_NO_BUFFERING\n") - }, - { - "os/pipe", os_pipe, - JDOC("(os/pipe)\n\n" - "Create a readable stream and a writable stream that are connected. Returns a two element " - "tuple where the first element is a readable stream and the second element is the writable " - "stream.") - }, -#endif -#endif - {NULL, NULL, NULL} -}; - /* Module entry point */ void janet_lib_os(JanetTable *env) { #if !defined(JANET_REDUCED_OS) && defined(JANET_WINDOWS) && defined(JANET_THREADS) /* During start up, the top-most abstract machine (thread) * in the thread tree sets up the critical section. */ - if (!env_lock_initialized) { + static volatile long env_lock_initializing = 0; + static volatile long env_lock_initialized = 0; + if (!InterlockedExchange(&env_lock_initializing, 1)) { InitializeCriticalSection(&env_lock); - env_lock_initialized = 1; + InterlockedOr(&env_lock_initialized, 1); + } else { + while (!InterlockedOr(&env_lock_initialized, 0)) { + Sleep(0); + } } + #endif #ifndef JANET_NO_PROCESSES #endif - janet_core_cfuns(env, NULL, os_cfuns); + JanetRegExt os_cfuns[] = { + JANET_CORE_REG("os/exit", os_exit), + JANET_CORE_REG("os/which", os_which), + JANET_CORE_REG("os/arch", os_arch), +#ifndef JANET_REDUCED_OS + JANET_CORE_REG("os/environ", os_environ), + JANET_CORE_REG("os/getenv", os_getenv), + JANET_CORE_REG("os/dir", os_dir), + JANET_CORE_REG("os/stat", os_stat), + JANET_CORE_REG("os/lstat", os_lstat), + JANET_CORE_REG("os/chmod", os_chmod), + JANET_CORE_REG("os/touch", os_touch), + JANET_CORE_REG("os/cd", os_cd), +#ifndef JANET_NO_UMASK + JANET_CORE_REG("os/umask", os_umask), +#endif + JANET_CORE_REG("os/mkdir", os_mkdir), + JANET_CORE_REG("os/rmdir", os_rmdir), + JANET_CORE_REG("os/rm", os_remove), + JANET_CORE_REG("os/link", os_link), +#ifndef JANET_NO_SYMLINKS + JANET_CORE_REG("os/symlink", os_symlink), + JANET_CORE_REG("os/readlink", os_readlink), +#endif +#ifndef JANET_NO_PROCESSES + JANET_CORE_REG("os/execute", os_execute), + JANET_CORE_REG("os/spawn", os_spawn), + JANET_CORE_REG("os/shell", os_shell), + JANET_CORE_REG("os/proc-wait", os_proc_wait), + JANET_CORE_REG("os/proc-kill", os_proc_kill), + JANET_CORE_REG("os/proc-close", os_proc_close), +#endif + JANET_CORE_REG("os/setenv", os_setenv), + JANET_CORE_REG("os/time", os_time), + JANET_CORE_REG("os/mktime", os_mktime), + JANET_CORE_REG("os/clock", os_clock), + JANET_CORE_REG("os/sleep", os_sleep), + JANET_CORE_REG("os/cwd", os_cwd), + JANET_CORE_REG("os/cryptorand", os_cryptorand), + JANET_CORE_REG("os/date", os_date), + JANET_CORE_REG("os/rename", os_rename), + JANET_CORE_REG("os/realpath", os_realpath), + JANET_CORE_REG("os/perm-string", os_permission_string), + JANET_CORE_REG("os/perm-int", os_permission_int), +#ifdef JANET_EV + JANET_CORE_REG("os/open", os_open), + JANET_CORE_REG("os/pipe", os_pipe), +#endif +#endif + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, os_cfuns); } diff --git a/src/core/parse.c b/src/core/parse.c index fd05a2f3..f667fc18 100644 --- a/src/core/parse.c +++ b/src/core/parse.c @@ -51,15 +51,15 @@ static const uint32_t symchars[8] = { }; /* Check if a character is a valid symbol character - * symbol chars are A-Z, a-z, 0-9, or one of !$&*+-./:<=>@\^_~| */ -static int is_symbol_char(uint8_t c) { + * symbol chars are A-Z, a-z, 0-9, or one of !$&*+-./:<=>@\^_| */ +int janet_is_symbol_char(uint8_t c) { return symchars[c >> 5] & ((uint32_t)1 << (c & 0x1F)); } /* Validate some utf8. Useful for identifiers. Only validates * the encoding, does not check for valid code points (they * are less well defined than the encoding). */ -static int valid_utf8(const uint8_t *str, int32_t len) { +int janet_valid_utf8(const uint8_t *str, int32_t len) { int32_t i = 0; int32_t j; while (i < len) { @@ -411,7 +411,7 @@ static int tokenchar(JanetParser *p, JanetParseState *state, uint8_t c) { Janet ret; double numval; int32_t blen; - if (is_symbol_char(c)) { + if (janet_is_symbol_char(c)) { push_buf(p, (uint8_t) c); if (c > 127) state->argn = 1; /* Use to indicate non ascii */ return 1; @@ -422,7 +422,7 @@ static int tokenchar(JanetParser *p, JanetParseState *state, uint8_t c) { int start_num = start_dig || p->buf[0] == '-' || p->buf[0] == '+' || p->buf[0] == '.'; if (p->buf[0] == ':') { /* Don't do full utf-8 check unless we have seen non ascii characters. */ - int valid = (!state->argn) || valid_utf8(p->buf + 1, blen - 1); + int valid = (!state->argn) || janet_valid_utf8(p->buf + 1, blen - 1); if (!valid) { p->error = "invalid utf-8 in keyword"; return 0; @@ -442,7 +442,7 @@ static int tokenchar(JanetParser *p, JanetParseState *state, uint8_t c) { return 0; } else { /* Don't do full utf-8 check unless we have seen non ascii characters. */ - int valid = (!state->argn) || valid_utf8(p->buf, blen); + int valid = (!state->argn) || janet_valid_utf8(p->buf, blen); if (!valid) { p->error = "invalid utf-8 in symbol"; return 0; @@ -582,7 +582,7 @@ static int root(JanetParser *p, JanetParseState *state, uint8_t c) { switch (c) { default: if (is_whitespace(c)) return 1; - if (!is_symbol_char(c)) { + if (!janet_is_symbol_char(c)) { p->error = "unexpected character"; return 1; } @@ -878,7 +878,10 @@ const JanetAbstractType janet_parser_type = { }; /* C Function parser */ -static Janet cfun_parse_parser(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_parser, + "(parser/new)", + "Creates and returns a new parser object. Parsers are state machines " + "that can receive bytes, and generate a stream of values.") { (void) argv; janet_fixarity(argc, 0); JanetParser *p = janet_abstract(&janet_parser_type, sizeof(JanetParser)); @@ -886,7 +889,11 @@ static Janet cfun_parse_parser(int32_t argc, Janet *argv) { return janet_wrap_abstract(p); } -static Janet cfun_parse_consume(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_consume, + "(parser/consume parser bytes &opt index)", + "Input bytes into the parser and parse them. Will not throw errors " + "if there is a parse error. Starts at the byte index given by index. Returns " + "the number of bytes read.") { janet_arity(argc, 2, 3); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); JanetByteView view = janet_getbytes(argv, 1); @@ -911,14 +918,20 @@ static Janet cfun_parse_consume(int32_t argc, Janet *argv) { return janet_wrap_integer(i); } -static Janet cfun_parse_eof(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_eof, + "(parser/eof parser)", + "Indicate that the end of file was reached to the parser. This puts the parser in the :dead state.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); janet_parser_eof(p); return argv[0]; } -static Janet cfun_parse_insert(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_insert, + "(parser/insert parser value)", + "Insert a value into the parser. This means that the parser state can be manipulated " + "in between chunks of bytes. This would allow a user to add extra elements to arrays " + "and tuples, for example. Returns the parser.") { janet_fixarity(argc, 2); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); JanetParseState *s = p->states + p->statecount - 1; @@ -957,13 +970,17 @@ static Janet cfun_parse_insert(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_parse_has_more(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_has_more, + "(parser/has-more parser)", + "Check if the parser has more values in the value queue.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); return janet_wrap_boolean(janet_parser_has_more(p)); } -static Janet cfun_parse_byte(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_byte, + "(parser/byte parser b)", + "Input a single byte into the parser byte stream. Returns the parser.") { janet_fixarity(argc, 2); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); int32_t i = janet_getinteger(argv, 1); @@ -971,7 +988,13 @@ static Janet cfun_parse_byte(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_parse_status(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_status, + "(parser/status parser)", + "Gets the current status of the parser state machine. The status will " + "be one of:\n\n" + "* :pending - a value is being parsed.\n\n" + "* :error - a parsing error was encountered.\n\n" + "* :root - the parser can either read more values or safely terminate.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); const char *stat = NULL; @@ -992,7 +1015,12 @@ static Janet cfun_parse_status(int32_t argc, Janet *argv) { return janet_ckeywordv(stat); } -static Janet cfun_parse_error(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_error, + "(parser/error parser)", + "If the parser is in the error state, returns the message associated with " + "that error. Otherwise, returns nil. Also flushes the parser state and parser " + "queue, so be sure to handle everything in the queue before calling " + "parser/error.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); const char *err = janet_parser_error(p); @@ -1004,7 +1032,13 @@ static Janet cfun_parse_error(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet cfun_parse_produce(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_produce, + "(parser/produce parser &opt wrap)", + "Dequeue the next value in the parse queue. Will return nil if " + "no parsed values are in the queue, otherwise will dequeue the " + "next value. If `wrap` is truthy, will return a 1-element tuple that " + "wraps the result. This tuple can be used for source-mapping " + "purposes.") { janet_arity(argc, 1, 2); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); if (argc == 2 && janet_truthy(argv[1])) { @@ -1014,14 +1048,22 @@ static Janet cfun_parse_produce(int32_t argc, Janet *argv) { } } -static Janet cfun_parse_flush(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_flush, + "(parser/flush parser)", + "Clears the parser state and parse queue. Can be used to reset the parser " + "if an error was encountered. Does not reset the line and column counter, so " + "to begin parsing in a new context, create a new parser.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); janet_parser_flush(p); return argv[0]; } -static Janet cfun_parse_where(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_where, + "(parser/where parser &opt line col)", + "Returns the current line number and column of the parser's internal state. If line is " + "provided, the current line number of the parser is first set to that value. If column is " + "also provided, the current column number of the parser is also first set to that value.") { janet_arity(argc, 1, 3); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); if (argc > 1) { @@ -1162,7 +1204,16 @@ static const struct ParserStateGetter parser_state_getters[] = { {NULL, NULL} }; -static Janet cfun_parse_state(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_state, + "(parser/state parser &opt key)", + "Returns a representation of the internal state of the parser. If a key is passed, " + "only that information about the state is returned. Allowed keys are:\n\n" + "* :delimiters - Each byte in the string represents a nested data structure. For example, " + "if the parser state is '([\"', then the parser is in the middle of parsing a " + "string inside of square brackets inside parentheses. Can be used to augment a REPL prompt.\n\n" + "* :frames - Each table in the array represents a 'frame' in the parser state. Frames " + "contain information about the start of the expression being parsed as well as the " + "type of that expression and some type-specific information.") { janet_arity(argc, 1, 2); const uint8_t *key = NULL; JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); @@ -1190,7 +1241,11 @@ static Janet cfun_parse_state(int32_t argc, Janet *argv) { } } -static Janet cfun_parse_clone(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_parse_clone, + "(parser/clone p)", + "Creates a deep clone of a parser that is identical to the input parser. " + "This cloned parser can be used to continue parsing from a good checkpoint " + "if parsing later fails. Returns a new parser.") { janet_fixarity(argc, 1); JanetParser *src = janet_getabstract(argv, 0, &janet_parser_type); JanetParser *dest = janet_abstract(&janet_parser_type, sizeof(JanetParser)); @@ -1225,105 +1280,23 @@ static Janet parsernext(void *p, Janet key) { return janet_nextmethod(parser_methods, key); } -static const JanetReg parse_cfuns[] = { - { - "parser/new", cfun_parse_parser, - JDOC("(parser/new)\n\n" - "Creates and returns a new parser object. Parsers are state machines " - "that can receive bytes, and generate a stream of values.") - }, - { - "parser/clone", cfun_parse_clone, - JDOC("(parser/clone p)\n\n" - "Creates a deep clone of a parser that is identical to the input parser. " - "This cloned parser can be used to continue parsing from a good checkpoint " - "if parsing later fails. Returns a new parser.") - }, - { - "parser/has-more", cfun_parse_has_more, - JDOC("(parser/has-more parser)\n\n" - "Check if the parser has more values in the value queue.") - }, - { - "parser/produce", cfun_parse_produce, - JDOC("(parser/produce parser &opt wrap)\n\n" - "Dequeue the next value in the parse queue. Will return nil if " - "no parsed values are in the queue, otherwise will dequeue the " - "next value. If `wrap` is truthy, will return a 1-element tuple that " - "wraps the result. This tuple can be used for source-mapping " - "purposes.") - }, - { - "parser/consume", cfun_parse_consume, - JDOC("(parser/consume parser bytes &opt index)\n\n" - "Input bytes into the parser and parse them. Will not throw errors " - "if there is a parse error. Starts at the byte index given by index. Returns " - "the number of bytes read.") - }, - { - "parser/byte", cfun_parse_byte, - JDOC("(parser/byte parser b)\n\n" - "Input a single byte into the parser byte stream. Returns the parser.") - }, - { - "parser/error", cfun_parse_error, - JDOC("(parser/error parser)\n\n" - "If the parser is in the error state, returns the message associated with " - "that error. Otherwise, returns nil. Also flushes the parser state and parser " - "queue, so be sure to handle everything in the queue before calling " - "parser/error.") - }, - { - "parser/status", cfun_parse_status, - JDOC("(parser/status parser)\n\n" - "Gets the current status of the parser state machine. The status will " - "be one of:\n\n" - "* :pending - a value is being parsed.\n\n" - "* :error - a parsing error was encountered.\n\n" - "* :root - the parser can either read more values or safely terminate.") - }, - { - "parser/flush", cfun_parse_flush, - JDOC("(parser/flush parser)\n\n" - "Clears the parser state and parse queue. Can be used to reset the parser " - "if an error was encountered. Does not reset the line and column counter, so " - "to begin parsing in a new context, create a new parser.") - }, - { - "parser/state", cfun_parse_state, - JDOC("(parser/state parser &opt key)\n\n" - "Returns a representation of the internal state of the parser. If a key is passed, " - "only that information about the state is returned. Allowed keys are:\n\n" - "* :delimiters - Each byte in the string represents a nested data structure. For example, " - "if the parser state is '([\"', then the parser is in the middle of parsing a " - "string inside of square brackets inside parentheses. Can be used to augment a REPL prompt.\n\n" - "* :frames - Each table in the array represents a 'frame' in the parser state. Frames " - "contain information about the start of the expression being parsed as well as the " - "type of that expression and some type-specific information.") - }, - { - "parser/where", cfun_parse_where, - JDOC("(parser/where parser &opt line col)\n\n" - "Returns the current line number and column of the parser's internal state. If line is " - "provided, the current line number of the parser is first set to that value. If column is " - "also provided, the current column number of the parser is also first set to that value.") - }, - { - "parser/eof", cfun_parse_eof, - JDOC("(parser/eof parser)\n\n" - "Indicate that the end of file was reached to the parser. This puts the parser in the :dead state.") - }, - { - "parser/insert", cfun_parse_insert, - JDOC("(parser/insert parser value)\n\n" - "Insert a value into the parser. This means that the parser state can be manipulated " - "in between chunks of bytes. This would allow a user to add extra elements to arrays " - "and tuples, for example. Returns the parser.") - }, - {NULL, NULL, NULL} -}; - /* Load the library */ void janet_lib_parse(JanetTable *env) { - janet_core_cfuns(env, NULL, parse_cfuns); + JanetRegExt parse_cfuns[] = { + JANET_CORE_REG("parser/new", cfun_parse_parser), + JANET_CORE_REG("parser/clone", cfun_parse_clone), + JANET_CORE_REG("parser/has-more", cfun_parse_has_more), + JANET_CORE_REG("parser/produce", cfun_parse_produce), + JANET_CORE_REG("parser/consume", cfun_parse_consume), + JANET_CORE_REG("parser/byte", cfun_parse_byte), + JANET_CORE_REG("parser/error", cfun_parse_error), + JANET_CORE_REG("parser/status", cfun_parse_status), + JANET_CORE_REG("parser/flush", cfun_parse_flush), + JANET_CORE_REG("parser/state", cfun_parse_state), + JANET_CORE_REG("parser/where", cfun_parse_where), + JANET_CORE_REG("parser/eof", cfun_parse_eof), + JANET_CORE_REG("parser/insert", cfun_parse_insert), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, parse_cfuns); } diff --git a/src/core/peg.c b/src/core/peg.c index 6377305f..41f64229 100644 --- a/src/core/peg.c +++ b/src/core/peg.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -387,6 +387,25 @@ tail: return result; } + case RULE_CAPTURE_NUM: { + down1(s); + const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); + up1(s); + if (!result) return NULL; + /* check number parsing */ + double x = 0.0; + int32_t base = (int32_t) rule[2]; + if (janet_scan_number_base(text, (int32_t)(result - text), base, &x)) return NULL; + /* Specialized pushcap - avoid intermediate string creation */ + if (!s->has_backref && s->mode == PEG_MODE_ACCUMULATE) { + janet_buffer_push_bytes(s->scratch, text, (int32_t)(result - text)); + } else { + uint32_t tag = rule[3]; + pushcap(s, janet_wrap_number(x), tag); + } + return result; + } + case RULE_ACCUMULATE: { uint32_t tag = rule[2]; int oldmode = s->mode; @@ -975,6 +994,25 @@ static void spec_unref(Builder *b, int32_t argc, const Janet *argv) { spec_cap1(b, argc, argv, RULE_UNREF); } +static void spec_capture_number(Builder *b, int32_t argc, const Janet *argv) { + peg_arity(b, argc, 1, 3); + Reserve r = reserve(b, 4); + uint32_t base = 0; + if (argc >= 2) { + if (!janet_checktype(argv[1], JANET_NIL)) { + if (!janet_checkint(argv[1])) goto error; + base = (uint32_t) janet_unwrap_integer(argv[1]); + if (base < 2 || base > 36) goto error; + } + } + uint32_t tag = (argc == 3) ? emit_tag(b, argv[2]) : 0; + uint32_t rule = peg_compile1(b, argv[0]); + emit_3(r, RULE_CAPTURE_NUM, rule, base, tag); + return; +error: + peg_panicf(b, "expected integer between 2 and 36, got %v", argv[2]); +} + static void spec_reference(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 1, 2); Reserve r = reserve(b, 3); @@ -1118,6 +1156,7 @@ static const SpecialPair peg_specials[] = { {"line", spec_line}, {"look", spec_look}, {"not", spec_not}, + {"number", spec_capture_number}, {"opt", spec_opt}, {"position", spec_position}, {"quote", spec_capture}, @@ -1214,6 +1253,18 @@ static uint32_t peg_compile1(Builder *b, Janet peg) { emit_bytes(b, RULE_LITERAL, len, str); break; } + case JANET_TABLE: { + /* Build grammar table */ + JanetTable *new_grammar = janet_table_clone(janet_unwrap_table(peg)); + new_grammar->proto = grammar; + b->grammar = grammar = new_grammar; + /* Run the main rule */ + Janet main_rule = janet_table_rawget(grammar, janet_ckeywordv("main")); + if (janet_checktype(main_rule, JANET_NIL)) + peg_panic(b, "grammar requires :main rule"); + rule = peg_compile1(b, main_rule); + break; + } case JANET_STRUCT: { /* Build grammar table */ const JanetKV *st = janet_unwrap_struct(peg); @@ -1419,6 +1470,12 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { if (rule[1] >= clen) goto bad; i += 3; break; + case RULE_CAPTURE_NUM: + /* [rule, base, tag] */ + if (rule[1] >= blen) goto bad; + op_flags[rule[1]] |= 0x01; + i += 4; + break; case RULE_ACCUMULATE: case RULE_GROUP: case RULE_CAPTURE: @@ -1541,7 +1598,11 @@ static JanetPeg *compile_peg(Janet x) { * C Functions */ -static Janet cfun_peg_compile(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_peg_compile, + "(peg/compile peg)", + "Compiles a peg source data structure into a . This will speed up matching " + "if the same peg will be used multiple times. Will also use `(dyn :peg-grammar)` to suppliment " + "the grammar of the peg for otherwise undefined peg keywords.") { janet_fixarity(argc, 1); JanetPeg *peg = compile_peg(argv[0]); return janet_wrap_abstract(peg); @@ -1604,13 +1665,18 @@ static void peg_call_reset(PegCall *c) { c->s.tags->count = 0; } -static Janet cfun_peg_match(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_peg_match, + "(peg/match peg text &opt start & args)", + "Match a Parsing Expression Grammar to a byte string and return an array of captured values. " + "Returns nil if text does not match the language defined by peg. The syntax of PEGs is documented on the Janet website.") { PegCall c = peg_cfun_init(argc, argv, 0); const uint8_t *result = peg_rule(&c.s, c.s.bytecode, c.bytes.bytes + c.start); return result ? janet_wrap_array(c.s.captures) : janet_wrap_nil(); } -static Janet cfun_peg_find(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_peg_find, + "(peg/find peg text &opt start & args)", + "Find first index where the peg matches in text. Returns an integer, or nil if not found.") { PegCall c = peg_cfun_init(argc, argv, 0); for (int32_t i = c.start; i < c.bytes.len; i++) { peg_call_reset(&c); @@ -1620,7 +1686,9 @@ static Janet cfun_peg_find(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet cfun_peg_find_all(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_peg_find_all, + "(peg/find-all peg text &opt start & args)", + "Find all indexes where the peg matches in text. Returns an array of integers.") { PegCall c = peg_cfun_init(argc, argv, 0); JanetArray *ret = janet_array(0); for (int32_t i = c.start; i < c.bytes.len; i++) { @@ -1659,11 +1727,16 @@ static Janet cfun_peg_replace_generic(int32_t argc, Janet *argv, int only_one) { return janet_wrap_buffer(ret); } -static Janet cfun_peg_replace_all(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_peg_replace_all, + "(peg/replace-all peg repl text &opt start & args)", + "Replace all matches of peg in text with repl, returning a new buffer. The peg does not need to make captures to do replacement.") { return cfun_peg_replace_generic(argc, argv, 0); } -static Janet cfun_peg_replace(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_peg_replace, + "(peg/replace peg repl text &opt start & args)", + "Replace first match of peg in text with repl, returning a new buffer. The peg does not need to make captures to do replacement. " + "If no matches are found, returns the input string in a new buffer.") { return cfun_peg_replace_generic(argc, argv, 1); } @@ -1688,47 +1761,18 @@ static Janet peg_next(void *p, Janet key) { return janet_nextmethod(peg_methods, key); } -static const JanetReg peg_cfuns[] = { - { - "peg/compile", cfun_peg_compile, - JDOC("(peg/compile peg)\n\n" - "Compiles a peg source data structure into a . This will speed up matching " - "if the same peg will be used multiple times. Will also use `(dyn :peg-grammar)` to suppliment " - "the grammar of the peg for otherwise undefined peg keywords.") - }, - { - "peg/match", cfun_peg_match, - JDOC("(peg/match peg text &opt start & args)\n\n" - "Match a Parsing Expression Grammar to a byte string and return an array of captured values. " - "Returns nil if text does not match the language defined by peg. The syntax of PEGs is documented on the Janet website.") - }, - { - "peg/find", cfun_peg_find, - JDOC("(peg/find peg text &opt start & args)\n\n" - "Find first index where the peg matches in text. Returns an integer, or nil if not found.") - }, - { - "peg/find-all", cfun_peg_find_all, - JDOC("(peg/find-all peg text &opt start & args)\n\n" - "Find all indexes where the peg matches in text. Returns an array of integers.") - }, - { - "peg/replace", cfun_peg_replace, - JDOC("(peg/replace peg repl text &opt start & args)\n\n" - "Replace first match of peg in text with repl, returning a new buffer. The peg does not need to make captures to do replacement. " - "If no matches are found, returns the input string in a new buffer.") - }, - { - "peg/replace-all", cfun_peg_replace_all, - JDOC("(peg/replace-all peg repl text &opt start & args)\n\n" - "Replace all matches of peg in text with repl, returning a new buffer. The peg does not need to make captures to do replacement.") - }, - {NULL, NULL, NULL} -}; - /* Load the peg module */ void janet_lib_peg(JanetTable *env) { - janet_core_cfuns(env, NULL, peg_cfuns); + JanetRegExt cfuns[] = { + JANET_CORE_REG("peg/compile", cfun_peg_compile), + JANET_CORE_REG("peg/match", cfun_peg_match), + JANET_CORE_REG("peg/find", cfun_peg_find), + JANET_CORE_REG("peg/find-all", cfun_peg_find_all), + JANET_CORE_REG("peg/replace", cfun_peg_replace), + JANET_CORE_REG("peg/replace-all", cfun_peg_replace_all), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, cfuns); janet_register_abstract_type(&janet_peg_type); } diff --git a/src/core/pp.c b/src/core/pp.c index 7ccb0142..ac20c6c2 100644 --- a/src/core/pp.c +++ b/src/core/pp.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -227,12 +227,14 @@ void janet_to_string_b(JanetBuffer *buffer, Janet x) { } return; case JANET_CFUNCTION: { - Janet check = janet_table_get(janet_vm_registry, x); - if (janet_checktype(check, JANET_SYMBOL)) { + JanetCFunRegistry *reg = janet_registry_get(janet_unwrap_cfunction(x)); + if (NULL != reg) { janet_buffer_push_cstring(buffer, "name_prefix) { + janet_buffer_push_cstring(buffer, reg->name_prefix); + janet_buffer_push_u8(buffer, '/'); + } + janet_buffer_push_cstring(buffer, reg->name); janet_buffer_push_u8(buffer, '>'); break; } @@ -259,21 +261,13 @@ void janet_to_string_b(JanetBuffer *buffer, Janet x) { /* See parse.c for full table */ -static const uint32_t pp_symchars[8] = { - 0x00000000, 0xf7ffec72, 0xc7ffffff, 0x07fffffe, - 0x00000000, 0x00000000, 0x00000000, 0x00000000 -}; - -static int pp_is_symbol_char(uint8_t c) { - return pp_symchars[c >> 5] & ((uint32_t)1 << (c & 0x1F)); -} - /* Check if a symbol or keyword contains no symbol characters */ static int contains_bad_chars(const uint8_t *sym, int issym) { int32_t len = janet_string_length(sym); if (len && issym && sym[0] >= '0' && sym[0] <= '9') return 1; + if (!janet_valid_utf8(sym, len)) return 1; for (int32_t i = 0; i < len; i++) { - if (!pp_is_symbol_char(sym[i])) return 1; + if (!janet_is_symbol_char(sym[i])) return 1; } return 0; } @@ -898,7 +892,7 @@ void janet_formatbv(JanetBuffer *b, const char *format, va_list args) { } } if (nb >= MAX_ITEM) - janet_panicf("format buffer overflow", form); + janet_panic("format buffer overflow"); if (nb > 0) janet_buffer_push_bytes(b, (uint8_t *) item, nb); } @@ -1050,7 +1044,7 @@ void janet_buffer_format( } } if (nb >= MAX_ITEM) - janet_panicf("format buffer overflow", form); + janet_panic("format buffer overflow"); if (nb > 0) janet_buffer_push_bytes(b, (uint8_t *) item, nb); } diff --git a/src/core/regalloc.c b/src/core/regalloc.c index edddcb59..4166c649 100644 --- a/src/core/regalloc.c +++ b/src/core/regalloc.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/regalloc.h b/src/core/regalloc.h index d1872bb0..03f9bc09 100644 --- a/src/core/regalloc.h +++ b/src/core/regalloc.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/run.c b/src/core/run.c index f675810a..f90a640c 100644 --- a/src/core/run.c +++ b/src/core/run.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -79,7 +79,9 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char const char *e = janet_parser_error(&parser); errflags |= 0x04; ret = janet_cstringv(e); - janet_eprintf("parse error in %s: %s\n", sourcePath, e); + int32_t line = parser.line; + int32_t col = parser.column; + janet_eprintf("%s:%d:%d: parse error: %s\n", sourcePath, line, col, e); done = 1; break; } @@ -108,3 +110,19 @@ int janet_dostring(JanetTable *env, const char *str, const char *sourcePath, Jan return janet_dobytes(env, (const uint8_t *)str, len, sourcePath, out); } +/* Run a fiber to completion (use event loop if enabled). Return the status. */ +int janet_loop_fiber(JanetFiber *fiber) { + int status; +#ifdef JANET_EV + janet_schedule(fiber, janet_wrap_nil()); + janet_loop(); + status = janet_fiber_status(fiber); +#else + Janet out; + status = janet_continue(fiber, janet_wrap_nil(), &out); + if (status != JANET_SIGNAL_OK && status != JANET_SIGNAL_EVENT) { + janet_stacktrace(fiber, out); + } +#endif + return status; +} diff --git a/src/core/specials.c b/src/core/specials.c index 3688eb72..2734a827 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -410,7 +410,9 @@ static JanetSlot janetc_if(JanetFopts opts, int32_t argn, const Janet *argv) { right = janetc_value(bodyopts, truebody); if (!drop && !tail) janetc_copy(c, target, right); janetc_popscope(c); - janetc_throwaway(bodyopts, falsebody); + if (!janet_checktype(falsebody, JANET_NIL)) { + janetc_throwaway(bodyopts, falsebody); + } janetc_popscope(c); return target; } diff --git a/test/install/testmod.c b/src/core/state.c similarity index 57% rename from test/install/testmod.c rename to src/core/state.c index d104e4c9..ffe9e660 100644 --- a/test/install/testmod.c +++ b/src/core/state.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose and contributors +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -20,21 +20,42 @@ * IN THE SOFTWARE. */ -/* A very simple native module */ - +#ifndef JANET_AMALG +#include "features.h" #include +#include "state.h" +#endif -static Janet cfun_get_five(int32_t argc, Janet *argv) { - (void) argv; - janet_fixarity(argc, 0); - return janet_wrap_number(5.0); +JANET_THREAD_LOCAL JanetVM janet_vm; + +JanetVM *janet_local_vm(void) { + return &janet_vm; } -static const JanetReg array_cfuns[] = { - {"get5", cfun_get_five, NULL}, - {NULL, NULL, NULL} -}; - -JANET_MODULE_ENTRY(JanetTable *env) { - janet_cfuns(env, NULL, array_cfuns); +JanetVM *janet_vm_alloc(void) { + JanetVM *mem = janet_malloc(sizeof(JanetVM)); + if (NULL == mem) { + JANET_OUT_OF_MEMORY; + } + return mem; +} + +void janet_vm_free(JanetVM *vm) { + janet_free(vm); +} + +void janet_vm_save(JanetVM *into) { + *into = janet_vm; +} + +void janet_vm_load(JanetVM *from) { + janet_vm = *from; +} + +/* Trigger suspension of the Janet vm by trying to + * exit the interpeter loop when convenient. You can optionally + * use NULL to interrupt the current VM when convenient */ +void janet_interpreter_interrupt(JanetVM *vm) { + vm = vm ? vm : &janet_vm; + vm->auto_suspend = 1; } diff --git a/src/core/state.h b/src/core/state.h index a36f5e38..c844fb31 100644 --- a/src/core/state.h +++ b/src/core/state.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -25,81 +25,151 @@ #include -/* The VM state. Rather than a struct that is passed - * around, the vm state is global for simplicity. If - * at some point a global state object, or context, - * is required to be passed around, this is what would - * be in it. However, thread local global variables for interpreter - * state should allow easy multi-threading. */ +typedef int64_t JanetTimestamp; -typedef struct JanetScratch JanetScratch; +typedef struct JanetScratch { + JanetScratchFinalizer finalize; + long long mem[]; /* for proper alignment */ +} JanetScratch; -/* Top level dynamic bindings */ -extern JANET_THREAD_LOCAL JanetTable *janet_vm_top_dyns; - -/* Cache the core environment */ -extern JANET_THREAD_LOCAL JanetTable *janet_vm_core_env; - -/* How many VM stacks have been entered */ -extern JANET_THREAD_LOCAL int janet_vm_stackn; - -/* The current running fiber on the current thread. - * Set and unset by janet_run. */ -extern JANET_THREAD_LOCAL JanetFiber *janet_vm_fiber; -extern JANET_THREAD_LOCAL JanetFiber *janet_vm_root_fiber; - -/* The current pointer to the inner most jmp_buf. The current - * return point for panics. */ -extern JANET_THREAD_LOCAL jmp_buf *janet_vm_jmp_buf; -extern JANET_THREAD_LOCAL Janet *janet_vm_return_reg; - -/* The global registry for c functions. Used to store meta-data - * along with otherwise bare c function pointers. */ -extern JANET_THREAD_LOCAL JanetTable *janet_vm_registry; - -/* Registry for abstract abstract types that can be marshalled. - * We need this to look up the constructors when unmarshalling. */ -extern JANET_THREAD_LOCAL JanetTable *janet_vm_abstract_registry; - -/* Immutable value cache */ -extern JANET_THREAD_LOCAL const uint8_t **janet_vm_cache; -extern JANET_THREAD_LOCAL uint32_t janet_vm_cache_capacity; -extern JANET_THREAD_LOCAL uint32_t janet_vm_cache_count; -extern JANET_THREAD_LOCAL uint32_t janet_vm_cache_deleted; - -/* Garbage collection */ -extern JANET_THREAD_LOCAL void *janet_vm_blocks; -extern JANET_THREAD_LOCAL size_t janet_vm_gc_interval; -extern JANET_THREAD_LOCAL size_t janet_vm_next_collection; -extern JANET_THREAD_LOCAL size_t janet_vm_block_count; -extern JANET_THREAD_LOCAL int janet_vm_gc_suspend; - -/* GC roots */ -extern JANET_THREAD_LOCAL Janet *janet_vm_roots; -extern JANET_THREAD_LOCAL size_t janet_vm_root_count; -extern JANET_THREAD_LOCAL size_t janet_vm_root_capacity; - -/* Scratch memory */ -extern JANET_THREAD_LOCAL JanetScratch **janet_scratch_mem; -extern JANET_THREAD_LOCAL size_t janet_scratch_cap; -extern JANET_THREAD_LOCAL size_t janet_scratch_len; - -/* Recursionless traversal of data structures */ typedef struct { JanetGCObject *self; JanetGCObject *other; int32_t index; int32_t index2; } JanetTraversalNode; -extern JANET_THREAD_LOCAL JanetTraversalNode *janet_vm_traversal; -extern JANET_THREAD_LOCAL JanetTraversalNode *janet_vm_traversal_top; -extern JANET_THREAD_LOCAL JanetTraversalNode *janet_vm_traversal_base; -/* Setup / teardown */ -#ifdef JANET_THREADS -void janet_threads_init(void); -void janet_threads_deinit(void); +typedef struct { + int32_t capacity; + int32_t head; + int32_t tail; + void *data; +} JanetQueue; + +typedef struct { + JanetTimestamp when; + JanetFiber *fiber; + JanetFiber *curr_fiber; + uint32_t sched_id; + int is_error; +} JanetTimeout; + +/* Registry table for C functions - containts metadata that can + * be looked up by cfunction pointer. All strings here are pointing to + * static memory not managed by Janet. */ +typedef struct { + JanetCFunction cfun; + const char *name; + const char *name_prefix; + const char *source_file; + int32_t source_line; + /* int32_t min_arity; */ + /* int32_t max_arity; */ +} JanetCFunRegistry; + +struct JanetVM { + /* Place for user data */ + void *user; + + /* Top level dynamic bindings */ + JanetTable *top_dyns; + + /* Cache the core environment */ + JanetTable *core_env; + + /* How many VM stacks have been entered */ + int stackn; + + /* If this flag is true, suspend on function calls and backwards jumps. + * When this occurs, this flag will be reset to 0. */ + int auto_suspend; + + /* The current running fiber on the current thread. + * Set and unset by janet_run. */ + JanetFiber *fiber; + JanetFiber *root_fiber; + + /* The current pointer to the inner most jmp_buf. The current + * return point for panics. */ + jmp_buf *signal_buf; + Janet *return_reg; + + /* The global registry for c functions. Used to store meta-data + * along with otherwise bare c function pointers. */ + JanetCFunRegistry *registry; + size_t registry_cap; + size_t registry_count; + int registry_dirty; + + /* Registry for abstract abstract types that can be marshalled. + * We need this to look up the constructors when unmarshalling. */ + JanetTable *abstract_registry; + + /* Immutable value cache */ + const uint8_t **cache; + uint32_t cache_capacity; + uint32_t cache_count; + uint32_t cache_deleted; + uint8_t gensym_counter[8]; + + /* Garbage collection */ + void *blocks; + size_t gc_interval; + size_t next_collection; + size_t block_count; + int gc_suspend; + + /* GC roots */ + Janet *roots; + size_t root_count; + size_t root_capacity; + + /* Scratch memory */ + JanetScratch **scratch_mem; + size_t scratch_cap; + size_t scratch_len; + + /* Random number generator */ + JanetRNG rng; + + /* Traversal pointers */ + JanetTraversalNode *traversal; + JanetTraversalNode *traversal_top; + JanetTraversalNode *traversal_base; + + /* Event loop and scheduler globals */ +#ifdef JANET_EV + size_t tq_count; + size_t tq_capacity; + JanetQueue spawn; + JanetTimeout *tq; + JanetRNG ev_rng; + JanetListenerState **listeners; + size_t listener_count; + size_t listener_cap; + size_t extra_listeners; + JanetTable threaded_abstracts; /* All abstract types that can be shared between threads (used in this thread) */ +#ifdef JANET_WINDOWS + void **iocp; +#elif defined(JANET_EV_EPOLL) + JanetHandle selfpipe[2]; + int epoll; + int timerfd; + int timer_enabled; +#elif defined(JANET_EV_KQUEUE) + JanetHandle selfpipe[2]; + int kq; + int timer; + int timer_enabled; +#else + JanetHandle selfpipe[2]; + struct pollfd *fds; #endif +#endif + +}; + +extern JANET_THREAD_LOCAL JanetVM janet_vm; #ifdef JANET_NET void janet_net_init(void); diff --git a/src/core/string.c b/src/core/string.c index eb913b49..cc895bc6 100644 --- a/src/core/string.c +++ b/src/core/string.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -170,25 +170,37 @@ static int32_t kmp_next(struct kmp_state *state) { /* CFuns */ -static Janet cfun_string_slice(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_slice, + "(string/slice bytes &opt start end)", + "Returns a substring from a byte sequence. The substring is from " + "index start inclusive to index end exclusive. All indexing " + "is from 0. 'start' and 'end' can also be negative to indicate indexing " + "from the end of the string. Note that index -1 is synonymous with " + "index (length bytes) to allow a full negative slice range. ") { JanetByteView view = janet_getbytes(argv, 0); JanetRange range = janet_getslice(argc, argv); return janet_stringv(view.bytes + range.start, range.end - range.start); } -static Janet cfun_symbol_slice(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_symbol_slice, + "(symbol/slice bytes &opt start end)", + "Same a string/slice, but returns a symbol.") { JanetByteView view = janet_getbytes(argv, 0); JanetRange range = janet_getslice(argc, argv); return janet_symbolv(view.bytes + range.start, range.end - range.start); } -static Janet cfun_keyword_slice(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_keyword_slice, + "(keyword/slice bytes &opt start end)", + "Same a string/slice, but returns a keyword.") { JanetByteView view = janet_getbytes(argv, 0); JanetRange range = janet_getslice(argc, argv); return janet_keywordv(view.bytes + range.start, range.end - range.start); } -static Janet cfun_string_repeat(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_repeat, + "(string/repeat bytes n)", + "Returns a string that is n copies of bytes concatenated.") { janet_fixarity(argc, 2); JanetByteView view = janet_getbytes(argv, 0); int32_t rep = janet_getinteger(argv, 1); @@ -204,7 +216,9 @@ static Janet cfun_string_repeat(int32_t argc, Janet *argv) { return janet_wrap_string(janet_string_end(newbuf)); } -static Janet cfun_string_bytes(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_bytes, + "(string/bytes str)", + "Returns a tuple of integers that are the byte values of the string.") { janet_fixarity(argc, 1); JanetByteView view = janet_getbytes(argv, 0); Janet *tup = janet_tuple_begin(view.len); @@ -215,7 +229,10 @@ static Janet cfun_string_bytes(int32_t argc, Janet *argv) { return janet_wrap_tuple(janet_tuple_end(tup)); } -static Janet cfun_string_frombytes(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_frombytes, + "(string/from-bytes & byte-vals)", + "Creates a string from integer parameters with byte values. All integers " + "will be coerced to the range of 1 byte 0-255.") { int32_t i; uint8_t *buf = janet_string_begin(argc); for (i = 0; i < argc; i++) { @@ -225,7 +242,11 @@ static Janet cfun_string_frombytes(int32_t argc, Janet *argv) { return janet_wrap_string(janet_string_end(buf)); } -static Janet cfun_string_asciilower(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_asciilower, + "(string/ascii-lower str)", + "Returns a new string where all bytes are replaced with the " + "lowercase version of themselves in ASCII. Does only a very simple " + "case check, meaning no unicode support.") { janet_fixarity(argc, 1); JanetByteView view = janet_getbytes(argv, 0); uint8_t *buf = janet_string_begin(view.len); @@ -240,7 +261,11 @@ static Janet cfun_string_asciilower(int32_t argc, Janet *argv) { return janet_wrap_string(janet_string_end(buf)); } -static Janet cfun_string_asciiupper(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_asciiupper, + "(string/ascii-upper str)", + "Returns a new string where all bytes are replaced with the " + "uppercase version of themselves in ASCII. Does only a very simple " + "case check, meaning no unicode support.") { janet_fixarity(argc, 1); JanetByteView view = janet_getbytes(argv, 0); uint8_t *buf = janet_string_begin(view.len); @@ -255,7 +280,9 @@ static Janet cfun_string_asciiupper(int32_t argc, Janet *argv) { return janet_wrap_string(janet_string_end(buf)); } -static Janet cfun_string_reverse(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_reverse, + "(string/reverse str)", + "Returns a string that is the reversed version of str.") { janet_fixarity(argc, 1); JanetByteView view = janet_getbytes(argv, 0); uint8_t *buf = janet_string_begin(view.len); @@ -279,7 +306,11 @@ static void findsetup(int32_t argc, Janet *argv, struct kmp_state *s, int32_t ex s->i = start; } -static Janet cfun_string_find(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_find, + "(string/find patt str &opt start-index)", + "Searches for the first instance of pattern patt in string " + "str. Returns the index of the first character in patt if found, " + "otherwise returns nil.") { int32_t result; struct kmp_state state; findsetup(argc, argv, &state, 0); @@ -290,7 +321,9 @@ static Janet cfun_string_find(int32_t argc, Janet *argv) { : janet_wrap_integer(result); } -static Janet cfun_string_hasprefix(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_hasprefix, + "(string/has-prefix? pfx str)", + "Tests whether str starts with pfx.") { janet_fixarity(argc, 2); JanetByteView prefix = janet_getbytes(argv, 0); JanetByteView str = janet_getbytes(argv, 1); @@ -299,7 +332,9 @@ static Janet cfun_string_hasprefix(int32_t argc, Janet *argv) { : janet_wrap_boolean(memcmp(prefix.bytes, str.bytes, prefix.len) == 0); } -static Janet cfun_string_hassuffix(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_hassuffix, + "(string/has-suffix? sfx str)", + "Tests whether str ends with sfx.") { janet_fixarity(argc, 2); JanetByteView suffix = janet_getbytes(argv, 0); JanetByteView str = janet_getbytes(argv, 1); @@ -310,7 +345,12 @@ static Janet cfun_string_hassuffix(int32_t argc, Janet *argv) { suffix.len) == 0); } -static Janet cfun_string_findall(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_findall, + "(string/find-all patt str &opt start-index)", + "Searches for all instances of pattern patt in string " + "str. Returns an array of all indices of found patterns. Overlapping " + "instances of the pattern are counted individually, meaning a byte in str " + "may contribute to multiple found patterns.") { int32_t result; struct kmp_state state; findsetup(argc, argv, &state, 0); @@ -344,7 +384,10 @@ static void replacesetup(int32_t argc, Janet *argv, struct replace_state *s) { s->substlen = subst.len; } -static Janet cfun_string_replace(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_replace, + "(string/replace patt subst str)", + "Replace the first occurrence of patt with subst in the string str. " + "Will return the new string if patt is found, otherwise returns str.") { int32_t result; struct replace_state s; uint8_t *buf; @@ -364,7 +407,11 @@ static Janet cfun_string_replace(int32_t argc, Janet *argv) { return janet_wrap_string(janet_string_end(buf)); } -static Janet cfun_string_replaceall(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_replaceall, + "(string/replace-all patt subst str)", + "Replace all instances of patt with subst in the string str. Overlapping " + "matches will not be counted, only the first match in such a span will be replaced. " + "Will return the new string if patt is found, otherwise returns str.") { int32_t result; struct replace_state s; JanetBuffer b; @@ -384,7 +431,13 @@ static Janet cfun_string_replaceall(int32_t argc, Janet *argv) { return janet_wrap_string(ret); } -static Janet cfun_string_split(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_split, + "(string/split delim str &opt start limit)", + "Splits a string str with delimiter delim and returns an array of " + "substrings. The substrings will not contain the delimiter delim. If delim " + "is not found, the returned array will have one element. Will start searching " + "for delim at the index start (if provided), and return up to a maximum " + "of limit results (if provided).") { int32_t result; JanetArray *array; struct kmp_state state; @@ -406,7 +459,11 @@ static Janet cfun_string_split(int32_t argc, Janet *argv) { return janet_wrap_array(array); } -static Janet cfun_string_checkset(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_checkset, + "(string/check-set set str)", + "Checks that the string str only contains bytes that appear in the string set. " + "Returns true if all bytes in str appear in set, false if some bytes in str do " + "not appear in set.") { uint32_t bitset[8] = {0, 0, 0, 0, 0, 0, 0, 0}; janet_fixarity(argc, 2); JanetByteView set = janet_getbytes(argv, 0); @@ -428,7 +485,10 @@ static Janet cfun_string_checkset(int32_t argc, Janet *argv) { return janet_wrap_true(); } -static Janet cfun_string_join(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_join, + "(string/join parts &opt sep)", + "Joins an array of strings into one string, optionally separated by " + "a separator string sep.") { janet_arity(argc, 1, 2); JanetView parts = janet_getindexed(argv, 0); JanetByteView joiner; @@ -468,7 +528,10 @@ static Janet cfun_string_join(int32_t argc, Janet *argv) { return janet_wrap_string(janet_string_end(buf)); } -static Janet cfun_string_format(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_format, + "(string/format format & values)", + "Similar to snprintf, but specialized for operating with Janet values. Returns " + "a new string.") { janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_buffer(0); const char *strfrmt = (const char *) janet_getstring(argv, 0); @@ -508,7 +571,10 @@ static void trim_help_args(int32_t argc, Janet *argv, JanetByteView *str, JanetB } } -static Janet cfun_string_trim(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_trim, + "(string/trim str &opt set)", + "Trim leading and trailing whitespace from a byte sequence. If the argument " + "set is provided, consider only characters in set to be whitespace.") { JanetByteView str, set; trim_help_args(argc, argv, &str, &set); int32_t left_edge = trim_help_leftedge(str, set); @@ -518,163 +584,52 @@ static Janet cfun_string_trim(int32_t argc, Janet *argv) { return janet_stringv(str.bytes + left_edge, right_edge - left_edge); } -static Janet cfun_string_triml(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_triml, + "(string/triml str &opt set)", + "Trim leading whitespace from a byte sequence. If the argument " + "set is provided, consider only characters in set to be whitespace.") { JanetByteView str, set; trim_help_args(argc, argv, &str, &set); int32_t left_edge = trim_help_leftedge(str, set); return janet_stringv(str.bytes + left_edge, str.len - left_edge); } -static Janet cfun_string_trimr(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_string_trimr, + "(string/trimr str &opt set)", + "Trim trailing whitespace from a byte sequence. If the argument " + "set is provided, consider only characters in set to be whitespace.") { JanetByteView str, set; trim_help_args(argc, argv, &str, &set); int32_t right_edge = trim_help_rightedge(str, set); return janet_stringv(str.bytes, right_edge); } -static const JanetReg string_cfuns[] = { - { - "string/slice", cfun_string_slice, - JDOC("(string/slice bytes &opt start end)\n\n" - "Returns a substring from a byte sequence. The substring is from " - "index start inclusive to index end exclusive. All indexing " - "is from 0. 'start' and 'end' can also be negative to indicate indexing " - "from the end of the string. Note that index -1 is synonymous with " - "index (length bytes) to allow a full negative slice range. ") - }, - { - "keyword/slice", cfun_keyword_slice, - JDOC("(keyword/slice bytes &opt start end)\n\n" - "Same a string/slice, but returns a keyword.") - }, - { - "symbol/slice", cfun_symbol_slice, - JDOC("(symbol/slice bytes &opt start end)\n\n" - "Same a string/slice, but returns a symbol.") - }, - { - "string/repeat", cfun_string_repeat, - JDOC("(string/repeat bytes n)\n\n" - "Returns a string that is n copies of bytes concatenated.") - }, - { - "string/bytes", cfun_string_bytes, - JDOC("(string/bytes str)\n\n" - "Returns an array of integers that are the byte values of the string.") - }, - { - "string/from-bytes", cfun_string_frombytes, - JDOC("(string/from-bytes & byte-vals)\n\n" - "Creates a string from integer parameters with byte values. All integers " - "will be coerced to the range of 1 byte 0-255.") - }, - { - "string/ascii-lower", cfun_string_asciilower, - JDOC("(string/ascii-lower str)\n\n" - "Returns a new string where all bytes are replaced with the " - "lowercase version of themselves in ASCII. Does only a very simple " - "case check, meaning no unicode support.") - }, - { - "string/ascii-upper", cfun_string_asciiupper, - JDOC("(string/ascii-upper str)\n\n" - "Returns a new string where all bytes are replaced with the " - "uppercase version of themselves in ASCII. Does only a very simple " - "case check, meaning no unicode support.") - }, - { - "string/reverse", cfun_string_reverse, - JDOC("(string/reverse str)\n\n" - "Returns a string that is the reversed version of str.") - }, - { - "string/find", cfun_string_find, - JDOC("(string/find patt str &opt start-index)\n\n" - "Searches for the first instance of pattern patt in string " - "str. Returns the index of the first character in patt if found, " - "otherwise returns nil.") - }, - { - "string/find-all", cfun_string_findall, - JDOC("(string/find-all patt str &opt start-index)\n\n" - "Searches for all instances of pattern patt in string " - "str. Returns an array of all indices of found patterns. Overlapping " - "instances of the pattern are counted individually, meaning a byte in str " - "may contribute to multiple found patterns.") - }, - { - "string/has-prefix?", cfun_string_hasprefix, - JDOC("(string/has-prefix? pfx str)\n\n" - "Tests whether str starts with pfx.") - }, - { - "string/has-suffix?", cfun_string_hassuffix, - JDOC("(string/has-suffix? sfx str)\n\n" - "Tests whether str ends with sfx.") - }, - { - "string/replace", cfun_string_replace, - JDOC("(string/replace patt subst str)\n\n" - "Replace the first occurrence of patt with subst in the string str. " - "Will return the new string if patt is found, otherwise returns str.") - }, - { - "string/replace-all", cfun_string_replaceall, - JDOC("(string/replace-all patt subst str)\n\n" - "Replace all instances of patt with subst in the string str. Overlapping " - "matches will not be counted, only the first match in such a span will be replaced. " - "Will return the new string if patt is found, otherwise returns str.") - }, - { - "string/split", cfun_string_split, - JDOC("(string/split delim str &opt start limit)\n\n" - "Splits a string str with delimiter delim and returns an array of " - "substrings. The substrings will not contain the delimiter delim. If delim " - "is not found, the returned array will have one element. Will start searching " - "for delim at the index start (if provided), and return up to a maximum " - "of limit results (if provided).") - }, - { - "string/check-set", cfun_string_checkset, - JDOC("(string/check-set set str)\n\n" - "Checks that the string str only contains bytes that appear in the string set. " - "Returns true if all bytes in str appear in set, false if some bytes in str do " - "not appear in set.") - }, - { - "string/join", cfun_string_join, - JDOC("(string/join parts &opt sep)\n\n" - "Joins an array of strings into one string, optionally separated by " - "a separator string sep.") - }, - { - "string/format", cfun_string_format, - JDOC("(string/format format & values)\n\n" - "Similar to snprintf, but specialized for operating with Janet values. Returns " - "a new string.") - }, - { - "string/trim", cfun_string_trim, - JDOC("(string/trim str &opt set)\n\n" - "Trim leading and trailing whitespace from a byte sequence. If the argument " - "set is provided, consider only characters in set to be whitespace.") - }, - { - "string/triml", cfun_string_triml, - JDOC("(string/triml str &opt set)\n\n" - "Trim leading whitespace from a byte sequence. If the argument " - "set is provided, consider only characters in set to be whitespace.") - }, - { - "string/trimr", cfun_string_trimr, - JDOC("(string/trimr str &opt set)\n\n" - "Trim trailing whitespace from a byte sequence. If the argument " - "set is provided, consider only characters in set to be whitespace.") - }, - {NULL, NULL, NULL} -}; - /* Module entry point */ void janet_lib_string(JanetTable *env) { - janet_core_cfuns(env, NULL, string_cfuns); + JanetRegExt string_cfuns[] = { + JANET_CORE_REG("string/slice", cfun_string_slice), + JANET_CORE_REG("keyword/slice", cfun_keyword_slice), + JANET_CORE_REG("symbol/slice", cfun_symbol_slice), + JANET_CORE_REG("string/repeat", cfun_string_repeat), + JANET_CORE_REG("string/bytes", cfun_string_bytes), + JANET_CORE_REG("string/from-bytes", cfun_string_frombytes), + JANET_CORE_REG("string/ascii-lower", cfun_string_asciilower), + JANET_CORE_REG("string/ascii-upper", cfun_string_asciiupper), + JANET_CORE_REG("string/reverse", cfun_string_reverse), + JANET_CORE_REG("string/find", cfun_string_find), + JANET_CORE_REG("string/find-all", cfun_string_findall), + JANET_CORE_REG("string/has-prefix?", cfun_string_hasprefix), + JANET_CORE_REG("string/has-suffix?", cfun_string_hassuffix), + JANET_CORE_REG("string/replace", cfun_string_replace), + JANET_CORE_REG("string/replace-all", cfun_string_replaceall), + JANET_CORE_REG("string/split", cfun_string_split), + JANET_CORE_REG("string/check-set", cfun_string_checkset), + JANET_CORE_REG("string/join", cfun_string_join), + JANET_CORE_REG("string/format", cfun_string_format), + JANET_CORE_REG("string/trim", cfun_string_trim), + JANET_CORE_REG("string/triml", cfun_string_triml), + JANET_CORE_REG("string/trimr", cfun_string_trimr), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, string_cfuns); } diff --git a/src/core/strtod.c b/src/core/strtod.c index 0de93a9e..23c08041 100644 --- a/src/core/strtod.c +++ b/src/core/strtod.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -246,15 +246,15 @@ static double convert( } /* Scan a real (double) from a string. If the string cannot be converted into - * and integer, set *err to 1 and return 0. */ -int janet_scan_number( + * and integer, return 0. */ +int janet_scan_number_base( const uint8_t *str, int32_t len, + int32_t base, double *out) { const uint8_t *end = str + len; int seenadigit = 0; int ex = 0; - int base = 10; int seenpoint = 0; int foundexp = 0; int neg = 0; @@ -278,21 +278,28 @@ int janet_scan_number( } /* Check for leading 0x or digit digit r */ - if (str + 1 < end && str[0] == '0' && str[1] == 'x') { - base = 16; - str += 2; - } else if (str + 1 < end && - str[0] >= '0' && str[0] <= '9' && - str[1] == 'r') { - base = str[0] - '0'; - str += 2; - } else if (str + 2 < end && - str[0] >= '0' && str[0] <= '9' && - str[1] >= '0' && str[1] <= '9' && - str[2] == 'r') { - base = 10 * (str[0] - '0') + (str[1] - '0'); - if (base < 2 || base > 36) goto error; - str += 3; + if (base == 0) { + if (str + 1 < end && str[0] == '0' && str[1] == 'x') { + base = 16; + str += 2; + } else if (str + 1 < end && + str[0] >= '0' && str[0] <= '9' && + str[1] == 'r') { + base = str[0] - '0'; + str += 2; + } else if (str + 2 < end && + str[0] >= '0' && str[0] <= '9' && + str[1] >= '0' && str[1] <= '9' && + str[2] == 'r') { + base = 10 * (str[0] - '0') + (str[1] - '0'); + if (base < 2 || base > 36) goto error; + str += 3; + } + } + + /* If still base is 0, set to default (10) */ + if (base == 0) { + base = 10; } /* Skip leading zeros */ @@ -376,6 +383,13 @@ error: return 1; } +int janet_scan_number( + const uint8_t *str, + int32_t len, + double *out) { + return janet_scan_number_base(str, len, 0, out); +} + #ifdef JANET_INT_TYPES static int scan_uint64( diff --git a/src/core/struct.c b/src/core/struct.c index f8a3bb81..ecc132f3 100644 --- a/src/core/struct.c +++ b/src/core/struct.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -167,17 +167,12 @@ Janet janet_struct_rawget(const JanetKV *st, Janet key) { /* Get an item from a struct */ Janet janet_struct_get(const JanetKV *st, Janet key) { - const JanetKV *kv = janet_struct_find(st, key); - if (NULL != kv) - return kv->value; - /* Check prototypes */ - { - int i = JANET_MAX_PROTO_DEPTH; - for (st = janet_struct_proto(st); st && i; st = janet_struct_proto(st), --i) { - kv = janet_struct_find(st, key); - if (NULL != kv) - return kv->value; - } + int i = JANET_MAX_PROTO_DEPTH; + for (; st && i; --i) { + const JanetKV *kv = janet_struct_find(st, key); + if (NULL != kv) + return kv->value; + st = janet_struct_proto(st); } return janet_wrap_nil(); } @@ -216,20 +211,25 @@ JanetTable *janet_struct_to_table(const JanetKV *st) { /* C Functions */ -static Janet cfun_struct_with_proto(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_struct_with_proto, + "(struct/with-proto proto & kvs)", + "Create a structure, as with the usual struct constructor but set the " + "struct prototype as well.") { janet_arity(argc, 1, -1); JanetStruct proto = janet_optstruct(argv, argc, 0, NULL); if (!(argc & 1)) janet_panic("expected odd number of arguments"); JanetKV *st = janet_struct_begin(argc / 2); - janet_struct_proto(st) = proto; for (int32_t i = 1; i < argc; i += 2) { janet_struct_put(st, argv[i], argv[i + 1]); } + janet_struct_proto(st) = proto; return janet_wrap_struct(janet_struct_end(st)); } -static Janet cfun_struct_getproto(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_struct_getproto, + "(struct/getproto st)", + "Return the prototype of a struct, or nil if it doesn't have one.") { janet_fixarity(argc, 1); JanetStruct st = janet_getstruct(argv, 0); return janet_struct_proto(st) @@ -237,7 +237,10 @@ static Janet cfun_struct_getproto(int32_t argc, Janet *argv) { : janet_wrap_nil(); } -static Janet cfun_struct_flatten(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_struct_flatten, + "(struct/proto-flatten st)", + "Convert a struct with prototypes to a struct with no prototypes by merging " + "all key value pairs from recursive prototypes into one new struct.") { janet_fixarity(argc, 1); JanetStruct st = janet_getstruct(argv, 0); @@ -267,7 +270,10 @@ static Janet cfun_struct_flatten(int32_t argc, Janet *argv) { return janet_wrap_struct(janet_struct_end(accum)); } -static Janet cfun_struct_to_table(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_struct_to_table, + "(struct/to-table st &opt recursive)", + "Convert a struct to a table. If recursive is true, also convert the " + "table's prototypes into the new struct's prototypes as well.") { janet_arity(argc, 1, 2); JanetStruct st = janet_getstruct(argv, 0); int recursive = argc > 1 && janet_truthy(argv[1]); @@ -295,34 +301,14 @@ static Janet cfun_struct_to_table(int32_t argc, Janet *argv) { return janet_wrap_table(tab); } -static const JanetReg struct_cfuns[] = { - { - "struct/with-proto", cfun_struct_with_proto, - JDOC("(struct/with-proto proto & kvs)\n\n" - "Create a structure, as with the usual struct constructor but set the " - "struct prototype as well.") - }, - { - "struct/getproto", cfun_struct_getproto, - JDOC("(struct/getproto st)\n\n" - "Get the prototype of a struct, or nil if it doesn't have one.") - }, - { - "struct/proto-flatten", cfun_struct_flatten, - JDOC("(struct/proto-flatten st)\n\n" - "Convert a struct with prototypes to a struct with no prototypes by merging " - "all key value pairs from recursive prototypes into one new struct.") - }, - { - "struct/to-table", cfun_struct_to_table, - JDOC("(struct/to-table st &opt recursive)\n\n" - "Convert a struct to a table. If recursive is true, also convert the " - "table's prototypes into the new struct's prototypes as well.") - }, - {NULL, NULL, NULL} -}; - /* Load the struct module */ void janet_lib_struct(JanetTable *env) { - janet_core_cfuns(env, NULL, struct_cfuns); + JanetRegExt struct_cfuns[] = { + JANET_CORE_REG("struct/with-proto", cfun_struct_with_proto), + JANET_CORE_REG("struct/getproto", cfun_struct_getproto), + JANET_CORE_REG("struct/proto-flatten", cfun_struct_flatten), + JANET_CORE_REG("struct/to-table", cfun_struct_to_table), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, struct_cfuns); } diff --git a/src/core/symcache.c b/src/core/symcache.c index 257dcc45..01a9a9b5 100644 --- a/src/core/symcache.c +++ b/src/core/symcache.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -36,30 +36,26 @@ #include -/* Cache state */ -JANET_THREAD_LOCAL const uint8_t **janet_vm_cache = NULL; -JANET_THREAD_LOCAL uint32_t janet_vm_cache_capacity = 0; -JANET_THREAD_LOCAL uint32_t janet_vm_cache_count = 0; -JANET_THREAD_LOCAL uint32_t janet_vm_cache_deleted = 0; - /* Initialize the cache (allocate cache memory) */ void janet_symcache_init() { - janet_vm_cache_capacity = 1024; - janet_vm_cache = janet_calloc(1, (size_t) janet_vm_cache_capacity * sizeof(const uint8_t *)); - if (NULL == janet_vm_cache) { + janet_vm.cache_capacity = 1024; + janet_vm.cache = janet_calloc(1, (size_t) janet_vm.cache_capacity * sizeof(const uint8_t *)); + if (NULL == janet_vm.cache) { JANET_OUT_OF_MEMORY; } - janet_vm_cache_count = 0; - janet_vm_cache_deleted = 0; + memset(&janet_vm.gensym_counter, '0', sizeof(janet_vm.gensym_counter)); + janet_vm.gensym_counter[0] = '_'; + janet_vm.cache_count = 0; + janet_vm.cache_deleted = 0; } /* Deinitialize the cache (free the cache memory) */ void janet_symcache_deinit() { - janet_free((void *)janet_vm_cache); - janet_vm_cache = NULL; - janet_vm_cache_capacity = 0; - janet_vm_cache_count = 0; - janet_vm_cache_deleted = 0; + janet_free((void *)janet_vm.cache); + janet_vm.cache = NULL; + janet_vm.cache_capacity = 0; + janet_vm.cache_count = 0; + janet_vm.cache_deleted = 0; } /* Mark an entry in the table as deleted. */ @@ -79,24 +75,24 @@ static const uint8_t **janet_symcache_findmem( /* We will search two ranges - index to the end, * and 0 to the index. */ - index = (uint32_t)hash & (janet_vm_cache_capacity - 1); + index = (uint32_t)hash & (janet_vm.cache_capacity - 1); bounds[0] = index; - bounds[1] = janet_vm_cache_capacity; + bounds[1] = janet_vm.cache_capacity; bounds[2] = 0; bounds[3] = index; for (j = 0; j < 4; j += 2) for (i = bounds[j]; i < bounds[j + 1]; ++i) { - const uint8_t *test = janet_vm_cache[i]; + const uint8_t *test = janet_vm.cache[i]; /* Check empty spots */ if (NULL == test) { if (NULL == firstEmpty) - firstEmpty = janet_vm_cache + i; + firstEmpty = janet_vm.cache + i; goto notfound; } /* Check for marked deleted */ if (JANET_SYMCACHE_DELETED == test) { if (firstEmpty == NULL) - firstEmpty = janet_vm_cache + i; + firstEmpty = janet_vm.cache + i; continue; } if (janet_string_equalconst(test, str, len, hash)) { @@ -104,10 +100,10 @@ static const uint8_t **janet_symcache_findmem( *success = 1; if (firstEmpty != NULL) { *firstEmpty = test; - janet_vm_cache[i] = JANET_SYMCACHE_DELETED; + janet_vm.cache[i] = JANET_SYMCACHE_DELETED; return firstEmpty; } - return janet_vm_cache + i; + return janet_vm.cache + i; } } notfound: @@ -121,15 +117,15 @@ notfound: /* Resize the cache. */ static void janet_cache_resize(uint32_t newCapacity) { uint32_t i, oldCapacity; - const uint8_t **oldCache = janet_vm_cache; + const uint8_t **oldCache = janet_vm.cache; const uint8_t **newCache = janet_calloc(1, (size_t) newCapacity * sizeof(const uint8_t *)); if (newCache == NULL) { JANET_OUT_OF_MEMORY; } - oldCapacity = janet_vm_cache_capacity; - janet_vm_cache = newCache; - janet_vm_cache_capacity = newCapacity; - janet_vm_cache_deleted = 0; + oldCapacity = janet_vm.cache_capacity; + janet_vm.cache = newCache; + janet_vm.cache_capacity = newCapacity; + janet_vm.cache_deleted = 0; /* Add all of the old cache entries back */ for (i = 0; i < oldCapacity; ++i) { int status; @@ -150,13 +146,13 @@ static void janet_cache_resize(uint32_t newCapacity) { /* Add an item to the cache */ static void janet_symcache_put(const uint8_t *x, const uint8_t **bucket) { - if ((janet_vm_cache_count + janet_vm_cache_deleted) * 2 > janet_vm_cache_capacity) { + if ((janet_vm.cache_count + janet_vm.cache_deleted) * 2 > janet_vm.cache_capacity) { int status; - janet_cache_resize(janet_tablen((2 * janet_vm_cache_count + 1))); + janet_cache_resize(janet_tablen((2 * janet_vm.cache_count + 1))); bucket = janet_symcache_find(x, &status); } /* Add x to the cache */ - janet_vm_cache_count++; + janet_vm.cache_count++; *bucket = x; } @@ -165,8 +161,8 @@ void janet_symbol_deinit(const uint8_t *sym) { int status = 0; const uint8_t **bucket = janet_symcache_find(sym, &status); if (status) { - janet_vm_cache_count--; - janet_vm_cache_deleted++; + janet_vm.cache_count--; + janet_vm.cache_deleted++; *bucket = JANET_SYMCACHE_DELETED; } } @@ -194,22 +190,19 @@ const uint8_t *janet_csymbol(const char *cstr) { return janet_symbol((const uint8_t *)cstr, (int32_t) strlen(cstr)); } -/* Store counter for genysm to avoid quadratic behavior */ -JANET_THREAD_LOCAL uint8_t gensym_counter[8] = {'_', '0', '0', '0', '0', '0', '0', 0}; - /* Increment the gensym buffer */ static void inc_gensym(void) { - for (int i = sizeof(gensym_counter) - 2; i; i--) { - if (gensym_counter[i] == '9') { - gensym_counter[i] = 'a'; + for (int i = sizeof(janet_vm.gensym_counter) - 2; i; i--) { + if (janet_vm.gensym_counter[i] == '9') { + janet_vm.gensym_counter[i] = 'a'; break; - } else if (gensym_counter[i] == 'z') { - gensym_counter[i] = 'A'; + } else if (janet_vm.gensym_counter[i] == 'z') { + janet_vm.gensym_counter[i] = 'A'; break; - } else if (gensym_counter[i] == 'Z') { - gensym_counter[i] = '0'; + } else if (janet_vm.gensym_counter[i] == 'Z') { + janet_vm.gensym_counter[i] = '0'; } else { - gensym_counter[i]++; + janet_vm.gensym_counter[i]++; break; } } @@ -227,19 +220,19 @@ const uint8_t *janet_symbol_gen(void) { * is enough for resolving collisions. */ do { hash = janet_string_calchash( - gensym_counter, - sizeof(gensym_counter) - 1); + janet_vm.gensym_counter, + sizeof(janet_vm.gensym_counter) - 1); bucket = janet_symcache_findmem( - gensym_counter, - sizeof(gensym_counter) - 1, + janet_vm.gensym_counter, + sizeof(janet_vm.gensym_counter) - 1, hash, &status); } while (status && (inc_gensym(), 1)); - JanetStringHead *head = janet_gcalloc(JANET_MEMORY_SYMBOL, sizeof(JanetStringHead) + sizeof(gensym_counter)); - head->length = sizeof(gensym_counter) - 1; + JanetStringHead *head = janet_gcalloc(JANET_MEMORY_SYMBOL, sizeof(JanetStringHead) + sizeof(janet_vm.gensym_counter)); + head->length = sizeof(janet_vm.gensym_counter) - 1; head->hash = hash; sym = (uint8_t *)(head->data); - memcpy(sym, gensym_counter, sizeof(gensym_counter)); + memcpy(sym, janet_vm.gensym_counter, sizeof(janet_vm.gensym_counter)); janet_symcache_put((const uint8_t *)sym, bucket); return (const uint8_t *)sym; } diff --git a/src/core/symcache.h b/src/core/symcache.h index d3274155..0da5138a 100644 --- a/src/core/symcache.h +++ b/src/core/symcache.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/table.c b/src/core/table.c index e8266a75..78abc433 100644 --- a/src/core/table.c +++ b/src/core/table.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -67,14 +67,23 @@ static JanetTable *janet_table_init_impl(JanetTable *table, int32_t capacity, in return table; } -/* Initialize a table */ +/* Initialize a table (for use withs scratch memory) */ JanetTable *janet_table_init(JanetTable *table, int32_t capacity) { return janet_table_init_impl(table, capacity, 1); } +/* Initialize a table without using scratch memory */ +JanetTable *janet_table_init_raw(JanetTable *table, int32_t capacity) { + return janet_table_init_impl(table, capacity, 0); +} + /* Deinitialize a table */ void janet_table_deinit(JanetTable *table) { - janet_sfree(table->data); + if (table->gc.flags & JANET_TABLE_FLAG_STACK) { + janet_sfree(table->data); + } else { + janet_free(table->data); + } } /* Create a new table */ @@ -300,13 +309,21 @@ JanetTable *janet_table_proto_flatten(JanetTable *t) { /* C Functions */ -static Janet cfun_table_new(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_table_new, + "(table/new capacity)", + "Creates a new empty table with pre-allocated memory " + "for capacity entries. This means that if one knows the number of " + "entries going to go in a table on creation, extra memory allocation " + "can be avoided. Returns the new table.") { janet_fixarity(argc, 1); int32_t cap = janet_getinteger(argv, 0); return janet_wrap_table(janet_table(cap)); } -static Janet cfun_table_getproto(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_table_getproto, + "(table/getproto tab)", + "Get the prototype table of a table. Returns nil if a table " + "has no prototype, otherwise returns the prototype.") { janet_fixarity(argc, 1); JanetTable *t = janet_gettable(argv, 0); return t->proto @@ -314,7 +331,9 @@ static Janet cfun_table_getproto(int32_t argc, Janet *argv) { : janet_wrap_nil(); } -static Janet cfun_table_setproto(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_table_setproto, + "(table/setproto tab proto)", + "Set the prototype of a table. Returns the original table tab.") { janet_fixarity(argc, 2); JanetTable *table = janet_gettable(argv, 0); JanetTable *proto = NULL; @@ -325,78 +344,63 @@ static Janet cfun_table_setproto(int32_t argc, Janet *argv) { return argv[0]; } -static Janet cfun_table_tostruct(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_table_tostruct, + "(table/to-struct tab)", + "Convert a table to a struct. Returns a new struct. This function " + "does not take into account prototype tables.") { janet_fixarity(argc, 1); JanetTable *t = janet_gettable(argv, 0); return janet_wrap_struct(janet_table_to_struct(t)); } -static Janet cfun_table_rawget(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_table_rawget, + "(table/rawget tab key)", + "Gets a value from a table without looking at the prototype table. " + "If a table tab does not contain t directly, the function will return " + "nil without checking the prototype. Returns the value in the table.") { janet_fixarity(argc, 2); JanetTable *table = janet_gettable(argv, 0); return janet_table_rawget(table, argv[1]); } -static Janet cfun_table_clone(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_table_clone, + "(table/clone tab)", + "Create a copy of a table. Updates to the new table will not change the old table, " + "and vice versa.") { janet_fixarity(argc, 1); JanetTable *table = janet_gettable(argv, 0); return janet_wrap_table(janet_table_clone(table)); } -static Janet cfun_table_proto_flatten(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_table_clear, + "(table/clear tab)", + "Remove all key-value pairs in a table and return the modified table `tab`.") { + janet_fixarity(argc, 1); + JanetTable *table = janet_gettable(argv, 0); + janet_table_clear(table); + return janet_wrap_table(table); +} + +JANET_CORE_FN(cfun_table_proto_flatten, + "(table/proto-flatten tab)", + "Create a new table that is the result of merging all prototypes into a new table.") { janet_fixarity(argc, 1); JanetTable *table = janet_gettable(argv, 0); return janet_wrap_table(janet_table_proto_flatten(table)); } -static const JanetReg table_cfuns[] = { - { - "table/new", cfun_table_new, - JDOC("(table/new capacity)\n\n" - "Creates a new empty table with pre-allocated memory " - "for capacity entries. This means that if one knows the number of " - "entries going to go in a table on creation, extra memory allocation " - "can be avoided. Returns the new table.") - }, - { - "table/to-struct", cfun_table_tostruct, - JDOC("(table/to-struct tab)\n\n" - "Convert a table to a struct. Returns a new struct. This function " - "does not take into account prototype tables.") - }, - { - "table/getproto", cfun_table_getproto, - JDOC("(table/getproto tab)\n\n" - "Get the prototype table of a table. Returns nil if a table " - "has no prototype, otherwise returns the prototype.") - }, - { - "table/setproto", cfun_table_setproto, - JDOC("(table/setproto tab proto)\n\n" - "Set the prototype of a table. Returns the original table tab.") - }, - { - "table/rawget", cfun_table_rawget, - JDOC("(table/rawget tab key)\n\n" - "Gets a value from a table without looking at the prototype table. " - "If a table tab does not contain t directly, the function will return " - "nil without checking the prototype. Returns the value in the table.") - }, - { - "table/clone", cfun_table_clone, - JDOC("(table/clone tab)\n\n" - "Create a copy of a table. Updates to the new table will not change the old table, " - "and vice versa.") - }, - { - "table/proto-flatten", cfun_table_proto_flatten, - JDOC("(table/proto-flatten tab)\n\n" - "Create a new table that is the result of merging all prototypes into a new table.") - }, - {NULL, NULL, NULL} -}; - /* Load the table module */ void janet_lib_table(JanetTable *env) { - janet_core_cfuns(env, NULL, table_cfuns); + JanetRegExt table_cfuns[] = { + JANET_CORE_REG("table/new", cfun_table_new), + JANET_CORE_REG("table/to-struct", cfun_table_tostruct), + JANET_CORE_REG("table/getproto", cfun_table_getproto), + JANET_CORE_REG("table/setproto", cfun_table_setproto), + JANET_CORE_REG("table/rawget", cfun_table_rawget), + JANET_CORE_REG("table/clone", cfun_table_clone), + JANET_CORE_REG("table/clear", cfun_table_clear), + JANET_CORE_REG("table/proto-flatten", cfun_table_proto_flatten), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, table_cfuns); } diff --git a/src/core/thread.c b/src/core/thread.c deleted file mode 100644 index 99115573..00000000 --- a/src/core/thread.c +++ /dev/null @@ -1,781 +0,0 @@ -/* -* Copyright (c) 2020 Calvin Rose -* -* Permission is hereby granted, free of charge, to any person obtaining a copy -* of this software and associated documentation files (the "Software"), to -* deal in the Software without restriction, including without limitation the -* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -* sell copies of the Software, and to permit persons to whom the Software is -* furnished to do so, subject to the following conditions: -* -* The above copyright notice and this permission notice shall be included in -* all copies or substantial portions of the Software. -* -* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -* IN THE SOFTWARE. -*/ - -#ifndef JANET_AMALG -#include "features.h" -#include -#include "gc.h" -#include "util.h" -#include "state.h" -#endif - -#ifdef JANET_THREADS - -#include -#ifdef JANET_WINDOWS -#include -#else -#include -#include -#include -#endif - -/* typedefed in janet.h */ -struct JanetMailbox { - - /* Synchronization */ -#ifdef JANET_WINDOWS - CRITICAL_SECTION lock; - CONDITION_VARIABLE cond; -#else - pthread_mutex_t lock; - pthread_cond_t cond; -#endif - - /* Memory management - reference counting */ - int refCount; - int closed; - - /* Store messages */ - uint16_t messageCapacity; - uint16_t messageCount; - uint16_t messageFirst; - uint16_t messageNext; - - /* Buffers to store messages. These buffers are manually allocated, so - * are not owned by any thread's GC. */ - JanetBuffer messages[]; -}; - -#define JANET_THREAD_HEAVYWEIGHT 0x1 -#define JANET_THREAD_ABSTRACTS 0x2 -#define JANET_THREAD_CFUNCTIONS 0x4 -static const char janet_thread_flags[] = "hac"; - -typedef struct { - JanetMailbox *original; - JanetMailbox *newbox; - uint64_t flags; -} JanetMailboxPair; - -static JANET_THREAD_LOCAL JanetMailbox *janet_vm_mailbox = NULL; -static JANET_THREAD_LOCAL JanetThread *janet_vm_thread_current = NULL; -static JANET_THREAD_LOCAL JanetTable *janet_vm_thread_decode = NULL; - -static JanetTable *janet_thread_get_decode(void) { - if (janet_vm_thread_decode == NULL) { - janet_vm_thread_decode = janet_get_core_table("load-image-dict"); - if (NULL == janet_vm_thread_decode) { - janet_vm_thread_decode = janet_table(0); - } - janet_gcroot(janet_wrap_table(janet_vm_thread_decode)); - } - return janet_vm_thread_decode; -} - -static JanetMailbox *janet_mailbox_create(int refCount, uint16_t capacity) { - JanetMailbox *mailbox = janet_malloc(sizeof(JanetMailbox) + sizeof(JanetBuffer) * (size_t) capacity); - if (NULL == mailbox) { - JANET_OUT_OF_MEMORY; - } -#ifdef JANET_WINDOWS - InitializeCriticalSection(&mailbox->lock); - InitializeConditionVariable(&mailbox->cond); -#else - pthread_mutex_init(&mailbox->lock, NULL); - pthread_cond_init(&mailbox->cond, NULL); -#endif - mailbox->refCount = refCount; - mailbox->closed = 0; - mailbox->messageCount = 0; - mailbox->messageCapacity = capacity; - mailbox->messageFirst = 0; - mailbox->messageNext = 0; - for (uint16_t i = 0; i < capacity; i++) { - janet_buffer_init(mailbox->messages + i, 0); - } - return mailbox; -} - -static void janet_mailbox_destroy(JanetMailbox *mailbox) { -#ifdef JANET_WINDOWS - DeleteCriticalSection(&mailbox->lock); -#else - pthread_mutex_destroy(&mailbox->lock); - pthread_cond_destroy(&mailbox->cond); -#endif - for (uint16_t i = 0; i < mailbox->messageCapacity; i++) { - janet_buffer_deinit(mailbox->messages + i); - } - janet_free(mailbox); -} - -static void janet_mailbox_lock(JanetMailbox *mailbox) { -#ifdef JANET_WINDOWS - EnterCriticalSection(&mailbox->lock); -#else - pthread_mutex_lock(&mailbox->lock); -#endif -} - -static void janet_mailbox_unlock(JanetMailbox *mailbox) { -#ifdef JANET_WINDOWS - LeaveCriticalSection(&mailbox->lock); -#else - pthread_mutex_unlock(&mailbox->lock); -#endif -} - -/* Assumes you have the mailbox lock already */ -static void janet_mailbox_ref_with_lock(JanetMailbox *mailbox, int delta) { - mailbox->refCount += delta; - if (mailbox->refCount <= 0) { - janet_mailbox_unlock(mailbox); - janet_mailbox_destroy(mailbox); - } else { - janet_mailbox_unlock(mailbox); - } -} - -static void janet_mailbox_ref(JanetMailbox *mailbox, int delta) { - janet_mailbox_lock(mailbox); - janet_mailbox_ref_with_lock(mailbox, delta); -} - -static void janet_close_thread(JanetThread *thread) { - if (thread->mailbox) { - janet_mailbox_ref(thread->mailbox, -1); - thread->mailbox = NULL; - } -} - -static int thread_gc(void *p, size_t size) { - (void) size; - JanetThread *thread = (JanetThread *)p; - janet_close_thread(thread); - return 0; -} - -static int thread_mark(void *p, size_t size) { - (void) size; - JanetThread *thread = (JanetThread *)p; - if (thread->encode) { - janet_mark(janet_wrap_table(thread->encode)); - } - return 0; -} - -static JanetMailboxPair *make_mailbox_pair(JanetMailbox *original, uint64_t flags) { - JanetMailboxPair *pair = janet_malloc(sizeof(JanetMailboxPair)); - if (NULL == pair) { - JANET_OUT_OF_MEMORY; - } - pair->original = original; - janet_mailbox_ref(original, 1); - pair->newbox = janet_mailbox_create(1, 16); - pair->flags = flags; - return pair; -} - -static void destroy_mailbox_pair(JanetMailboxPair *pair) { - janet_mailbox_ref(pair->original, -1); - janet_mailbox_ref(pair->newbox, -1); - janet_free(pair); -} - -/* Abstract waiting for timeout across windows/posix */ -typedef struct { - int timedwait; - int nowait; -#ifdef JANET_WINDOWS - DWORD interval; - DWORD ticksLeft; -#else - struct timespec ts; -#endif -} JanetWaiter; - -static void janet_waiter_init(JanetWaiter *waiter, double sec) { - waiter->timedwait = 0; - waiter->nowait = 0; - - if (sec <= 0.0 || isnan(sec)) { - waiter->nowait = 1; - return; - } - waiter->timedwait = sec > 0.0 && !isinf(sec); - - /* Set maximum wait time to 30 days */ - if (sec > (60.0 * 60.0 * 24.0 * 30.0)) { - sec = 60.0 * 60.0 * 24.0 * 30.0; - } - -#ifdef JANET_WINDOWS - if (waiter->timedwait) { - waiter->ticksLeft = waiter->interval = (DWORD) floor(1000.0 * sec); - } -#else - if (waiter->timedwait) { - /* N seconds -> timespec of (now + sec) */ - struct timespec now; - janet_gettime(&now); - time_t tvsec = (time_t) floor(sec); - long tvnsec = (long) floor(1000000000.0 * (sec - ((double) tvsec))); - tvsec += now.tv_sec; - tvnsec += now.tv_nsec; - if (tvnsec >= 1000000000L) { - tvnsec -= 1000000000L; - tvsec += 1; - } - waiter->ts.tv_sec = tvsec; - waiter->ts.tv_nsec = tvnsec; - } -#endif -} - -static int janet_waiter_wait(JanetWaiter *wait, JanetMailbox *mailbox) { - if (wait->nowait) return 1; -#ifdef JANET_WINDOWS - if (wait->timedwait) { - if (wait->ticksLeft == 0) return 1; - DWORD startTime = GetTickCount(); - int status = !SleepConditionVariableCS(&mailbox->cond, &mailbox->lock, wait->ticksLeft); - DWORD dTick = GetTickCount() - startTime; - /* Be careful about underflow */ - wait->ticksLeft = dTick > wait->ticksLeft ? 0 : dTick; - return status; - } else { - SleepConditionVariableCS(&mailbox->cond, &mailbox->lock, INFINITE); - return 0; - } -#else - if (wait->timedwait) { - return pthread_cond_timedwait(&mailbox->cond, &mailbox->lock, &wait->ts); - } else { - pthread_cond_wait(&mailbox->cond, &mailbox->lock); - return 0; - } -#endif -} - -static void janet_mailbox_wakeup(JanetMailbox *mailbox) { -#ifdef JANET_WINDOWS - WakeConditionVariable(&mailbox->cond); -#else - pthread_cond_signal(&mailbox->cond); -#endif -} - -static int mailbox_at_capacity(JanetMailbox *mailbox) { - return mailbox->messageCount >= mailbox->messageCapacity; -} - -/* Returns 1 if could not send (encode error or timeout), 2 for mailbox closed, and - * 0 otherwise. Will not panic. */ -int janet_thread_send(JanetThread *thread, Janet msg, double timeout) { - - /* Ensure mailbox is not closed. */ - JanetMailbox *mailbox = thread->mailbox; - if (NULL == mailbox) return 2; - janet_mailbox_lock(mailbox); - if (mailbox->closed) { - janet_mailbox_ref_with_lock(mailbox, -1); - thread->mailbox = NULL; - return 2; - } - - /* Back pressure */ - if (mailbox_at_capacity(mailbox)) { - JanetWaiter wait; - janet_waiter_init(&wait, timeout); - - if (wait.nowait) { - janet_mailbox_unlock(mailbox); - return 1; - } - - /* Retry loop, as there can be multiple writers */ - while (mailbox_at_capacity(mailbox)) { - if (janet_waiter_wait(&wait, mailbox)) { - janet_mailbox_unlock(mailbox); - janet_mailbox_wakeup(mailbox); - return 1; - } - } - } - - /* Hack to capture all panics from marshalling. This works because - * we know janet_marshal won't mess with other essential global state. */ - jmp_buf buf; - jmp_buf *old_buf = janet_vm_jmp_buf; - janet_vm_jmp_buf = &buf; - int32_t oldmcount = mailbox->messageCount; - - int ret = 0; - if (setjmp(buf)) { - ret = 1; - mailbox->messageCount = oldmcount; - } else { - JanetBuffer *msgbuf = mailbox->messages + mailbox->messageNext; - msgbuf->count = 0; - - /* Start panic zone */ - janet_marshal(msgbuf, msg, thread->encode, JANET_MARSHAL_UNSAFE); - /* End panic zone */ - - mailbox->messageNext = (mailbox->messageNext + 1) % mailbox->messageCapacity; - mailbox->messageCount++; - } - - /* Cleanup */ - janet_vm_jmp_buf = old_buf; - janet_mailbox_unlock(mailbox); - - /* Potentially wake up a blocked thread */ - janet_mailbox_wakeup(mailbox); - - return ret; -} - -/* Returns 0 on successful message. Returns 1 if timedout */ -int janet_thread_receive(Janet *msg_out, double timeout) { - JanetMailbox *mailbox = janet_vm_mailbox; - janet_mailbox_lock(mailbox); - - /* For timeouts */ - JanetWaiter wait; - janet_waiter_init(&wait, timeout); - - for (;;) { - - /* Check for messages waiting for us */ - if (mailbox->messageCount > 0) { - - /* Hack to capture all panics from marshalling. This works because - * we know janet_marshal won't mess with other essential global state. */ - jmp_buf buf; - jmp_buf *old_buf = janet_vm_jmp_buf; - janet_vm_jmp_buf = &buf; - - /* Handle errors */ - if (setjmp(buf)) { - /* Cleanup jmp_buf, return error. - * Do not ignore bad messages as before. */ - janet_vm_jmp_buf = old_buf; - *msg_out = *janet_vm_return_reg; - janet_mailbox_unlock(mailbox); - return 2; - } else { - JanetBuffer *msgbuf = mailbox->messages + mailbox->messageFirst; - mailbox->messageCount--; - mailbox->messageFirst = (mailbox->messageFirst + 1) % mailbox->messageCapacity; - - /* Read from beginning of channel */ - const uint8_t *nextItem = NULL; - Janet item = janet_unmarshal( - msgbuf->data, msgbuf->count, - JANET_MARSHAL_UNSAFE, janet_thread_get_decode(), &nextItem); - *msg_out = item; - - /* Cleanup */ - janet_vm_jmp_buf = old_buf; - janet_mailbox_unlock(mailbox); - - /* Potentially wake up pending threads */ - janet_mailbox_wakeup(mailbox); - - return 0; - } - } - - if (wait.nowait) { - janet_mailbox_unlock(mailbox); - return 1; - } - - /* Wait for next message */ - if (janet_waiter_wait(&wait, mailbox)) { - janet_mailbox_unlock(mailbox); - return 1; - } - } -} - -static int janet_thread_getter(void *p, Janet key, Janet *out); -static Janet janet_thread_next(void *p, Janet key); - -const JanetAbstractType janet_thread_type = { - "core/thread", - thread_gc, - thread_mark, - janet_thread_getter, - NULL, /* put */ - NULL, /* marshal */ - NULL, /* unmarshal */ - NULL, /* tostring */ - NULL, /* compare */ - NULL, /* hash */ - janet_thread_next, - JANET_ATEND_NEXT -}; - -static JanetThread *janet_make_thread(JanetMailbox *mailbox, JanetTable *encode) { - JanetThread *thread = janet_abstract(&janet_thread_type, sizeof(JanetThread)); - janet_mailbox_ref(mailbox, 1); - thread->mailbox = mailbox; - thread->encode = encode; - return thread; -} - -JanetThread *janet_getthread(const Janet *argv, int32_t n) { - return (JanetThread *) janet_getabstract(argv, n, &janet_thread_type); -} - -/* Runs in new thread */ -static int thread_worker(JanetMailboxPair *pair) { - JanetFiber *fiber = NULL; - Janet out; - - /* Use the mailbox we were given */ - janet_vm_mailbox = pair->newbox; - janet_mailbox_ref(pair->newbox, 1); - - /* Init VM */ - janet_init(); - - /* Get dictionaries for default encode/decode */ - JanetTable *encode; - if (pair->flags & JANET_THREAD_HEAVYWEIGHT) { - encode = janet_get_core_table("make-image-dict"); - } else { - encode = NULL; - janet_vm_thread_decode = janet_table(0); - janet_gcroot(janet_wrap_table(janet_vm_thread_decode)); - } - - /* Create parent thread */ - JanetThread *parent = janet_make_thread(pair->original, encode); - Janet parentv = janet_wrap_abstract(parent); - - /* Unmarshal the abstract registry */ - if (pair->flags & JANET_THREAD_ABSTRACTS) { - Janet reg; - int status = janet_thread_receive(®, INFINITY); - if (status) goto error; - if (!janet_checktype(reg, JANET_TABLE)) goto error; - janet_gcunroot(janet_wrap_table(janet_vm_abstract_registry)); - janet_vm_abstract_registry = janet_unwrap_table(reg); - janet_gcroot(janet_wrap_table(janet_vm_abstract_registry)); - } - - /* Unmarshal the normal registry */ - if (pair->flags & JANET_THREAD_CFUNCTIONS) { - Janet reg; - int status = janet_thread_receive(®, INFINITY); - if (status) goto error; - if (!janet_checktype(reg, JANET_TABLE)) goto error; - janet_gcunroot(janet_wrap_table(janet_vm_registry)); - janet_vm_registry = janet_unwrap_table(reg); - janet_gcroot(janet_wrap_table(janet_vm_registry)); - } - - /* Unmarshal the function */ - Janet funcv; - int status = janet_thread_receive(&funcv, INFINITY); - if (status) goto error; - if (!janet_checktype(funcv, JANET_FUNCTION)) goto error; - JanetFunction *func = janet_unwrap_function(funcv); - - /* Arity check */ - if (func->def->min_arity > 1 || func->def->max_arity < 1) { - goto error; - } - - /* Call function */ - Janet argv[1] = { parentv }; - fiber = janet_fiber(func, 64, 1, argv); - if (pair->flags & JANET_THREAD_HEAVYWEIGHT) { - fiber->env = janet_table(0); - fiber->env->proto = janet_core_env(NULL); - } - JanetSignal sig = janet_continue(fiber, janet_wrap_nil(), &out); - if (sig != JANET_SIGNAL_OK && sig < JANET_SIGNAL_USER0) { - janet_eprintf("in thread %v: ", janet_wrap_abstract(janet_make_thread(pair->newbox, encode))); - janet_stacktrace(fiber, out); - } - -#ifdef JANET_EV - janet_loop(); -#endif - - /* Normal exit */ - destroy_mailbox_pair(pair); - janet_deinit(); - return 0; - - /* Fail to set something up */ -error: - destroy_mailbox_pair(pair); - janet_eprintf("\nthread failed to start\n"); - janet_deinit(); - return 1; -} - -#ifdef JANET_WINDOWS - -static DWORD WINAPI janet_create_thread_wrapper(LPVOID param) { - thread_worker((JanetMailboxPair *)param); - return 0; -} - -static int janet_thread_start_child(JanetMailboxPair *pair) { - HANDLE handle = CreateThread(NULL, 0, janet_create_thread_wrapper, pair, 0, NULL); - int ret = NULL == handle; - /* Does not kill thread, simply detatches */ - if (!ret) CloseHandle(handle); - return ret; -} - -#else - -static void *janet_pthread_wrapper(void *param) { - thread_worker((JanetMailboxPair *)param); - return NULL; -} - -static int janet_thread_start_child(JanetMailboxPair *pair) { - pthread_t handle; - int error = pthread_create(&handle, NULL, janet_pthread_wrapper, pair); - if (error) { - return 1; - } else { - pthread_detach(handle); - return 0; - } -} - -#endif - -/* - * Setup/Teardown - */ - -void janet_threads_init(void) { - if (NULL == janet_vm_mailbox) { - janet_vm_mailbox = janet_mailbox_create(1, 10); - } - janet_vm_thread_decode = NULL; - janet_vm_thread_current = NULL; -} - -void janet_threads_deinit(void) { - janet_mailbox_lock(janet_vm_mailbox); - janet_vm_mailbox->closed = 1; - janet_mailbox_ref_with_lock(janet_vm_mailbox, -1); - janet_vm_mailbox = NULL; - janet_vm_thread_current = NULL; - janet_vm_thread_decode = NULL; -} - -JanetThread *janet_thread_current(void) { - if (NULL == janet_vm_thread_current) { - janet_vm_thread_current = janet_make_thread(janet_vm_mailbox, janet_get_core_table("make-image-dict")); - janet_gcroot(janet_wrap_abstract(janet_vm_thread_current)); - } - return janet_vm_thread_current; -} - -/* - * Cfuns - */ - -static Janet cfun_thread_current(int32_t argc, Janet *argv) { - (void) argv; - janet_fixarity(argc, 0); - return janet_wrap_abstract(janet_thread_current()); -} - -static Janet cfun_thread_new(int32_t argc, Janet *argv) { - janet_arity(argc, 1, 3); - /* Just type checking */ - janet_getfunction(argv, 0); - int32_t cap = janet_optinteger(argv, argc, 1, 10); - if (cap < 1 || cap > UINT16_MAX) { - janet_panicf("bad slot #1, expected integer in range [1, 65535], got %d", cap); - } - uint64_t flags = argc >= 3 ? janet_getflags(argv, 2, janet_thread_flags) : JANET_THREAD_ABSTRACTS; - JanetTable *encode; - if (flags & JANET_THREAD_HEAVYWEIGHT) { - encode = janet_get_core_table("make-image-dict"); - } else { - encode = NULL; - } - - JanetMailboxPair *pair = make_mailbox_pair(janet_vm_mailbox, flags); - JanetThread *thread = janet_make_thread(pair->newbox, encode); - if (janet_thread_start_child(pair)) { - destroy_mailbox_pair(pair); - janet_panic("could not start thread"); - } - - if (flags & JANET_THREAD_ABSTRACTS) { - if (janet_thread_send(thread, janet_wrap_table(janet_vm_abstract_registry), INFINITY)) { - janet_panic("could not send abstract registry to thread"); - } - } - - if (flags & JANET_THREAD_CFUNCTIONS) { - if (janet_thread_send(thread, janet_wrap_table(janet_vm_registry), INFINITY)) { - janet_panic("could not send registry to thread"); - } - } - - /* If thread started, send the worker function. */ - if (janet_thread_send(thread, argv[0], INFINITY)) { - janet_panicf("could not send worker function %v to thread", argv[0]); - } - - return janet_wrap_abstract(thread); -} - -static Janet cfun_thread_send(int32_t argc, Janet *argv) { - janet_arity(argc, 2, 3); - JanetThread *thread = janet_getthread(argv, 0); - int status = janet_thread_send(thread, argv[1], janet_optnumber(argv, argc, 2, 1.0)); - switch (status) { - default: - break; - case 1: - janet_panicf("failed to send message %v", argv[1]); - case 2: - janet_panic("thread mailbox is closed"); - } - return argv[0]; -} - -static Janet cfun_thread_receive(int32_t argc, Janet *argv) { - janet_arity(argc, 0, 1); - double wait = janet_optnumber(argv, argc, 0, 1.0); - Janet out; - int status = janet_thread_receive(&out, wait); - switch (status) { - default: - break; - case 1: - janet_panicf("timeout after %f seconds", wait); - case 2: - janet_panicf("failed to receive message: %v", out); - } - return out; -} - -static Janet cfun_thread_close(int32_t argc, Janet *argv) { - janet_fixarity(argc, 1); - JanetThread *thread = janet_getthread(argv, 0); - janet_close_thread(thread); - return janet_wrap_nil(); -} - -static Janet cfun_thread_exit(int32_t argc, Janet *argv) { - (void) argv; - janet_arity(argc, 0, 1); -#if defined(JANET_WINDOWS) - int32_t flag = janet_optinteger(argv, argc, 0, 0); - ExitThread(flag); -#else - pthread_exit(NULL); -#endif - return janet_wrap_nil(); -} - -static const JanetMethod janet_thread_methods[] = { - {"send", cfun_thread_send}, - {"close", cfun_thread_close}, - {NULL, NULL} -}; - -static int janet_thread_getter(void *p, Janet key, Janet *out) { - (void) p; - if (!janet_checktype(key, JANET_KEYWORD)) return 0; - return janet_getmethod(janet_unwrap_keyword(key), janet_thread_methods, out); -} - -static Janet janet_thread_next(void *p, Janet key) { - (void) p; - return janet_nextmethod(janet_thread_methods, key); -} - -static const JanetReg threadlib_cfuns[] = { - { - "thread/current", cfun_thread_current, - JDOC("(thread/current)\n\n" - "Get the current running thread.") - }, - { - "thread/new", cfun_thread_new, - JDOC("(thread/new func &opt capacity flags)\n\n" - "Start a new thread that will start immediately. " - "If capacity is provided, that is how many messages can be stored in the thread's mailbox before blocking senders. " - "The capacity must be between 1 and 65535 inclusive, and defaults to 10. " - "Can optionally provide flags to the new thread - supported flags are:\n\n" - "* :h - Start a heavyweight thread. This loads the core environment by default, so may use more memory initially. Messages may compress better, though.\n\n" - "* :a - Allow sending over registered abstract types to the new thread\n\n" - "* :c - Send over cfunction information to the new thread.\n\n" - "Returns a handle to the new thread.") - }, - { - "thread/send", cfun_thread_send, - JDOC("(thread/send thread msgi &opt timeout)\n\n" - "Send a message to the thread. By default, the timeout is 1 second, but an optional timeout " - "in seconds can be provided. Use math/inf for no timeout. " - "Will throw an error if there is a problem sending the message.") - }, - { - "thread/receive", cfun_thread_receive, - JDOC("(thread/receive &opt timeout)\n\n" - "Get a message sent to this thread. If timeout (in seconds) is provided, an error " - "will be thrown after the timeout has elapsed but " - "no messages are received. The default timeout is 1 second, and math/inf cam be passed to " - "turn off the timeout.") - }, - { - "thread/close", cfun_thread_close, - JDOC("(thread/close thread)\n\n" - "Close a thread, unblocking it and ending communication with it. Note that closing " - "a thread is idempotent and does not cancel the thread's operation. Returns nil.") - }, - { - "thread/exit", cfun_thread_exit, - JDOC("(thread/exit &opt code)\n\n" - "Exit from the current thread. If no more threads are running, ends the process, but otherwise does " - "not end the current process.") - }, - {NULL, NULL, NULL} -}; - -/* Module entry point */ -void janet_lib_thread(JanetTable *env) { - janet_core_cfuns(env, NULL, threadlib_cfuns); - janet_register_abstract_type(&janet_thread_type); -} - -#endif diff --git a/src/core/tuple.c b/src/core/tuple.c index cd1b1aa4..95791e45 100644 --- a/src/core/tuple.c +++ b/src/core/tuple.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -55,19 +55,35 @@ const Janet *janet_tuple_n(const Janet *values, int32_t n) { /* C Functions */ -static Janet cfun_tuple_brackets(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_tuple_brackets, + "(tuple/brackets & xs)", + "Creates a new bracketed tuple containing the elements xs.") { const Janet *tup = janet_tuple_n(argv, argc); janet_tuple_flag(tup) |= JANET_TUPLE_FLAG_BRACKETCTOR; return janet_wrap_tuple(tup); } -static Janet cfun_tuple_slice(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_tuple_slice, + "(tuple/slice arrtup [,start=0 [,end=(length arrtup)]])", + "Take a sub sequence of an array or tuple from index start " + "inclusive to index end exclusive. If start or end are not provided, " + "they default to 0 and the length of arrtup respectively. " + "'start' and 'end' can also be negative to indicate indexing " + "from the end of the input. Note that index -1 is synonymous with " + "index '(length arrtup)' to allow a full negative slice range. " + "Returns the new tuple.") { JanetView view = janet_getindexed(argv, 0); JanetRange range = janet_getslice(argc, argv); return janet_wrap_tuple(janet_tuple_n(view.items + range.start, range.end - range.start)); } -static Janet cfun_tuple_type(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_tuple_type, + "(tuple/type tup)", + "Checks how the tuple was constructed. Will return the keyword " + ":brackets if the tuple was parsed with brackets, and :parens " + "otherwise. The two types of tuples will behave the same most of " + "the time, but will print differently and be treated differently by " + "the compiler.") { janet_fixarity(argc, 1); const Janet *tup = janet_gettuple(argv, 0); if (janet_tuple_flag(tup) & JANET_TUPLE_FLAG_BRACKETCTOR) { @@ -77,7 +93,10 @@ static Janet cfun_tuple_type(int32_t argc, Janet *argv) { } } -static Janet cfun_tuple_sourcemap(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_tuple_sourcemap, + "(tuple/sourcemap tup)", + "Returns the sourcemap metadata attached to a tuple, " + " which is another tuple (line, column).") { janet_fixarity(argc, 1); const Janet *tup = janet_gettuple(argv, 0); Janet contents[2]; @@ -86,7 +105,10 @@ static Janet cfun_tuple_sourcemap(int32_t argc, Janet *argv) { return janet_wrap_tuple(janet_tuple_n(contents, 2)); } -static Janet cfun_tuple_setmap(int32_t argc, Janet *argv) { +JANET_CORE_FN(cfun_tuple_setmap, + "(tuple/setmap tup line column)", + "Set the sourcemap metadata on a tuple. line and column indicate " + "should be integers.") { janet_fixarity(argc, 3); const Janet *tup = janet_gettuple(argv, 0); janet_tuple_head(tup)->sm_line = janet_getinteger(argv, 1); @@ -94,48 +116,15 @@ static Janet cfun_tuple_setmap(int32_t argc, Janet *argv) { return argv[0]; } -static const JanetReg tuple_cfuns[] = { - { - "tuple/brackets", cfun_tuple_brackets, - JDOC("(tuple/brackets & xs)\n\n" - "Creates a new bracketed tuple containing the elements xs.") - }, - { - "tuple/slice", cfun_tuple_slice, - JDOC("(tuple/slice arrtup [,start=0 [,end=(length arrtup)]])\n\n" - "Take a sub sequence of an array or tuple from index start " - "inclusive to index end exclusive. If start or end are not provided, " - "they default to 0 and the length of arrtup respectively. " - "'start' and 'end' can also be negative to indicate indexing " - "from the end of the input. Note that index -1 is synonymous with " - "index '(length arrtup)' to allow a full negative slice range. " - "Returns the new tuple.") - }, - { - "tuple/type", cfun_tuple_type, - JDOC("(tuple/type tup)\n\n" - "Checks how the tuple was constructed. Will return the keyword " - ":brackets if the tuple was parsed with brackets, and :parens " - "otherwise. The two types of tuples will behave the same most of " - "the time, but will print differently and be treated differently by " - "the compiler.") - }, - { - "tuple/sourcemap", cfun_tuple_sourcemap, - JDOC("(tuple/sourcemap tup)\n\n" - "Returns the sourcemap metadata attached to a tuple, " - " which is another tuple (line, column).") - }, - { - "tuple/setmap", cfun_tuple_setmap, - JDOC("(tuple/setmap tup line column)\n\n" - "Set the sourcemap metadata on a tuple. line and column indicate " - "should be integers.") - }, - {NULL, NULL, NULL} -}; - /* Load the tuple module */ void janet_lib_tuple(JanetTable *env) { - janet_core_cfuns(env, NULL, tuple_cfuns); + JanetRegExt tuple_cfuns[] = { + JANET_CORE_REG("tuple/brackets", cfun_tuple_brackets), + JANET_CORE_REG("tuple/slice", cfun_tuple_slice), + JANET_CORE_REG("tuple/type", cfun_tuple_type), + JANET_CORE_REG("tuple/sourcemap", cfun_tuple_sourcemap), + JANET_CORE_REG("tuple/setmap", cfun_tuple_setmap), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, tuple_cfuns); } diff --git a/src/core/util.c b/src/core/util.c index c3005947..a0230037 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -362,105 +362,208 @@ const void *janet_strbinsearch( return NULL; } -/* Register a value in the global registry */ -void janet_register(const char *name, JanetCFunction cfun) { - Janet key = janet_wrap_cfunction(cfun); - Janet value = janet_csymbolv(name); - janet_table_put(janet_vm_registry, key, value); +/* Add sourcemapping and documentation to a binding table */ +static void janet_add_meta(JanetTable *table, const char *doc, const char *source_file, int32_t source_line) { + if (doc) { + janet_table_put(table, janet_ckeywordv("doc"), janet_cstringv(doc)); + } + if (source_file && source_line) { + Janet triple[3]; + triple[0] = janet_cstringv(source_file); + triple[1] = janet_wrap_integer(source_line); + triple[2] = janet_wrap_integer(1); + Janet value = janet_wrap_tuple(janet_tuple_n(triple, 3)); + janet_table_put(table, janet_ckeywordv("source-map"), value); + } } /* Add a def to an environment */ -void janet_def(JanetTable *env, const char *name, Janet val, const char *doc) { +void janet_def_sm(JanetTable *env, const char *name, Janet val, const char *doc, const char *source_file, int32_t source_line) { JanetTable *subt = janet_table(2); janet_table_put(subt, janet_ckeywordv("value"), val); - if (doc) - janet_table_put(subt, janet_ckeywordv("doc"), janet_cstringv(doc)); + janet_add_meta(subt, doc, source_file, source_line); janet_table_put(env, janet_csymbolv(name), janet_wrap_table(subt)); } +void janet_def(JanetTable *env, const char *name, Janet value, const char *doc) { + janet_def_sm(env, name, value, doc, NULL, 0); +} /* Add a var to the environment */ -void janet_var(JanetTable *env, const char *name, Janet val, const char *doc) { +void janet_var_sm(JanetTable *env, const char *name, Janet val, const char *doc, const char *source_file, int32_t source_line) { JanetArray *array = janet_array(1); JanetTable *subt = janet_table(2); janet_array_push(array, val); janet_table_put(subt, janet_ckeywordv("ref"), janet_wrap_array(array)); - if (doc) - janet_table_put(subt, janet_ckeywordv("doc"), janet_cstringv(doc)); + janet_add_meta(subt, doc, source_file, source_line); janet_table_put(env, janet_csymbolv(name), janet_wrap_table(subt)); } - -/* Load many cfunctions at once */ -static void _janet_cfuns_prefix(JanetTable *env, const char *regprefix, const JanetReg *cfuns, int defprefix) { - uint8_t *longname_buffer = NULL; - size_t prefixlen = 0; - size_t bufsize = 0; - if (NULL != regprefix) { - prefixlen = strlen(regprefix); - bufsize = prefixlen + 256; - longname_buffer = janet_malloc(bufsize); - if (NULL == longname_buffer) { - JANET_OUT_OF_MEMORY; - } - safe_memcpy(longname_buffer, regprefix, prefixlen); - longname_buffer[prefixlen] = '/'; - prefixlen++; - } - while (cfuns->name) { - Janet name; - if (NULL != regprefix) { - int32_t nmlen = 0; - while (cfuns->name[nmlen]) nmlen++; - int32_t totallen = (int32_t) prefixlen + nmlen; - if ((size_t) totallen > bufsize) { - bufsize = (size_t)(totallen) + 128; - longname_buffer = janet_realloc(longname_buffer, bufsize); - if (NULL == longname_buffer) { - JANET_OUT_OF_MEMORY; - } - } - safe_memcpy(longname_buffer + prefixlen, cfuns->name, nmlen); - name = janet_wrap_symbol(janet_symbol(longname_buffer, totallen)); - } else { - name = janet_csymbolv(cfuns->name); - } - Janet fun = janet_wrap_cfunction(cfuns->cfun); - if (defprefix) { - JanetTable *subt = janet_table(2); - janet_table_put(subt, janet_ckeywordv("value"), fun); - if (cfuns->documentation) - janet_table_put(subt, janet_ckeywordv("doc"), janet_cstringv(cfuns->documentation)); - janet_table_put(env, name, janet_wrap_table(subt)); - } else { - janet_def(env, cfuns->name, fun, cfuns->documentation); - } - janet_table_put(janet_vm_registry, fun, name); - cfuns++; - } - janet_free(longname_buffer); +void janet_var(JanetTable *env, const char *name, Janet val, const char *doc) { + janet_var_sm(env, name, val, doc, NULL, 0); } -void janet_cfuns_prefix(JanetTable *env, const char *regprefix, const JanetReg *cfuns) { - _janet_cfuns_prefix(env, regprefix, cfuns, 1); +/* Registry functions */ + +/* Put the registry in sorted order. */ +static void janet_registry_sort(void) { + for (size_t i = 1; i < janet_vm.registry_count; i++) { + JanetCFunRegistry reg = janet_vm.registry[i]; + size_t j; + for (j = i; j > 0; j--) { + if ((void *)(janet_vm.registry[j - 1].cfun) < (void *)(reg.cfun)) break; + janet_vm.registry[j] = janet_vm.registry[j - 1]; + } + janet_vm.registry[j] = reg; + } + janet_vm.registry_dirty = 0; +} + +void janet_registry_put( + JanetCFunction key, + const char *name, + const char *name_prefix, + const char *source_file, + int32_t source_line) { + if (janet_vm.registry_count == janet_vm.registry_cap) { + size_t newcap = (janet_vm.registry_count + 1) * 2; + /* Size it nicely with core by default */ + if (newcap < 512) { + newcap = 512; + } + void *newmem = janet_realloc(janet_vm.registry, newcap * sizeof(JanetCFunRegistry)); + if (NULL == newmem) { + JANET_OUT_OF_MEMORY; + } + janet_vm.registry = newmem; + janet_vm.registry_cap = newcap; + } + JanetCFunRegistry value = { + key, + name, + name_prefix, + source_file, + source_line + }; + janet_vm.registry[janet_vm.registry_count++] = value; + janet_vm.registry_dirty = 1; +} + +JanetCFunRegistry *janet_registry_get(JanetCFunction key) { + if (janet_vm.registry_dirty) { + janet_registry_sort(); + } + for (size_t i = 0; i < janet_vm.registry_count; i++) { + if (janet_vm.registry[i].cfun == key) { + return janet_vm.registry + i; + } + } + JanetCFunRegistry *lo = janet_vm.registry; + JanetCFunRegistry *hi = lo + janet_vm.registry_count; + while (lo < hi) { + JanetCFunRegistry *mid = lo + (hi - lo) / 2; + if (mid->cfun == key) { + return mid; + } + if ((void *)(mid->cfun) > (void *)(key)) { + hi = mid; + } else { + lo = mid + 1; + } + } + return NULL; +} + +typedef struct { + char *buf; + size_t plen; +} NameBuf; + +static void namebuf_init(NameBuf *namebuf, const char *prefix) { + size_t plen = strlen(prefix); + namebuf->plen = plen; + namebuf->buf = janet_malloc(namebuf->plen + 256); + if (NULL == namebuf->buf) { + JANET_OUT_OF_MEMORY; + } + memcpy(namebuf->buf, prefix, plen); + namebuf->buf[plen] = '/'; +} + +static void namebuf_deinit(NameBuf *namebuf) { + janet_free(namebuf->buf); +} + +static char *namebuf_name(NameBuf *namebuf, const char *suffix) { + size_t slen = strlen(suffix); + namebuf->buf = janet_realloc(namebuf->buf, namebuf->plen + 2 + slen); + if (NULL == namebuf->buf) { + JANET_OUT_OF_MEMORY; + } + memcpy(namebuf->buf + namebuf->plen + 1, suffix, slen); + namebuf->buf[namebuf->plen + 1 + slen] = '\0'; + return (char *)(namebuf->buf); } void janet_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns) { - _janet_cfuns_prefix(env, regprefix, cfuns, 0); + while (cfuns->name) { + Janet fun = janet_wrap_cfunction(cfuns->cfun); + if (env) janet_def(env, cfuns->name, fun, cfuns->documentation); + janet_registry_put(cfuns->cfun, cfuns->name, regprefix, NULL, 0); + cfuns++; + } +} + +void janet_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) { + while (cfuns->name) { + Janet fun = janet_wrap_cfunction(cfuns->cfun); + if (env) janet_def_sm(env, cfuns->name, fun, cfuns->documentation, cfuns->source_file, cfuns->source_line); + janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line); + cfuns++; + } +} + +void janet_cfuns_prefix(JanetTable *env, const char *regprefix, const JanetReg *cfuns) { + NameBuf nb; + if (env) namebuf_init(&nb, regprefix); + while (cfuns->name) { + Janet fun = janet_wrap_cfunction(cfuns->cfun); + if (env) janet_def(env, namebuf_name(&nb, cfuns->name), fun, cfuns->documentation); + janet_registry_put(cfuns->cfun, cfuns->name, regprefix, NULL, 0); + cfuns++; + } + if (env) namebuf_deinit(&nb); +} + +void janet_cfuns_ext_prefix(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) { + NameBuf nb; + if (env) namebuf_init(&nb, regprefix); + while (cfuns->name) { + Janet fun = janet_wrap_cfunction(cfuns->cfun); + if (env) janet_def_sm(env, namebuf_name(&nb, cfuns->name), fun, cfuns->documentation, cfuns->source_file, cfuns->source_line); + janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line); + cfuns++; + } + if (env) namebuf_deinit(&nb); +} + +/* Register a value in the global registry */ +void janet_register(const char *name, JanetCFunction cfun) { + janet_registry_put(cfun, name, NULL, NULL, 0); } /* Abstract type introspection */ void janet_register_abstract_type(const JanetAbstractType *at) { Janet sym = janet_csymbolv(at->name); - Janet check = janet_table_get(janet_vm_abstract_registry, sym); + Janet check = janet_table_get(janet_vm.abstract_registry, sym); if (!janet_checktype(check, JANET_NIL) && at != janet_unwrap_pointer(check)) { janet_panicf("cannot register abstract type %s, " "a type with the same name exists", at->name); } - janet_table_put(janet_vm_abstract_registry, sym, janet_wrap_pointer((void *) at)); + janet_table_put(janet_vm.abstract_registry, sym, janet_wrap_pointer((void *) at)); } const JanetAbstractType *janet_get_abstract_type(Janet key) { - Janet wrapped = janet_table_get(janet_vm_abstract_registry, key); + Janet wrapped = janet_table_get(janet_vm.abstract_registry, key); if (janet_checktype(wrapped, JANET_NIL)) { return NULL; } @@ -468,46 +571,82 @@ const JanetAbstractType *janet_get_abstract_type(Janet key) { } #ifndef JANET_BOOTSTRAP -void janet_core_def(JanetTable *env, const char *name, Janet x, const void *p) { +void janet_core_def_sm(JanetTable *env, const char *name, Janet x, const void *p, const void *sf, int32_t sl) { + (void) sf; + (void) sl; (void) p; Janet key = janet_csymbolv(name); janet_table_put(env, key, x); if (janet_checktype(x, JANET_CFUNCTION)) { - janet_table_put(janet_vm_registry, x, key); + janet_registry_put(janet_unwrap_cfunction(x), name, NULL, NULL, 0); } } -void janet_core_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns) { +void janet_core_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) { (void) regprefix; while (cfuns->name) { Janet fun = janet_wrap_cfunction(cfuns->cfun); - janet_core_def(env, cfuns->name, fun, cfuns->documentation); + janet_table_put(env, janet_csymbolv(cfuns->name), fun); + janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line); cfuns++; } } #endif -/* Resolve a symbol in the environment */ -JanetBindingType janet_resolve(JanetTable *env, const uint8_t *sym, Janet *out) { +JanetBinding janet_resolve_ext(JanetTable *env, const uint8_t *sym) { Janet ref; JanetTable *entry_table; Janet entry = janet_table_get(env, janet_wrap_symbol(sym)); + JanetBinding binding = { + JANET_BINDING_NONE, + janet_wrap_nil(), + JANET_BINDING_DEP_NONE + }; + + /* Check environment for entry */ if (!janet_checktype(entry, JANET_TABLE)) - return JANET_BINDING_NONE; + return binding; entry_table = janet_unwrap_table(entry); + + /* deprecation check */ + Janet deprecate = janet_table_get(entry_table, janet_ckeywordv("deprecated")); + if (janet_checktype(deprecate, JANET_KEYWORD)) { + JanetKeyword depkw = janet_unwrap_keyword(deprecate); + if (!janet_cstrcmp(depkw, "relaxed")) { + binding.deprecation = JANET_BINDING_DEP_RELAXED; + } else if (!janet_cstrcmp(depkw, "normal")) { + binding.deprecation = JANET_BINDING_DEP_NORMAL; + } else if (!janet_cstrcmp(depkw, "strict")) { + binding.deprecation = JANET_BINDING_DEP_STRICT; + } + } else if (!janet_checktype(deprecate, JANET_NIL)) { + binding.deprecation = JANET_BINDING_DEP_NORMAL; + } + if (!janet_checktype( janet_table_get(entry_table, janet_ckeywordv("macro")), JANET_NIL)) { - *out = janet_table_get(entry_table, janet_ckeywordv("value")); - return JANET_BINDING_MACRO; + binding.value = janet_table_get(entry_table, janet_ckeywordv("value")); + binding.type = JANET_BINDING_MACRO; + return binding; } + ref = janet_table_get(entry_table, janet_ckeywordv("ref")); if (janet_checktype(ref, JANET_ARRAY)) { - *out = ref; - return JANET_BINDING_VAR; + binding.value = ref; + binding.type = JANET_BINDING_VAR; + return binding; } - *out = janet_table_get(entry_table, janet_ckeywordv("value")); - return JANET_BINDING_DEF; + + binding.value = janet_table_get(entry_table, janet_ckeywordv("value")); + binding.type = JANET_BINDING_DEF; + return binding; +} + +JanetBindingType janet_resolve(JanetTable *env, const uint8_t *sym, Janet *out) { + JanetBinding binding = janet_resolve_ext(env, sym); + *out = binding.value; + return binding.type; } /* Resolve a symbol in the core environment. */ @@ -728,7 +867,7 @@ void *(janet_malloc)(size_t size) { } void (janet_free)(void *ptr) { - return janet_free(ptr); + janet_free(ptr); } void *(janet_calloc)(size_t nmemb, size_t size) { diff --git a/src/core/util.h b/src/core/util.h index a7633da1..87a381b7 100644 --- a/src/core/util.h +++ b/src/core/util.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -26,6 +26,7 @@ #ifndef JANET_AMALG #include "features.h" #include +#include "state.h" #endif #include @@ -48,20 +49,16 @@ } while (0) #endif +#define JANET_MARSHAL_DECREF 0x40000 + #define janet_assert(c, m) do { \ if (!(c)) JANET_EXIT((m)); \ } while (0) -/* Omit docstrings in some builds */ -#ifndef JANET_BOOTSTRAP -#define JDOC(x) NULL -#define JANET_NO_BOOTSTRAP -#else -#define JDOC(x) x -#endif - /* Utils */ #define janet_maphash(cap, hash) ((uint32_t)(hash) & (cap - 1)) +int janet_valid_utf8(const uint8_t *str, int32_t len); +int janet_is_symbol_char(uint8_t c); extern const char janet_base64[65]; int32_t janet_array_calchash(const Janet *array, int32_t len); int32_t janet_kv_calchash(const JanetKV *kvs, int32_t len); @@ -87,14 +84,29 @@ void janet_buffer_format( Janet *argv); Janet janet_next_impl(Janet ds, Janet key, int is_interpreter); +/* Registry functions */ +void janet_registry_put( + JanetCFunction key, + const char *name, + const char *name_prefix, + const char *source_file, + int32_t source_line); +JanetCFunRegistry *janet_registry_get(JanetCFunction key); + /* Inside the janet core, defining globals is different * at bootstrap time and normal runtime */ #ifdef JANET_BOOTSTRAP -#define janet_core_def janet_def -#define janet_core_cfuns janet_cfuns +#define JANET_CORE_REG JANET_REG +#define JANET_CORE_FN JANET_FN +#define JANET_CORE_DEF JANET_DEF +#define janet_core_def_sm janet_def_sm +#define janet_core_cfuns_ext janet_cfuns_ext #else -void janet_core_def(JanetTable *env, const char *name, Janet x, const void *p); -void janet_core_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns); +#define JANET_CORE_REG JANET_REG_S +#define JANET_CORE_FN JANET_FN_S +#define JANET_CORE_DEF(ENV, NAME, X, DOC) janet_core_def_sm(ENV, NAME, X, DOC, NULL, 0) +void janet_core_def_sm(JanetTable *env, const char *name, Janet x, const void *p, const void *sf, int32_t sl); +void janet_core_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns); #endif /* Clock gettime */ @@ -136,9 +148,6 @@ void janet_lib_typed_array(JanetTable *env); #ifdef JANET_INT_TYPES void janet_lib_inttypes(JanetTable *env); #endif -#ifdef JANET_THREADS -void janet_lib_thread(JanetTable *env); -#endif #ifdef JANET_NET void janet_lib_net(JanetTable *env); extern const JanetAbstractType janet_address_type; diff --git a/src/core/value.c b/src/core/value.c index ea0a95ed..74397171 100644 --- a/src/core/value.c +++ b/src/core/value.c @@ -31,31 +31,28 @@ #include -JANET_THREAD_LOCAL JanetTraversalNode *janet_vm_traversal = NULL; -JANET_THREAD_LOCAL JanetTraversalNode *janet_vm_traversal_top = NULL; -JANET_THREAD_LOCAL JanetTraversalNode *janet_vm_traversal_base = NULL; - static void push_traversal_node(void *lhs, void *rhs, int32_t index2) { JanetTraversalNode node; node.self = (JanetGCObject *) lhs; node.other = (JanetGCObject *) rhs; node.index = 0; node.index2 = index2; - if (janet_vm_traversal + 1 >= janet_vm_traversal_top) { - size_t oldsize = janet_vm_traversal - janet_vm_traversal_base; + int is_new = janet_vm.traversal_base == NULL; + if (is_new || (janet_vm.traversal + 1 >= janet_vm.traversal_top)) { + size_t oldsize = is_new ? 0 : (janet_vm.traversal - janet_vm.traversal_base); size_t newsize = 2 * oldsize + 1; if (newsize < 128) { newsize = 128; } - JanetTraversalNode *tn = janet_realloc(janet_vm_traversal_base, newsize * sizeof(JanetTraversalNode)); + JanetTraversalNode *tn = janet_realloc(janet_vm.traversal_base, newsize * sizeof(JanetTraversalNode)); if (tn == NULL) { JANET_OUT_OF_MEMORY; } - janet_vm_traversal_base = tn; - janet_vm_traversal_top = janet_vm_traversal_base + newsize; - janet_vm_traversal = janet_vm_traversal_base + oldsize; + janet_vm.traversal_base = tn; + janet_vm.traversal_top = janet_vm.traversal_base + newsize; + janet_vm.traversal = janet_vm.traversal_base + oldsize; } - *(++janet_vm_traversal) = node; + *(++janet_vm.traversal) = node; } /* @@ -67,8 +64,8 @@ static void push_traversal_node(void *lhs, void *rhs, int32_t index2) { * 3 - early stop - lhs > rhs */ static int traversal_next(Janet *x, Janet *y) { - JanetTraversalNode *t = janet_vm_traversal; - while (t && t > janet_vm_traversal_base) { + JanetTraversalNode *t = janet_vm.traversal; + while (t && t > janet_vm.traversal_base) { JanetGCObject *self = t->self; JanetTupleHead *tself = (JanetTupleHead *)self; JanetStructHead *sself = (JanetStructHead *)self; @@ -81,7 +78,7 @@ static int traversal_next(Janet *x, Janet *y) { int32_t index = t->index++; *x = tself->data[index]; *y = tother->data[index]; - janet_vm_traversal = t; + janet_vm.traversal = t; return 0; } if (t->index2 && tself->length != tother->length) { @@ -94,14 +91,14 @@ static int traversal_next(Janet *x, Janet *y) { int32_t index = t->index++; *x = sself->data[index].value; *y = sother->data[index].value; - janet_vm_traversal = t; + janet_vm.traversal = t; return 0; } for (int32_t i = t->index; i < sself->capacity; i++) { t->index2 = 1; *x = sself->data[t->index].key; *y = sother->data[t->index].key; - janet_vm_traversal = t; + janet_vm.traversal = t; return 0; } /* Traverse prototype */ @@ -112,13 +109,13 @@ static int traversal_next(Janet *x, Janet *y) { if (oproto && sproto) { *x = janet_wrap_struct(sproto); *y = janet_wrap_struct(oproto); - janet_vm_traversal = t - 1; + janet_vm.traversal = t - 1; return 0; } } t--; } - janet_vm_traversal = t; + janet_vm.traversal = t; return 2; } @@ -207,17 +204,17 @@ Janet janet_next_impl(Janet ds, Janet key, int is_interpreter) { status == JANET_STATUS_USER4) { return janet_wrap_nil(); } - janet_vm_fiber->child = child; + janet_vm.fiber->child = child; JanetSignal sig = janet_continue(child, janet_wrap_nil(), &retreg); if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) { if (is_interpreter) { janet_signalv(sig, retreg); } else { - janet_vm_fiber->child = NULL; + janet_vm.fiber->child = NULL; janet_panicv(retreg); } } - janet_vm_fiber->child = NULL; + janet_vm.fiber->child = NULL; if (sig == JANET_SIGNAL_OK || sig == JANET_SIGNAL_ERROR || sig == JANET_SIGNAL_USER0 || @@ -250,7 +247,7 @@ static int janet_compare_abstract(JanetAbstract xx, JanetAbstract yy) { } int janet_equals(Janet x, Janet y) { - janet_vm_traversal = janet_vm_traversal_base; + janet_vm.traversal = janet_vm.traversal_base; do { if (janet_type(x) != janet_type(y)) return 0; switch (janet_type(x)) { @@ -360,7 +357,7 @@ int32_t janet_hash(Janet x) { * If y is less, returns 1. All types are comparable * and should have strict ordering, excepts NaNs. */ int janet_compare(Janet x, Janet y) { - janet_vm_traversal = janet_vm_traversal_base; + janet_vm.traversal = janet_vm.traversal_base; int status; do { JanetType tx = janet_type(x); diff --git a/src/core/vector.c b/src/core/vector.c index 687d6375..8bf742da 100644 --- a/src/core/vector.c +++ b/src/core/vector.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/vector.h b/src/core/vector.h index 42e63da7..fc9cd2d1 100644 --- a/src/core/vector.h +++ b/src/core/vector.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/src/core/vm.c b/src/core/vm.c index ceb682a3..e6c1a7fd 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -32,17 +32,6 @@ #include -/* VM state */ -JANET_THREAD_LOCAL JanetTable *janet_vm_top_dyns; -JANET_THREAD_LOCAL JanetTable *janet_vm_core_env; -JANET_THREAD_LOCAL JanetTable *janet_vm_registry; -JANET_THREAD_LOCAL JanetTable *janet_vm_abstract_registry; -JANET_THREAD_LOCAL int janet_vm_stackn = 0; -JANET_THREAD_LOCAL JanetFiber *janet_vm_fiber = NULL; -JANET_THREAD_LOCAL JanetFiber *janet_vm_root_fiber = NULL; -JANET_THREAD_LOCAL Janet *janet_vm_return_reg = NULL; -JANET_THREAD_LOCAL jmp_buf *janet_vm_jmp_buf = NULL; - /* Virtual registers * * One instruction word @@ -91,18 +80,18 @@ JANET_THREAD_LOCAL jmp_buf *janet_vm_jmp_buf = NULL; func = janet_stack_frame(stack)->func; \ } while (0) #define vm_return(sig, val) do { \ - janet_vm_return_reg[0] = (val); \ + janet_vm.return_reg[0] = (val); \ vm_commit(); \ return (sig); \ } while (0) #define vm_return_no_restore(sig, val) do { \ - janet_vm_return_reg[0] = (val); \ + janet_vm.return_reg[0] = (val); \ return (sig); \ } while (0) /* Next instruction variations */ #define maybe_collect() do {\ - if (janet_vm_next_collection >= janet_vm_gc_interval) janet_collect(); } while (0) + if (janet_vm.next_collection >= janet_vm.gc_interval) janet_collect(); } while (0) #define vm_checkgc_next() maybe_collect(); vm_next() #define vm_pcnext() pc++; vm_next() #define vm_checkgc_pcnext() maybe_collect(); vm_pcnext() @@ -122,6 +111,17 @@ JANET_THREAD_LOCAL jmp_buf *janet_vm_jmp_buf = NULL; janet_panicf("expected %T, got %v", (TS), (X)); \ } \ } while (0) +#ifdef JANET_NO_INTERPRETER_INTERRUPT +#define vm_maybe_auto_suspend(COND) +#else +#define vm_maybe_auto_suspend(COND) do { \ + if ((COND) && janet_vm.auto_suspend) { \ + janet_vm.auto_suspend = 0; \ + fiber->flags |= (JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP); \ + vm_return(JANET_SIGNAL_INTERRUPT, janet_wrap_nil()); \ + } \ +} while (0) +#endif /* Templates for certain patterns in opcodes */ #define vm_binop_immediate(op)\ @@ -591,7 +591,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { JanetSignal sig = (fiber->gc.flags & JANET_FIBER_STATUS_MASK) >> JANET_FIBER_STATUS_OFFSET; fiber->gc.flags &= ~JANET_FIBER_STATUS_MASK; fiber->flags &= ~(JANET_FIBER_RESUME_SIGNAL | JANET_FIBER_FLAG_MASK); - janet_vm_return_reg[0] = in; + janet_vm.return_reg[0] = in; return sig; } @@ -757,11 +757,13 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { VM_OP(JOP_JUMP) pc += DS; + vm_maybe_auto_suspend(DS < 0); vm_next(); VM_OP(JOP_JUMP_IF) if (janet_truthy(stack[A])) { pc += ES; + vm_maybe_auto_suspend(ES < 0); } else { pc++; } @@ -772,12 +774,14 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { pc++; } else { pc += ES; + vm_maybe_auto_suspend(ES < 0); } vm_next(); VM_OP(JOP_JUMP_IF_NIL) if (janet_checktype(stack[A], JANET_NIL)) { pc += ES; + vm_maybe_auto_suspend(ES < 0); } else { pc++; } @@ -788,6 +792,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { pc++; } else { pc += ES; + vm_maybe_auto_suspend(ES < 0); } vm_next(); @@ -961,6 +966,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { vm_checkgc_pcnext(); VM_OP(JOP_CALL) { + vm_maybe_auto_suspend(1); Janet callee = stack[E]; if (fiber->stacktop > fiber->maxstack) { vm_throw("stack overflow"); @@ -1000,6 +1006,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { } VM_OP(JOP_TAILCALL) { + vm_maybe_auto_suspend(1); Janet callee = stack[D]; if (fiber->stacktop > fiber->maxstack) { vm_throw("stack overflow"); @@ -1046,6 +1053,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { VM_OP(JOP_RESUME) { Janet retreg; + vm_maybe_auto_suspend(1); vm_assert_type(stack[B], JANET_FIBER); JanetFiber *child = janet_unwrap_fiber(stack[B]); if (janet_check_can_resume(child, &retreg)) { @@ -1279,9 +1287,9 @@ JanetSignal janet_step(JanetFiber *fiber, Janet in, Janet *out) { Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv) { /* Check entry conditions */ - if (!janet_vm_fiber) + if (!janet_vm.fiber) janet_panic("janet_call failed because there is no current fiber"); - if (janet_vm_stackn >= JANET_RECURSION_GUARD) + if (janet_vm.stackn >= JANET_RECURSION_GUARD) janet_panic("C stack recursed too deeply"); /* Tracing */ @@ -1290,8 +1298,8 @@ Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv) { } /* Push frame */ - janet_fiber_pushn(janet_vm_fiber, argv, argc); - if (janet_fiber_funcframe(janet_vm_fiber, fun)) { + janet_fiber_pushn(janet_vm.fiber, argv, argc); + if (janet_fiber_funcframe(janet_vm.fiber, fun)) { int32_t min = fun->def->min_arity; int32_t max = fun->def->max_arity; Janet funv = janet_wrap_function(fun); @@ -1301,31 +1309,31 @@ Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv) { janet_panicf("arity mismatch in %v, expected at least %d, got %d", funv, min, argc); janet_panicf("arity mismatch in %v, expected at most %d, got %d", funv, max, argc); } - janet_fiber_frame(janet_vm_fiber)->flags |= JANET_STACKFRAME_ENTRANCE; + janet_fiber_frame(janet_vm.fiber)->flags |= JANET_STACKFRAME_ENTRANCE; /* Set up */ - int32_t oldn = janet_vm_stackn++; + int32_t oldn = janet_vm.stackn++; int handle = janet_gclock(); /* Run vm */ - janet_vm_fiber->flags |= JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP; - JanetSignal signal = run_vm(janet_vm_fiber, janet_wrap_nil()); + janet_vm.fiber->flags |= JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP; + JanetSignal signal = run_vm(janet_vm.fiber, janet_wrap_nil()); /* Teardown */ - janet_vm_stackn = oldn; + janet_vm.stackn = oldn; janet_gcunlock(handle); if (signal != JANET_SIGNAL_OK) { - janet_panicv(*janet_vm_return_reg); + janet_panicv(*janet_vm.return_reg); } - return *janet_vm_return_reg; + return *janet_vm.return_reg; } static JanetSignal janet_check_can_resume(JanetFiber *fiber, Janet *out) { /* Check conditions */ JanetFiberStatus old_status = janet_fiber_status(fiber); - if (janet_vm_stackn >= JANET_RECURSION_GUARD) { + if (janet_vm.stackn >= JANET_RECURSION_GUARD) { janet_fiber_set_status(fiber, JANET_STATUS_ERROR); *out = janet_cstringv("C stack recursed too deeply"); return JANET_SIGNAL_ERROR; @@ -1343,21 +1351,21 @@ static JanetSignal janet_check_can_resume(JanetFiber *fiber, Janet *out) { } void janet_try_init(JanetTryState *state) { - state->stackn = janet_vm_stackn++; - state->gc_handle = janet_vm_gc_suspend; - state->vm_fiber = janet_vm_fiber; - state->vm_jmp_buf = janet_vm_jmp_buf; - state->vm_return_reg = janet_vm_return_reg; - janet_vm_return_reg = &(state->payload); - janet_vm_jmp_buf = &(state->buf); + state->stackn = janet_vm.stackn++; + state->gc_handle = janet_vm.gc_suspend; + state->vm_fiber = janet_vm.fiber; + state->vm_jmp_buf = janet_vm.signal_buf; + state->vm_return_reg = janet_vm.return_reg; + janet_vm.return_reg = &(state->payload); + janet_vm.signal_buf = &(state->buf); } void janet_restore(JanetTryState *state) { - janet_vm_stackn = state->stackn; - janet_vm_gc_suspend = state->gc_handle; - janet_vm_fiber = state->vm_fiber; - janet_vm_jmp_buf = state->vm_jmp_buf; - janet_vm_return_reg = state->vm_return_reg; + janet_vm.stackn = state->stackn; + janet_vm.gc_suspend = state->gc_handle; + janet_vm.fiber = state->vm_fiber; + janet_vm.signal_buf = state->vm_jmp_buf; + janet_vm.return_reg = state->vm_return_reg; } static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *out) { @@ -1373,13 +1381,13 @@ static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *o /* Continue child fiber if it exists */ if (fiber->child) { - if (janet_vm_root_fiber == NULL) janet_vm_root_fiber = fiber; + if (janet_vm.root_fiber == NULL) janet_vm.root_fiber = fiber; JanetFiber *child = fiber->child; uint32_t instr = (janet_stack_frame(fiber->data + fiber->frame)->pc)[0]; - janet_vm_stackn++; + janet_vm.stackn++; JanetSignal sig = janet_continue(child, in, &in); - janet_vm_stackn--; - if (janet_vm_root_fiber == fiber) janet_vm_root_fiber = NULL; + janet_vm.stackn--; + if (janet_vm.root_fiber == fiber) janet_vm.root_fiber = NULL; if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) { *out = in; janet_fiber_set_status(fiber, sig); @@ -1425,14 +1433,14 @@ static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *o JanetSignal sig = janet_try(&tstate); if (!sig) { /* Normal setup */ - if (janet_vm_root_fiber == NULL) janet_vm_root_fiber = fiber; - janet_vm_fiber = fiber; + if (janet_vm.root_fiber == NULL) janet_vm.root_fiber = fiber; + janet_vm.fiber = fiber; janet_fiber_set_status(fiber, JANET_STATUS_ALIVE); sig = run_vm(fiber, in); } /* Restore */ - if (janet_vm_root_fiber == fiber) janet_vm_root_fiber = NULL; + if (janet_vm.root_fiber == fiber) janet_vm.root_fiber = NULL; janet_fiber_set_status(fiber, sig); janet_restore(&tstate); fiber->last_value = tstate.payload; @@ -1485,7 +1493,9 @@ JanetSignal janet_pcall( Janet janet_mcall(const char *name, int32_t argc, Janet *argv) { /* At least 1 argument */ - if (argc < 1) janet_panicf("method :%s expected at least 1 argument"); + if (argc < 1) { + janet_panicf("method :%s expected at least 1 argument", name); + } /* Find method */ Janet method = janet_method_lookup(argv[0], name); if (janet_checktype(method, JANET_NIL)) { @@ -1497,42 +1507,58 @@ Janet janet_mcall(const char *name, int32_t argc, Janet *argv) { /* Setup VM */ int janet_init(void) { + /* Garbage collection */ - janet_vm_blocks = NULL; - janet_vm_next_collection = 0; - janet_vm_gc_interval = 0x400000; - janet_vm_block_count = 0; + janet_vm.blocks = NULL; + janet_vm.next_collection = 0; + janet_vm.gc_interval = 0x400000; + janet_vm.block_count = 0; + janet_symcache_init(); + /* Initialize gc roots */ - janet_vm_roots = NULL; - janet_vm_root_count = 0; - janet_vm_root_capacity = 0; + janet_vm.roots = NULL; + janet_vm.root_count = 0; + janet_vm.root_capacity = 0; + /* Scratch memory */ - janet_scratch_mem = NULL; - janet_scratch_len = 0; - janet_scratch_cap = 0; + janet_vm.user = NULL; + janet_vm.scratch_mem = NULL; + janet_vm.scratch_len = 0; + janet_vm.scratch_cap = 0; + /* Initialize registry */ - janet_vm_registry = janet_table(0); - janet_vm_abstract_registry = janet_table(0); - janet_gcroot(janet_wrap_table(janet_vm_registry)); - janet_gcroot(janet_wrap_table(janet_vm_abstract_registry)); + janet_vm.registry = NULL; + janet_vm.registry_cap = 0; + janet_vm.registry_count = 0; + janet_vm.registry_dirty = 0; + + /* Intialize abstract registry */ + janet_vm.abstract_registry = janet_table(0); + janet_gcroot(janet_wrap_table(janet_vm.abstract_registry)); + /* Traversal */ - janet_vm_traversal = NULL; - janet_vm_traversal_base = NULL; - janet_vm_traversal_top = NULL; + janet_vm.traversal = NULL; + janet_vm.traversal_base = NULL; + janet_vm.traversal_top = NULL; + /* Core env */ - janet_vm_core_env = NULL; + janet_vm.core_env = NULL; + + /* Auto suspension */ + janet_vm.auto_suspend = 0; + /* Dynamic bindings */ - janet_vm_top_dyns = NULL; + janet_vm.top_dyns = NULL; + /* Seed RNG */ janet_rng_seed(janet_default_rng(), 0); + /* Fibers */ - janet_vm_fiber = NULL; - janet_vm_root_fiber = NULL; - janet_vm_stackn = 0; -#ifdef JANET_THREADS - janet_threads_init(); -#endif + janet_vm.fiber = NULL; + janet_vm.root_fiber = NULL; + janet_vm.stackn = 0; + #ifdef JANET_EV janet_ev_init(); #endif @@ -1546,20 +1572,19 @@ int janet_init(void) { void janet_deinit(void) { janet_clear_memory(); janet_symcache_deinit(); - janet_free(janet_vm_roots); - janet_vm_roots = NULL; - janet_vm_root_count = 0; - janet_vm_root_capacity = 0; - janet_vm_registry = NULL; - janet_vm_abstract_registry = NULL; - janet_vm_core_env = NULL; - janet_vm_top_dyns = NULL; - janet_free(janet_vm_traversal_base); - janet_vm_fiber = NULL; - janet_vm_root_fiber = NULL; -#ifdef JANET_THREADS - janet_threads_deinit(); -#endif + janet_free(janet_vm.roots); + janet_vm.roots = NULL; + janet_vm.root_count = 0; + janet_vm.root_capacity = 0; + janet_vm.abstract_registry = NULL; + janet_vm.core_env = NULL; + janet_vm.top_dyns = NULL; + janet_vm.user = NULL; + janet_free(janet_vm.traversal_base); + janet_vm.fiber = NULL; + janet_vm.root_fiber = NULL; + janet_free(janet_vm.registry); + janet_vm.registry = NULL; #ifdef JANET_EV janet_ev_deinit(); #endif diff --git a/src/core/wrap.c b/src/core/wrap.c index 2777f22b..3025c332 100644 --- a/src/core/wrap.c +++ b/src/core/wrap.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -163,7 +163,7 @@ Janet(janet_wrap_number)(double x) { void *janet_memalloc_empty(int32_t count) { int32_t i; void *mem = janet_malloc((size_t) count * sizeof(JanetKV)); - janet_vm_next_collection += (size_t) count * sizeof(JanetKV); + janet_vm.next_collection += (size_t) count * sizeof(JanetKV); if (NULL == mem) { JANET_OUT_OF_MEMORY; } diff --git a/src/include/janet.h b/src/include/janet.h index bf111e57..ee486da0 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -145,16 +145,17 @@ extern "C" { #endif /* Define how global janet state is declared */ +/* Also enable the thread library only if not single-threaded */ #ifdef JANET_SINGLE_THREADED #define JANET_THREAD_LOCAL +#undef JANET_THREADS #elif defined(__GNUC__) #define JANET_THREAD_LOCAL __thread -#define JANET_THREADS #elif defined(_MSC_BUILD) #define JANET_THREAD_LOCAL __declspec(thread) -#define JANET_THREADS #else #define JANET_THREAD_LOCAL +#undef JANET_THREADS #endif /* Enable or disable dynamic module loading. Enabled by default. */ @@ -172,11 +173,6 @@ extern "C" { #define JANET_PEG #endif -/* Enable or disable the typedarray module */ -#ifndef JANET_NO_TYPED_ARRAY -#define JANET_TYPED_ARRAY -#endif - /* Enable or disable event loop */ #if !defined(JANET_NO_EV) && !defined(__EMSCRIPTEN__) #define JANET_EV @@ -192,6 +188,21 @@ extern "C" { #define JANET_INT_TYPES #endif +/* Enable or disable epoll on Linux */ +#if defined(JANET_LINUX) && !defined(JANET_EV_NO_EPOLL) +#define JANET_EV_EPOLL +#endif + +/* Enable or disable kqueue on BSD */ +#if defined(JANET_BSD) && !defined(JANET_EV_NO_KQUEUE) +#define JANET_EV_KQUEUE +#endif + +/* Enable or disable kqueue on Apple */ +#if defined(JANET_APPLE) && !defined(JANET_EV_NO_KQUEUE) +#define JANET_EV_KQUEUE +#endif + /* How to export symbols */ #ifndef JANET_API #ifdef JANET_WINDOWS @@ -299,9 +310,10 @@ typedef struct { /***** START SECTION TYPES *****/ #ifdef JANET_WINDOWS -// Must be defined before including stdlib.h +/* Must be defined before including stdlib.h */ #define _CRT_RAND_S #endif + #include #include #include @@ -310,6 +322,25 @@ typedef struct { #include #include +/* Some extra includes if EV is enabled */ +#ifdef JANET_EV +#ifdef JANET_WINDOWS +typedef struct JanetDudCriticalSection { + /* Avoid including windows.h here - instead, create a structure of the same size */ + /* Needs to be same size as crtical section see WinNT.h for CRITCIAL_SECTION definition */ + void *debug_info; + long lock_count; + long recursion_count; + void *owning_thread; + void *lock_semaphore; + unsigned long spin_count; +} JanetOSMutex; +#else +#include +typedef pthread_mutex_t JanetOSMutex; +#endif +#endif + #ifdef JANET_BSD int _setjmp(jmp_buf); JANET_NO_RETURN void _longjmp(jmp_buf, int); @@ -348,6 +379,7 @@ typedef enum { } JanetSignal; #define JANET_SIGNAL_EVENT JANET_SIGNAL_USER9 +#define JANET_SIGNAL_INTERRUPT JANET_SIGNAL_USER8 /* Fiber statuses - mostly corresponds to signals. */ typedef enum { @@ -369,6 +401,9 @@ typedef enum { JANET_STATUS_ALIVE } JanetFiberStatus; +/* For encapsulating all thread-local Janet state (except natives) */ +typedef struct JanetVM JanetVM; + /* Use type punning for GC objects */ typedef struct JanetGCObject JanetGCObject; @@ -392,6 +427,7 @@ typedef struct JanetKV JanetKV; typedef struct JanetStackFrame JanetStackFrame; typedef struct JanetAbstractType JanetAbstractType; typedef struct JanetReg JanetReg; +typedef struct JanetRegExt JanetRegExt; typedef struct JanetMethod JanetMethod; typedef struct JanetSourceMapping JanetSourceMapping; typedef struct JanetView JanetView; @@ -827,7 +863,10 @@ JANET_API JanetAbstract janet_checkabstract(Janet x, const JanetAbstractType *at * list of blocks, which is naive but works. */ struct JanetGCObject { int32_t flags; - JanetGCObject *next; + union { + JanetGCObject *next; + int32_t refcount; /* For threaded abstract types */ + } data; }; /* A lightweight green thread in janet. Does not correspond to @@ -1083,6 +1122,14 @@ struct JanetReg { const char *documentation; }; +struct JanetRegExt { + const char *name; + JanetCFunction cfun; + const char *documentation; + const char *source_file; + int32_t source_line; +}; + struct JanetMethod { const char *name; JanetCFunction cfun; @@ -1268,10 +1315,36 @@ extern enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT]; #ifdef JANET_EV extern JANET_API const JanetAbstractType janet_stream_type; +extern JANET_API const JanetAbstractType janet_channel_type; /* Run the event loop */ JANET_API void janet_loop(void); +/* Run the event loop, but allow for user scheduled interrupts triggered + * by janet_loop1_interrupt being called in library code, a signal handler, or + * another thread. + * + * Example: + * + * while (!janet_loop_done()) { + * // One turn of the event loop + * JanetFiber *interrupted_fiber = janet_loop1(); + * // interrupted_fiber may be NULL + * // do some work here periodically... + * if (NULL != interrupted_fiber) { + * if (cancel_interrupted_fiber) { + * janet_cancel(interrupted_fiber, janet_cstringv("fiber was interrupted for [reason]")); + * } else { + * janet_schedule(interrupted_fiber, janet_wrap_nil()); + * } + * } + * } + * + */ +JANET_API int janet_loop_done(void); +JANET_API JanetFiber *janet_loop1(void); +JANET_API void janet_loop1_interrupt(JanetVM *vm); + /* Wrapper around streams */ JANET_API JanetStream *janet_stream(JanetHandle handle, uint32_t flags, const JanetMethod *methods); JANET_API void janet_stream_close(JanetStream *stream); @@ -1299,7 +1372,20 @@ JANET_API void janet_addtimeout(double sec); JANET_API void janet_ev_inc_refcount(void); JANET_API void janet_ev_dec_refcount(void); -/* Get last error from a an IO operation */ +/* Thread aware abstract types and helpers */ +JANET_API void *janet_abstract_begin_threaded(const JanetAbstractType *atype, size_t size); +JANET_API void *janet_abstract_end_threaded(void *x); +JANET_API void *janet_abstract_threaded(const JanetAbstractType *atype, size_t size); +JANET_API int32_t janet_abstract_incref(void *abst); +JANET_API int32_t janet_abstract_decref(void *abst); + +/* Expose some OS sync primitives to make portable abstract types easier to implement */ +JANET_API void janet_os_mutex_init(JanetOSMutex *mutex); +JANET_API void janet_os_mutex_deinit(JanetOSMutex *mutex); +JANET_API void janet_os_mutex_lock(JanetOSMutex *mutex); +JANET_API void janet_os_mutex_unlock(JanetOSMutex *mutex); + +/* Get last error from an IO operation */ JANET_API Janet janet_ev_lasterr(void); /* Async service for calling a function or syscall in a background thread. This is not @@ -1313,6 +1399,7 @@ typedef struct { int tag; int argi; void *argp; + Janet argj; JanetFiber *fiber; } JanetEVGenericMessage; @@ -1335,13 +1422,20 @@ typedef struct { /* Function pointer that is run in the thread pool */ typedef JanetEVGenericMessage(*JanetThreadedSubroutine)(JanetEVGenericMessage arguments); -/* Handler that is run in the main thread with the result of the JanetAsyncSubroutine */ +/* Handler for events posted to the event loop */ +typedef void (*JanetCallback)(JanetEVGenericMessage return_value); + +/* Handler that is run in the main thread with the result of the JanetAsyncSubroutine (same as JanetCallback) */ typedef void (*JanetThreadedCallback)(JanetEVGenericMessage return_value); /* API calls for quickly offloading some work in C to a new thread or thread pool. */ JANET_API void janet_ev_threaded_call(JanetThreadedSubroutine fp, JanetEVGenericMessage arguments, JanetThreadedCallback cb); JANET_NO_RETURN JANET_API void janet_ev_threaded_await(JanetThreadedSubroutine fp, int tag, int argi, void *argp); +/* Post callback + userdata to an event loop. Takes the vm parameter to allow posting from other + * threads or signal handlers. Use NULL to post to the current thread. */ +JANET_API void janet_ev_post_event(JanetVM *vm, JanetCallback cb, JanetEVGenericMessage msg); + /* Callback used by janet_ev_threaded_await */ JANET_API void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value); @@ -1410,16 +1504,26 @@ struct JanetCompileResult { enum JanetCompileStatus status; }; JANET_API JanetCompileResult janet_compile(Janet source, JanetTable *env, JanetString where); +JANET_API JanetCompileResult janet_compile_lint( + Janet source, + JanetTable *env, + JanetString where, + JanetArray *lints); /* Get the default environment for janet */ JANET_API JanetTable *janet_core_env(JanetTable *replacements); JANET_API JanetTable *janet_core_lookup_table(JanetTable *replacements); +/* Execute strings */ JANET_API int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char *sourcePath, Janet *out); JANET_API int janet_dostring(JanetTable *env, const char *str, const char *sourcePath, Janet *out); +/* Run the entrypoint of a wrapped program */ +JANET_API int janet_loop_fiber(JanetFiber *fiber); + /* Number scanning */ JANET_API int janet_scan_number(const uint8_t *str, int32_t len, double *out); +JANET_API int janet_scan_number_base(const uint8_t *str, int32_t len, int32_t base, double *out); JANET_API int janet_scan_int64(const uint8_t *str, int32_t len, int64_t *out); JANET_API int janet_scan_uint64(const uint8_t *str, int32_t len, uint64_t *out); @@ -1436,6 +1540,7 @@ JANET_API JanetRNG *janet_default_rng(void); JANET_API void janet_rng_seed(JanetRNG *rng, uint32_t seed); JANET_API void janet_rng_longseed(JanetRNG *rng, const uint8_t *bytes, int32_t len); JANET_API uint32_t janet_rng_u32(JanetRNG *rng); +JANET_API double janet_rng_double(JanetRNG *rng); /* Array functions */ JANET_API JanetArray *janet_array(int32_t capacity); @@ -1529,6 +1634,7 @@ JANET_API const JanetKV *janet_struct_find(JanetStruct st, Janet key); /* Table functions */ JANET_API JanetTable *janet_table(int32_t capacity); JANET_API JanetTable *janet_table_init(JanetTable *table, int32_t capacity); +JANET_API JanetTable *janet_table_init_raw(JanetTable *table, int32_t capacity); JANET_API void janet_table_deinit(JanetTable *table); JANET_API Janet janet_table_get(JanetTable *t, Janet key); JANET_API Janet janet_table_get_ex(JanetTable *t, Janet key, JanetTable **which); @@ -1644,6 +1750,12 @@ JANET_API int32_t janet_sorted_keys(const JanetKV *dict, int32_t cap, int32_t *i /* VM functions */ JANET_API int janet_init(void); JANET_API void janet_deinit(void); +JANET_API JanetVM *janet_vm_alloc(void); +JANET_API JanetVM *janet_local_vm(void); +JANET_API void janet_vm_free(JanetVM *vm); +JANET_API void janet_vm_save(JanetVM *into); +JANET_API void janet_vm_load(JanetVM *from); +JANET_API void janet_interpreter_interrupt(JanetVM *vm); JANET_API JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out); JANET_API JanetSignal janet_continue_signal(JanetFiber *fiber, Janet in, Janet *out, JanetSignal sig); JANET_API JanetSignal janet_pcall(JanetFunction *fun, int32_t argn, const Janet *argv, Janet *out, JanetFiber **f); @@ -1668,12 +1780,24 @@ typedef enum { JANET_BINDING_VAR, JANET_BINDING_MACRO } JanetBindingType; + +typedef struct { + JanetBindingType type; + Janet value; + enum { + JANET_BINDING_DEP_NONE, + JANET_BINDING_DEP_RELAXED, + JANET_BINDING_DEP_NORMAL, + JANET_BINDING_DEP_STRICT, + } deprecation; +} JanetBinding; + JANET_API void janet_def(JanetTable *env, const char *name, Janet val, const char *documentation); JANET_API void janet_var(JanetTable *env, const char *name, Janet val, const char *documentation); JANET_API void janet_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns); JANET_API void janet_cfuns_prefix(JanetTable *env, const char *regprefix, const JanetReg *cfuns); JANET_API JanetBindingType janet_resolve(JanetTable *env, JanetSymbol sym, Janet *out); -JANET_API void janet_register(const char *name, JanetCFunction cfun); +JANET_API JanetBinding janet_resolve_ext(JanetTable *env, JanetSymbol sym); /* Get values from the core environment. */ JANET_API Janet janet_resolve_core(const char *name); @@ -1683,6 +1807,70 @@ JANET_API Janet janet_resolve_core(const char *name); /* Shorthand for janet C function declarations */ #define JANET_CFUN(name) Janet name (int32_t argc, Janet *argv) +/* Declare a C function with documentation and source mapping */ +#define JANET_REG_END {NULL, NULL, NULL, NULL, 0} + +/* no docstrings or sourcemaps */ +#define JANET_REG_(JNAME, CNAME) {JNAME, CNAME, NULL, NULL, 0} +#define JANET_FN_(CNAME, USAGE, DOCSTRING) \ + Janet CNAME (int32_t argc, Janet *argv) +#define JANET_DEF_(ENV, JNAME, VAL, DOC) \ + janet_def(ENV, JNAME, VAL, NULL) + +/* sourcemaps only */ +#define JANET_REG_S(JNAME, CNAME) {JNAME, CNAME, NULL, __FILE__, CNAME##_sourceline_} +#define JANET_FN_S(CNAME, USAGE, DOCSTRING) \ + static int32_t CNAME##_sourceline_ = __LINE__; \ + Janet CNAME (int32_t argc, Janet *argv) +#define JANET_DEF_S(ENV, JNAME, VAL, DOC) \ + janet_def_sm(ENV, JNAME, VAL, NULL, __FILE__, __LINE__) + +/* docstring only */ +#define JANET_REG_D(JNAME, CNAME) {JNAME, CNAME, CNAME##_docstring_, NULL, 0} +#define JANET_FN_D(CNAME, USAGE, DOCSTRING) \ + static const char CNAME##_docstring_[] = USAGE "\n\n" DOCSTRING; \ + Janet CNAME (int32_t argc, Janet *argv) +#define JANET_DEF_D(ENV, JNAME, VAL, DOC) \ + janet_def(ENV, JNAME, VAL, DOC) + +/* sourcemaps and docstrings */ +#define JANET_REG_SD(JNAME, CNAME) {JNAME, CNAME, CNAME##_docstring_, __FILE__, CNAME##_sourceline_} +#define JANET_FN_SD(CNAME, USAGE, DOCSTRING) \ + static int32_t CNAME##_sourceline_ = __LINE__; \ + static const char CNAME##_docstring_[] = USAGE "\n\n" DOCSTRING; \ + Janet CNAME (int32_t argc, Janet *argv) +#define JANET_DEF_SD(ENV, JNAME, VAL, DOC) \ + janet_def_sm(ENV, JNAME, VAL, DOC, __FILE__, __LINE__) + + +/* Choose defaults for source mapping and docstring based on config defs */ +#if defined(JANET_NO_SOURCEMAPS) && defined(JANET_NO_DOCSTRINGS) +#define JANET_REG JANET_REG_ +#define JANET_FN JANET_FN_ +#define JANET_DEF JANET_DEF_ +#elif defined(JANET_NO_SOURCEMAPS) && !defined(JANET_NO_DOCSTRINGS) +#define JANET_REG JANET_REG_D +#define JANET_FN JANET_FN_D +#define JANET_DEF JANET_DEF_D +#elif !defined(JANET_NO_SOURCEMAPS) && defined(JANET_NO_DOCSTRINGS) +#define JANET_REG JANET_REG_S +#define JANET_FN JANET_FN_S +#define JANET_DEF JANET_DEF_S +#elif !defined(JANET_NO_SOURCEMAPS) && !defined(JANET_NO_DOCSTRINGS) +#define JANET_REG JANET_REG_SD +#define JANET_FN JANET_FN_SD +#define JANET_DEF JANET_DEF_SD +#endif + +/* Define things with source mapping information */ +JANET_API void janet_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns); +JANET_API void janet_cfuns_ext_prefix(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns); +JANET_API void janet_def_sm(JanetTable *env, const char *name, Janet val, const char *documentation, const char *source_file, int32_t source_line); +JANET_API void janet_var_sm(JanetTable *env, const char *name, Janet val, const char *documentation, const char *source_file, int32_t source_line); + +/* Legacy definition of C functions */ +JANET_API void janet_register(const char *name, JanetCFunction cfun); + /* Allow setting entry name for static libraries */ #ifdef __cplusplus #define JANET_MODULE_PREFIX extern "C" @@ -1812,6 +2000,7 @@ JANET_API uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx); JANET_API void janet_unmarshal_bytes(JanetMarshalContext *ctx, uint8_t *dest, size_t len); JANET_API Janet janet_unmarshal_janet(JanetMarshalContext *ctx); JANET_API JanetAbstract janet_unmarshal_abstract(JanetMarshalContext *ctx, size_t size); +JANET_API void janet_unmarshal_abstract_reuse(JanetMarshalContext *ctx, void *p); JANET_API void janet_register_abstract_type(const JanetAbstractType *at); JANET_API const JanetAbstractType *janet_get_abstract_type(Janet key); @@ -1852,7 +2041,8 @@ typedef enum { RULE_READINT, /* [(signedness << 4) | (endianess << 5) | bytewidth, tag] */ RULE_LINE, /* [tag] */ RULE_COLUMN, /* [tag] */ - RULE_UNREF /* [rule, tag] */ + RULE_UNREF, /* [rule, tag] */ + RULE_CAPTURE_NUM /* [rule, tag] */ } JanetPegOpcod; typedef struct { diff --git a/src/mainclient/shell.c b/src/mainclient/shell.c index 4b17e777..396c6762 100644 --- a/src/mainclient/shell.c +++ b/src/mainclient/shell.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to @@ -1021,7 +1021,6 @@ int main(int argc, char **argv) { janet_init_hash_key(hash_key); #endif - /* Set up VM */ janet_init(); @@ -1048,18 +1047,8 @@ int main(int argc, char **argv) { JanetFiber *fiber = janet_fiber(janet_unwrap_function(mainfun), 64, 1, mainargs); fiber->env = env; -#ifdef JANET_EV - janet_gcroot(janet_wrap_fiber(fiber)); - janet_schedule(fiber, janet_wrap_nil()); - janet_loop(); - status = janet_fiber_status(fiber); -#else - Janet out; - status = janet_continue(fiber, janet_wrap_nil(), &out); - if (status != JANET_SIGNAL_OK && status != JANET_SIGNAL_EVENT) { - janet_stacktrace(fiber, out); - } -#endif + /* Run the fiber in an event loop */ + status = janet_loop_fiber(fiber); /* Deinitialize vm */ janet_deinit(); diff --git a/test/amalg/main.c b/test/amalg/main.c index 4521ab59..10c17a1c 100644 --- a/test/amalg/main.c +++ b/test/amalg/main.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to diff --git a/test/install/.gitignore b/test/install/.gitignore deleted file mode 100644 index 9a026ee6..00000000 --- a/test/install/.gitignore +++ /dev/null @@ -1,10 +0,0 @@ -/build -/modpath -.cache -.manifests -json.* -jhydro.* -circlet.* -argparse.* -sqlite3.* -path.* diff --git a/test/install/project.janet b/test/install/project.janet deleted file mode 100644 index e91ad20e..00000000 --- a/test/install/project.janet +++ /dev/null @@ -1,26 +0,0 @@ -(declare-project - :name "testmod") - -(declare-native - :name "testmod" - :source @["testmod.c"]) - -(declare-native - :name "testmod2" - :source @["testmod2.c"]) - -(declare-native - :name "testmod3" - :source @["testmod3.cpp"]) - -(declare-native - :name "test-mod-4" - :source @["testmod4.c"]) - -(declare-native - :name "testmod5" - :source @["testmod5.cc"]) - -(declare-executable - :name "testexec" - :entry "testexec.janet") diff --git a/test/install/test/test1.janet b/test/install/test/test1.janet deleted file mode 100644 index d6c9c0f5..00000000 --- a/test/install/test/test1.janet +++ /dev/null @@ -1,3 +0,0 @@ -(import /build/testmod :as testmod) - -(if (not= 5 (testmod/get5)) (error "testmod/get5 failed")) diff --git a/test/install/testexec.janet b/test/install/testexec.janet deleted file mode 100644 index 2e511936..00000000 --- a/test/install/testexec.janet +++ /dev/null @@ -1,9 +0,0 @@ -(use /build/testmod) -(use /build/testmod2) -(use /build/testmod3) -(use /build/test-mod-4) -(use /build/testmod5) - -(defn main [&] - (print "Hello from executable!") - (print (+ (get5) (get6) (get7) (get8) (get9)))) diff --git a/test/install/testmod2.c b/test/install/testmod2.c deleted file mode 100644 index 80d9bae4..00000000 --- a/test/install/testmod2.c +++ /dev/null @@ -1,40 +0,0 @@ -/* -* Copyright (c) 2020 Calvin Rose and contributors -* -* Permission is hereby granted, free of charge, to any person obtaining a copy -* of this software and associated documentation files (the "Software"), to -* deal in the Software without restriction, including without limitation the -* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -* sell copies of the Software, and to permit persons to whom the Software is -* furnished to do so, subject to the following conditions: -* -* The above copyright notice and this permission notice shall be included in -* all copies or substantial portions of the Software. -* -* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -* IN THE SOFTWARE. -*/ - -/* A very simple native module */ - -#include - -static Janet cfun_get_six(int32_t argc, Janet *argv) { - (void) argv; - janet_fixarity(argc, 0); - return janet_wrap_number(6.0); -} - -static const JanetReg array_cfuns[] = { - {"get6", cfun_get_six, NULL}, - {NULL, NULL, NULL} -}; - -JANET_MODULE_ENTRY(JanetTable *env) { - janet_cfuns(env, NULL, array_cfuns); -} diff --git a/test/install/testmod3.cpp b/test/install/testmod3.cpp deleted file mode 100644 index dfaf94f0..00000000 --- a/test/install/testmod3.cpp +++ /dev/null @@ -1,42 +0,0 @@ -/* -* Copyright (c) 2020 Calvin Rose and contributors -* -* Permission is hereby granted, free of charge, to any person obtaining a copy -* of this software and associated documentation files (the "Software"), to -* deal in the Software without restriction, including without limitation the -* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -* sell copies of the Software, and to permit persons to whom the Software is -* furnished to do so, subject to the following conditions: -* -* The above copyright notice and this permission notice shall be included in -* all copies or substantial portions of the Software. -* -* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -* IN THE SOFTWARE. -*/ - -/* A very simple native module */ - -#include -#include - -static Janet cfun_get_seven(int32_t argc, Janet *argv) { - (void) argv; - janet_fixarity(argc, 0); - std::cout << "Hello!" << std::endl; - return janet_wrap_number(7.0); -} - -static const JanetReg array_cfuns[] = { - {"get7", cfun_get_seven, NULL}, - {NULL, NULL, NULL} -}; - -JANET_MODULE_ENTRY(JanetTable *env) { - janet_cfuns(env, NULL, array_cfuns); -} diff --git a/test/install/testmod4.c b/test/install/testmod4.c deleted file mode 100644 index b29249dd..00000000 --- a/test/install/testmod4.c +++ /dev/null @@ -1,40 +0,0 @@ -/* -* Copyright (c) 2020 Calvin Rose and contributors -* -* Permission is hereby granted, free of charge, to any person obtaining a copy -* of this software and associated documentation files (the "Software"), to -* deal in the Software without restriction, including without limitation the -* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -* sell copies of the Software, and to permit persons to whom the Software is -* furnished to do so, subject to the following conditions: -* -* The above copyright notice and this permission notice shall be included in -* all copies or substantial portions of the Software. -* -* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -* IN THE SOFTWARE. -*/ - -/* A very simple native module */ - -#include - -static Janet cfun_get_eight(int32_t argc, Janet *argv) { - (void) argv; - janet_fixarity(argc, 0); - return janet_wrap_number(8.0); -} - -static const JanetReg array_cfuns[] = { - {"get8", cfun_get_eight, NULL}, - {NULL, NULL, NULL} -}; - -JANET_MODULE_ENTRY(JanetTable *env) { - janet_cfuns(env, NULL, array_cfuns); -} diff --git a/test/install/testmod5.cc b/test/install/testmod5.cc deleted file mode 100644 index 2e8ae6db..00000000 --- a/test/install/testmod5.cc +++ /dev/null @@ -1,42 +0,0 @@ -/* -* Copyright (c) 2020 Calvin Rose and contributors -* -* Permission is hereby granted, free of charge, to any person obtaining a copy -* of this software and associated documentation files (the "Software"), to -* deal in the Software without restriction, including without limitation the -* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -* sell copies of the Software, and to permit persons to whom the Software is -* furnished to do so, subject to the following conditions: -* -* The above copyright notice and this permission notice shall be included in -* all copies or substantial portions of the Software. -* -* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -* IN THE SOFTWARE. -*/ - -/* A very simple native module */ - -#include -#include - -static Janet cfun_get_nine(int32_t argc, Janet *argv) { - (void) argv; - janet_fixarity(argc, 0); - std::cout << "Hello!" << std::endl; - return janet_wrap_number(9.0); -} - -static const JanetReg array_cfuns[] = { - {"get9", cfun_get_nine, NULL}, - {NULL, NULL, NULL} -}; - -JANET_MODULE_ENTRY(JanetTable *env) { - janet_cfuns(env, NULL, array_cfuns); -} diff --git a/test/suite0000.janet b/test/suite0000.janet index c5ecc226..39d63b6e 100644 --- a/test/suite0000.janet +++ b/test/suite0000.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose +# Copyright (c) 2021 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to @@ -202,6 +202,7 @@ #🐙🐙🐙🐙 +(defn foo [Θa Θb Θc] 0) (def 🦊 :fox) (def 🐮 :cow) (assert (= (string "🐼" 🦊 🐮) "🐼foxcow") "emojis 🙉 :)") diff --git a/test/suite0001.janet b/test/suite0001.janet index 810432bd..7501f37a 100644 --- a/test/suite0001.janet +++ b/test/suite0001.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose +# Copyright (c) 2021 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to diff --git a/test/suite0002.janet b/test/suite0002.janet index e606c5e4..4721d685 100644 --- a/test/suite0002.janet +++ b/test/suite0002.janet @@ -1,4 +1,4 @@ -#' Copyright (c) 2020 Calvin Rose +# Copyright (c) 2021 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to diff --git a/test/suite0003.janet b/test/suite0003.janet index 2a7277d3..152ea02b 100644 --- a/test/suite0003.janet +++ b/test/suite0003.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose +# Copyright (c) 2021 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to diff --git a/test/suite0004.janet b/test/suite0004.janet index 17b1f358..dc8438cd 100644 --- a/test/suite0004.janet +++ b/test/suite0004.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose +# Copyright (c) 2021 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to diff --git a/test/suite0005.janet b/test/suite0005.janet index 300e72e1..0e982174 100644 --- a/test/suite0005.janet +++ b/test/suite0005.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose & contributors +# Copyright (c) 2021 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to @@ -51,7 +51,10 @@ (assert (deep= (take 0 [1 2 3 4 5]) []) "take 3") (assert (deep= (take 10 [1 2 3]) [1 2 3]) "take 4") (assert (deep= (take -1 [:a :b :c]) []) "take 5") -(assert-error :invalid-type (take 3 {}) "take 6") +(assert (deep= (take 3 (generate [x :in [1 2 3 4 5]] x)) @[1 2 3]) "take from fiber") +# NB: repeatedly resuming a fiber created with `generate` includes a `nil` as +# the final element. Thus a generate of 2 elements will create an array of 3. +(assert (= (length (take 4 (generate [x :in [1 2]] x))) 2) "take from short fiber") # take-until @@ -61,6 +64,8 @@ (assert (deep= (take-until pos? @[-1 -2 3]) [-1 -2]) "take-until 4") (assert (deep= (take-until pos? @[-1 1 -2]) [-1]) "take-until 5") (assert (deep= (take-until |(= $ 115) "books") "book") "take-until 6") +(assert (deep= (take-until |(= $ 115) (generate [x :in "books"] x)) + @[98 111 111 107]) "take-until from fiber") # take-while @@ -69,6 +74,8 @@ (assert (deep= (take-while neg? @[-1 -2 -3]) [-1 -2 -3]) "take-while 3") (assert (deep= (take-while neg? @[-1 -2 3]) [-1 -2]) "take-while 4") (assert (deep= (take-while neg? @[-1 1 -2]) [-1]) "take-while 5") +(assert (deep= (take-while neg? (generate [x :in @[-1 1 -2]] x)) + @[-1]) "take-while from fiber") # drop diff --git a/test/suite0006.janet b/test/suite0006.janet index e37dff75..e0fa6774 100644 --- a/test/suite0006.janet +++ b/test/suite0006.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose & contributors +# Copyright (c) 2021 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to diff --git a/test/suite0007.janet b/test/suite0007.janet index 3dd5534b..f24aa1a1 100644 --- a/test/suite0007.janet +++ b/test/suite0007.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose & contributors +# Copyright (c) 2021 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to @@ -311,4 +311,6 @@ (tracev (def my-unique-var-name true)) (assert my-unique-var-name "tracev upscopes") +(assert (pos? (length (gensym))) "gensym not empty, regression #753") + (end-suite) diff --git a/test/suite0008.janet b/test/suite0008.janet index 4eb70040..3f91ace7 100644 --- a/test/suite0008.janet +++ b/test/suite0008.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2020 Calvin Rose & contributors +# Copyright (c) 2021 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to @@ -344,4 +344,8 @@ neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02 (assert (deep= @[] (peg/match '(* "test" (any 1)) @"test")) "peg empty pattern 5") (assert (deep= @[] (peg/match '(* "test" (any 1)) (buffer "test"))) "peg empty pattern 6") +# number pattern +(assert (deep= @[111] (peg/match '(number :d+) "111")) "simple number capture 1") +(assert (deep= @[255] (peg/match '(number :w+) "0xff")) "simple number capture 2") + (end-suite) diff --git a/test/suite0009.janet b/test/suite0009.janet index 2b744a73..cb205cd2 100644 --- a/test/suite0009.janet +++ b/test/suite0009.janet @@ -47,6 +47,11 @@ (assert-no-error "pipe stdin to process 2" (os/proc-wait p)) (assert (= "hello!" (string/trim x)) "round trip pipeline in process")) +(let [p (os/spawn [janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] + (os/proc-kill p) + (def retval (os/proc-wait p)) + (assert (not= retval 24) "Process was *not* terminated by parent")) + # Parallel subprocesses (defn calc-1 @@ -100,6 +105,17 @@ (file/close outfile) (os/rm "unique.txt")) +# Ensure that the stream created by os/open works + +(assert-no-error "File writing 4.1" + (def outstream (os/open "unique.txt" :wct)) + (defer (:close outstream) + (:write outstream "123\n") + (:write outstream "456\n")) + # Cast to string to enable comparison + (assert (= "123\n456\n" (string (slurp "unique.txt"))) "File writing 4.2") + (os/rm "unique.txt")) + # ev/gather (assert (deep= @[1 2 3] (ev/gather 1 2 3)) "ev/gather 1") @@ -135,6 +151,38 @@ (:close s)) +# Test localname and peername +(repeat 20 + + (defn check-matching-names [stream] + (def [my-ip my-port] (net/localname stream)) + (def [remote-ip remote-port] (net/peername stream)) + (def msg (string my-ip " " my-port " " remote-ip " " remote-port)) + (def buf @"") + (ev/gather + (net/write stream msg) + (net/read stream 1024 buf)) + (def comparison (string/split " " buf)) + (assert (and (= my-ip (get comparison 2)) + (= (string my-port) (get comparison 3)) + (= remote-ip (get comparison 0)) + (= (string remote-port) (get comparison 1))) + "localname should match peername")) + + # Test on both server and client + (defn names-handler + [stream] + (defer (:close stream) + (check-matching-names stream))) + (with [s (net/server "127.0.0.1" "8000" names-handler)] + (defn test-names [] + (with [conn (net/connect "127.0.0.1" "8000")] + (check-matching-names conn))) + (test-names) + (test-names)) + + (gccollect)) + # Create pipe (var pipe-counter 0) @@ -163,4 +211,46 @@ (assert (os/execute [janet "-e" `(+ 1 2 3)`] :xp) "os/execute self") +# Test some channel + +(def c1 (ev/chan)) +(def c2 (ev/chan)) +(def arr @[]) +(ev/spawn + (while (def x (ev/take c1)) + (array/push arr x)) + (ev/chan-close c2)) +(for i 0 1000 + (ev/give c1 i)) +(ev/chan-close c1) +(ev/take c2) +(assert (= (slice arr) (slice (range 1000))) "ev/chan-close 1") + +(def c1 (ev/chan)) +(def c2 (ev/chan)) +(def arr @[]) +(ev/spawn + (while (def x (ev/take c1)) + (array/push arr x)) + (ev/sleep 0.1) + (ev/chan-close c2)) +(for i 0 100 + (ev/give c1 i)) +(ev/chan-close c1) +(ev/select c2) +(assert (= (slice arr) (slice (range 100))) "ev/chan-close 2") + +(def c1 (ev/chan)) +(def c2 (ev/chan)) +(def arr @[]) +(ev/spawn + (while (def x (ev/take c1)) + (array/push arr x)) + (ev/chan-close c2)) +(for i 0 100 + (ev/give c1 i)) +(ev/chan-close c1) +(ev/rselect c2) +(assert (= (slice arr) (slice (range 100))) "ev/chan-close 3") + (end-suite) diff --git a/test/suite0010.janet b/test/suite0010.janet index 3b031906..8ba64f1c 100644 --- a/test/suite0010.janet +++ b/test/suite0010.janet @@ -1,4 +1,4 @@ -#- Copyright (c) 2020 Calvin Rose & contributors +# Copyright (c) 2021 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to @@ -161,10 +161,14 @@ ([err] :caught)))) "regression #638")) + # Struct prototypes (def x (struct/with-proto {1 2 3 4} 5 6)) (def y (-> x marshal unmarshal)) (def z {1 2 3 4}) +(assert (= 2 (get x 1)) "struct get proto value 1") +(assert (= 4 (get x 3)) "struct get proto value 2") +(assert (= 6 (get x 5)) "struct get proto value 3") (assert (= x y) "struct proto marshal equality 1") (assert (= (getproto x) (getproto y)) "struct proto marshal equality 2") (assert (= 0 (cmp x y)) "struct proto comparison 1") @@ -179,4 +183,13 @@ (assert (deep-not= x z) "struct proto deep= 2") (assert (deep-not= y z) "struct proto deep= 3") +# Issue #751 +(def t {:side false}) +(assert (nil? (get-in t [:side :note])) "get-in with false value") +(assert (= (get-in t [:side :note] "dflt") "dflt") + "get-in with false value and default") + +(assert (= (math/gcd 462 1071) 21) "math/gcd 1") +(assert (= (math/lcm 462 1071) 23562) "math/lcm 1") + (end-suite) diff --git a/tools/jpm.bat b/tools/jpm.bat deleted file mode 100644 index 075b0220..00000000 --- a/tools/jpm.bat +++ /dev/null @@ -1,4 +0,0 @@ -@echo off -@rem Wrapper around jpm - -janet "%~dp0\jpm.janet" %* diff --git a/tools/msi/LICENSE.rtf b/tools/msi/LICENSE.rtf index e45ced57..f9bfc457 100644 Binary files a/tools/msi/LICENSE.rtf and b/tools/msi/LICENSE.rtf differ diff --git a/tools/msi/janet.wxs b/tools/msi/janet.wxs index 80a0b7e4..bbf62066 100644 --- a/tools/msi/janet.wxs +++ b/tools/msi/janet.wxs @@ -115,12 +115,6 @@ - - - - - - diff --git a/tools/patch-jpm.janet b/tools/patch-jpm.janet deleted file mode 100644 index b0f812f3..00000000 --- a/tools/patch-jpm.janet +++ /dev/null @@ -1,33 +0,0 @@ -# Patch jpm to have the correct paths for the current install. -# usage: janet patch-jpm.janet output --libdir=/usr/local/lib/x64-linux/ --binpath - -(def- argpeg - (peg/compile - '(* "--" '(to "=") "=" '(any 1)))) - -(def- args (tuple/slice (dyn :args) 3)) -(def- len (length args)) -(var i :private 0) - -(def install-paths @{}) - -# Get flags -(each a args - (if-let [m (peg/match argpeg a)] - (let [[key value] m] - (put install-paths (keyword key) value)))) - -(def- replace-peg - (peg/compile - ~(% (* '(to "###START###") - (constant ,(string/format "# Inserted by tools/patch-jpm.janet\n(defn- install-paths [] %j)" install-paths)) - (thru "###END###") - '(any 1))))) - -(def source (slurp ((dyn :args) 1))) -(def newsource (0 (peg/match replace-peg source))) - -(spit ((dyn :args) 2) newsource) - -(unless (= :windows (os/which)) - (os/shell (string `chmod +x "` ((dyn :args) 2) `"`))) diff --git a/tools/symcharsgen.c b/tools/symcharsgen.c index 4e3c7965..5d86c25b 100644 --- a/tools/symcharsgen.c +++ b/tools/symcharsgen.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2020 Calvin Rose +* Copyright (c) 2021 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to