From 1e290fbadb02916143b7441ed2230637e74c5773 Mon Sep 17 00:00:00 2001 From: Matthew Paras <34500476+mattwparas@users.noreply.github.com> Date: Sun, 29 Oct 2023 22:22:05 -0700 Subject: [PATCH] Proof of concept for end to end super instructions (#77) * work in progress, end to end pipeline with super instruction generation and vm support added * dedicated op codes for cons and list * adjust to go back to once cell * clean up * lazy dylibs * more clean up * adjust threading macro, add optimization pass * rename stdlib to scm * fixing panics * checkpoint before nuking rust contract impl * checkpoint, contracts have been nuked, structs overhauled * big changes, mutable data structures, cycle stuff * fixing lots of bugs * check point * move files to built ins * more clean up * remove dbg * fix module suffix issue * clean up logging * very close * new printing method * fix typo * clean up * add test case * fix typo in test * another typo in the test * format * expander respects local bindings * more tests * fix iterators * more tests * more tests * more testing * enable env logger --- Cargo.lock | 127 +- Cargo.toml | 3 +- README.md | 4 +- cogs/clos/clos.scm | 177 +- cogs/collections/dll.scm | 87 +- cogs/collections/iterators.scm | 33 + cogs/collections/mhash.scm | 22 + cogs/collections/mpair.scm | 27 + cogs/collections/tests.scm | 72 + cogs/contracts/contract-test.scm | 37 +- cogs/contracts/contract.scm | 294 +-- cogs/coop/threads.scm | 58 +- cogs/download.scm | 8 +- cogs/dump.scm | 2263 ----------------- cogs/dump.txt | 338 +++ cogs/foo.scm | 10 +- cogs/fs/fs.scm | 21 +- cogs/installer/package.scm | 91 +- cogs/other.scm | 4 +- cogs/r5rs.scm | 78 +- cogs/r7rs.scm | 32 + cogs/require.scm | 2 + cogs/slack/main.scm | 19 +- cogs/slack/slack.scm | 128 +- cogs/sorting/tests.scm | 10 +- cogs/test-runner.scm | 49 +- cogs/threads/test-threads.scm | 2 + cogs/transducers/transducers.scm | 28 +- core/contracts.rkt | 84 +- crates/steel-core/Cargo.toml | 9 +- crates/steel-core/benches/my_benchmark.rs | 263 +- crates/steel-core/build.rs | 40 +- crates/steel-core/output.txt | 6 + crates/steel-core/src/compiler/code_gen.rs | 19 +- crates/steel-core/src/compiler/compiler.rs | 105 +- crates/steel-core/src/compiler/constants.rs | 10 + crates/steel-core/src/compiler/modules.rs | 454 ++-- .../src/compiler/passes/analysis.rs | 897 +++++-- crates/steel-core/src/compiler/passes/mod.rs | 10 +- crates/steel-core/src/compiler/program.rs | 191 +- crates/steel-core/src/conversions.rs | 80 +- crates/steel-core/src/gc.rs | 18 +- crates/steel-core/src/lib.rs | 3 + crates/steel-core/src/parser/ast.rs | 187 +- .../steel-core/src/parser/expand_visitor.rs | 194 +- crates/steel-core/src/parser/expander.rs | 21 +- crates/steel-core/src/parser/interner.rs | 40 +- crates/steel-core/src/parser/kernel.rs | 147 +- crates/steel-core/src/parser/rename_idents.rs | 6 +- .../steel-core/src/parser/replace_idents.rs | 24 +- .../steel-core/src/parser/tryfrom_visitor.rs | 98 +- crates/steel-core/src/primitives.rs | 61 +- crates/steel-core/src/primitives/contracts.rs | 182 +- crates/steel-core/src/primitives/fs.rs | 291 +-- crates/steel-core/src/primitives/hashmaps.rs | 159 +- crates/steel-core/src/primitives/hashsets.rs | 151 +- crates/steel-core/src/primitives/lists.rs | 25 +- crates/steel-core/src/primitives/meta_ops.rs | 22 +- crates/steel-core/src/primitives/strings.rs | 31 +- .../steel-core/src/primitives/transducers.rs | 6 +- crates/steel-core/src/primitives/vectors.rs | 223 +- crates/steel-core/src/rvals.rs | 411 ++- crates/steel-core/src/rvals/cycles.rs | 1505 ++++++++++- crates/steel-core/src/scheme/contract.rkt | 64 +- crates/steel-core/src/scheme/kernel.scm | 59 +- .../src/scheme/modules/contracts.scm | 515 ++++ .../src/scheme/modules/iterators.scm | 130 + .../steel-core/src/scheme/modules/mvector.scm | 115 + .../src/scheme/modules/parameters.scm | 133 + .../steel-core/src/scheme/modules/result.scm | 14 +- crates/steel-core/src/scheme/print.scm | 193 ++ crates/steel-core/src/scheme/stdlib.rkt | 673 ----- crates/steel-core/src/scheme/stdlib.scm | 715 ++++++ crates/steel-core/src/stdlib.rs | 8 +- crates/steel-core/src/steel_vm/builtin.rs | 59 +- crates/steel-core/src/steel_vm/contracts.rs | 913 ++++--- crates/steel-core/src/steel_vm/dylib.rs | 161 +- crates/steel-core/src/steel_vm/engine.rs | 390 ++- crates/steel-core/src/steel_vm/ffi.rs | 6 +- crates/steel-core/src/steel_vm/meta.rs | 17 +- crates/steel-core/src/steel_vm/primitives.rs | 430 +++- crates/steel-core/src/steel_vm/register_fn.rs | 16 +- crates/steel-core/src/steel_vm/test_util.rs | 9 +- crates/steel-core/src/steel_vm/transducers.rs | 32 +- crates/steel-core/src/steel_vm/vm.rs | 594 ++++- crates/steel-core/src/steel_vm/vm/threads.rs | 2 +- crates/steel-core/src/tests/mod.rs | 2 + crates/steel-core/src/tests/success/dfs.scm | 113 +- .../steel-core/src/tests/success/ncsubseq.scm | 27 + .../src/tests/success/tree_traversal.scm | 54 + crates/steel-core/src/values/closed.rs | 539 +++- crates/steel-core/src/values/contracts.rs | 955 ++++--- crates/steel-core/src/values/functions.rs | 31 +- crates/steel-core/src/values/json_vals.rs | 17 +- crates/steel-core/src/values/lists.rs | 93 + crates/steel-core/src/values/mod.rs | 5 + crates/steel-core/src/values/structs.rs | 251 +- crates/steel-gen/src/lib.rs | 238 +- crates/steel-gen/src/opcode.rs | 255 +- crates/steel-repl/src/repl.rs | 24 +- crates/steel-sys-info/sys-info.scm | 10 +- src/lib.rs | 22 +- src/main.rs | 14 +- 103 files changed, 10552 insertions(+), 7343 deletions(-) create mode 100644 cogs/collections/iterators.scm create mode 100644 cogs/collections/mhash.scm create mode 100644 cogs/collections/mpair.scm create mode 100644 cogs/collections/tests.scm delete mode 100644 cogs/dump.scm create mode 100644 cogs/dump.txt create mode 100644 cogs/require.scm create mode 100644 crates/steel-core/output.txt create mode 100644 crates/steel-core/src/scheme/modules/contracts.scm create mode 100644 crates/steel-core/src/scheme/modules/iterators.scm create mode 100644 crates/steel-core/src/scheme/modules/mvector.scm create mode 100644 crates/steel-core/src/scheme/modules/parameters.scm create mode 100644 crates/steel-core/src/scheme/print.scm delete mode 100644 crates/steel-core/src/scheme/stdlib.rkt create mode 100644 crates/steel-core/src/scheme/stdlib.scm create mode 100644 crates/steel-core/src/tests/success/ncsubseq.scm create mode 100644 crates/steel-core/src/tests/success/tree_traversal.scm create mode 100644 crates/steel-core/src/values/lists.rs diff --git a/Cargo.lock b/Cargo.lock index 1e4be11bd..e43cbd900 100644 --- a/Cargo.lock +++ b/Cargo.lock @@ -169,7 +169,7 @@ checksum = "4e246206a63c9830e118d12c894f56a82033da1a2361f5544deeee3df85c99d9" dependencies = [ "async-trait", "axum-core", - "bitflags", + "bitflags 1.3.2", "bytes", "futures-util", "http", @@ -274,6 +274,12 @@ version = "1.3.2" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "bef38d45163c2f1dde094a7dfd33ccf595c92905c8f8f4fdc18d06fb1037718a" +[[package]] +name = "bitflags" +version = "2.4.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "327762f6e5a765692301e5bb513e0d9fef63be86bbc14528052b1cd3e6f03e07" + [[package]] name = "bitmaps" version = "2.1.0" @@ -421,27 +427,15 @@ dependencies = [ "half", ] -[[package]] -name = "clap" -version = "3.2.23" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "71655c45cb9845d3270c9d6df84ebe72b4dad3c2ba3f7023ad47c144e4e473a5" -dependencies = [ - "bitflags", - "clap_lex 0.2.4", - "indexmap", - "textwrap", -] - [[package]] name = "clap" version = "4.1.4" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "f13b9c79b5d1dd500d20ef541215a6423c75829ef43117e1b4d17fd8af0b5d76" dependencies = [ - "bitflags", + "bitflags 1.3.2", "clap_derive", - "clap_lex 0.3.1", + "clap_lex", "is-terminal", "once_cell", "strsim", @@ -461,15 +455,6 @@ dependencies = [ "syn 1.0.107", ] -[[package]] -name = "clap_lex" -version = "0.2.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2850f2f5a82cbf437dd5af4d49848fbdfc27c157c3d010345776f952765261c5" -dependencies = [ - "os_str_bytes", -] - [[package]] name = "clap_lex" version = "0.3.1" @@ -693,19 +678,19 @@ dependencies = [ [[package]] name = "criterion" -version = "0.4.0" +version = "0.5.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e7c76e09c1aae2bc52b3d2f29e13c6572553b30c4aa1b8a49fd70de6412654cb" +checksum = "f2b12d017a929603d80db1831cd3a24082f8137ce19c69e6447f54f5fc8d692f" dependencies = [ "anes", - "atty", "cast", "ciborium", - "clap 3.2.23", + "clap", "criterion-plot", + "is-terminal", "itertools", - "lazy_static", "num-traits", + "once_cell", "oorandom", "plotters", "rayon", @@ -800,7 +785,7 @@ version = "0.23.2" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "a2102ea4f781910f8a5b98dd061f4c2023f479ce7bb1236330099ceb5a93cf17" dependencies = [ - "bitflags", + "bitflags 1.3.2", "crossterm_winapi", "libc", "mio", @@ -1010,6 +995,16 @@ dependencies = [ "winapi", ] +[[package]] +name = "errno" +version = "0.3.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "ac3e13f66a2f95e32a39eaa81f6b95d42878ca0e1db0c7543723dfe12557e860" +dependencies = [ + "libc", + "windows-sys 0.48.0", +] + [[package]] name = "errno-dragonfly" version = "0.1.2" @@ -1066,7 +1061,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "8ef1a30ae415c3a691a4f41afddc2dbcd6d70baf338368d85ebc1e8ed92cedb9" dependencies = [ "cfg-if 1.0.0", - "rustix", + "rustix 0.36.8", "windows-sys 0.45.0", ] @@ -1475,9 +1470,9 @@ dependencies = [ [[package]] name = "im-lists" -version = "0.4.0" +version = "0.5.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "08f93ebe9d5265409edc0b5c2ebd96bf7dcd4125c1626bff0ece34b9300e490a" +checksum = "dbe1ea6399f751563e6f5d88bff90a5c7418f8e7abbdd34708412be793a73949" [[package]] name = "im-rc" @@ -1539,14 +1534,13 @@ checksum = "30e22bd8629359895450b59ea7a776c850561b96a3b1d31321c1949d9e6c9146" [[package]] name = "is-terminal" -version = "0.4.3" +version = "0.4.9" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "22e18b0a45d56fe973d6db23972bf5bc46f988a4a2385deac9cc29572f09daef" +checksum = "cb0889898416213fab133e1d33a0e5858a48177452750691bde3666d0fdbaf8b" dependencies = [ "hermit-abi 0.3.0", - "io-lifetimes", - "rustix", - "windows-sys 0.45.0", + "rustix 0.38.13", + "windows-sys 0.48.0", ] [[package]] @@ -1644,6 +1638,12 @@ version = "0.1.4" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "f051f77a7c8e6957c0696eac88f26b0117e54f52d3fc682ab19397a8812846a4" +[[package]] +name = "linux-raw-sys" +version = "0.4.10" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "da2479e8c062e40bf0066ffa0bc823de0a9368974af99c9f6df941d2c231e03f" + [[package]] name = "lock_api" version = "0.4.9" @@ -1800,7 +1800,7 @@ version = "0.24.3" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "fa52e972a9a719cecb6864fb88568781eb706bac2cd1d4f04a648542dbf78069" dependencies = [ - "bitflags", + "bitflags 1.3.2", "cfg-if 1.0.0", "libc", "memoffset 0.6.5", @@ -1813,7 +1813,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "f346ff70e7dbfd675fe90590b92d59ef2de15a8779ae305ebcbfd3f0caf59be4" dependencies = [ "autocfg", - "bitflags", + "bitflags 1.3.2", "cfg-if 1.0.0", "libc", "memoffset 0.6.5", @@ -1971,7 +1971,7 @@ version = "0.10.45" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "b102428fd03bc5edf97f62620f7298614c45cedf287c271e7ed450bbaf83f2e1" dependencies = [ - "bitflags", + "bitflags 1.3.2", "cfg-if 1.0.0", "foreign-types", "libc", @@ -2247,7 +2247,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "806ee80c2a03dbe1a9fb9534f8d19e4c0546b790cde8fd1fea9d6390644cb0be" dependencies = [ "anyhow", - "bitflags", + "bitflags 1.3.2", "downcast-rs", "filedescriptor", "lazy_static", @@ -2318,7 +2318,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "29f1b898011ce9595050a68e60f90bad083ff2987a695a42357134c8381fba70" dependencies = [ "bit-set", - "bitflags", + "bitflags 1.3.2", "byteorder", "lazy_static", "num-traits", @@ -2455,7 +2455,7 @@ version = "0.2.16" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "fb5a58c1855b4b6819d59012155603f0b22ad30cad752600aadfcb695265519a" dependencies = [ - "bitflags", + "bitflags 1.3.2", ] [[package]] @@ -2504,7 +2504,7 @@ version = "2.2.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "877e54ea2adcd70d80e9179344c97f93ef0dffd6b03e1f4529e6e83ab2fa9ae0" dependencies = [ - "bitflags", + "bitflags 1.3.2", "libc", "mach", "winapi", @@ -2586,7 +2586,7 @@ version = "0.28.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "01e213bc3ecb39ac32e81e51ebe31fd888a940515173e3a18a35f8c6e896422a" dependencies = [ - "bitflags", + "bitflags 1.3.2", "fallible-iterator", "fallible-streaming-iterator", "hashlink", @@ -2615,14 +2615,27 @@ version = "0.36.8" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "f43abb88211988493c1abb44a70efa56ff0ce98f233b7b276146f1f3f7ba9644" dependencies = [ - "bitflags", - "errno", + "bitflags 1.3.2", + "errno 0.2.8", "io-lifetimes", "libc", - "linux-raw-sys", + "linux-raw-sys 0.1.4", "windows-sys 0.45.0", ] +[[package]] +name = "rustix" +version = "0.38.13" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d7db8590df6dfcd144d22afd1b83b36c21a18d7cbc1dc4bb5295a8712e9eb662" +dependencies = [ + "bitflags 2.4.1", + "errno 0.3.5", + "libc", + "linux-raw-sys 0.4.10", + "windows-sys 0.48.0", +] + [[package]] name = "rustls" version = "0.20.8" @@ -2680,7 +2693,7 @@ version = "10.1.1" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "c1e83c32c3f3c33b08496e0d1df9ea8c64d39adb8eb36a1ebb1440c690697aef" dependencies = [ - "bitflags", + "bitflags 1.3.2", "cfg-if 1.0.0", "clipboard-win", "dirs-next", @@ -2760,7 +2773,7 @@ version = "2.8.2" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "a332be01508d814fed64bf28f798a146d73792121129962fdf335bb3c49a4254" dependencies = [ - "bitflags", + "bitflags 1.3.2", "core-foundation", "core-foundation-sys", "libc", @@ -3139,7 +3152,7 @@ dependencies = [ name = "steel-interpreter" version = "0.5.0" dependencies = [ - "clap 4.1.4", + "clap", "env_logger", "log", "once_cell", @@ -3356,7 +3369,7 @@ checksum = "9509a978a10fcbace4991deae486ae10885e0f4c2c465123e08c9714a90648fa" dependencies = [ "anyhow", "base64 0.21.0", - "bitflags", + "bitflags 1.3.2", "filedescriptor", "finl_unicode", "fixedbitset", @@ -3389,12 +3402,6 @@ dependencies = [ "winapi", ] -[[package]] -name = "textwrap" -version = "0.16.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "222a222a5bfe1bba4a77b45ec488a741b3cb8872e5e499451fd7d0129c9c7c3d" - [[package]] name = "thiserror" version = "1.0.38" @@ -3551,7 +3558,7 @@ version = "0.3.5" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "f873044bf02dd1e8239e9c1293ea39dad76dc594ec16185d0a1bf31d8dc8d858" dependencies = [ - "bitflags", + "bitflags 1.3.2", "bytes", "futures-core", "futures-util", diff --git a/Cargo.toml b/Cargo.toml index a81ebf66b..b4d976edf 100644 --- a/Cargo.toml +++ b/Cargo.toml @@ -41,5 +41,6 @@ members = [ ] [profile.release] -debug = false +# debug = false +debug = true lto = true diff --git a/README.md b/README.md index 322ef9e94..b771c916b 100644 --- a/README.md +++ b/README.md @@ -41,10 +41,10 @@ If you would like to install and use packages, please set the `STEEL_HOME` envir ## About -`Steel` is an embeddable scheme interpreter, with a standalone cli included as well. Inspired largely by Racket and Clojure, the language seeks to be ergonomic scheme variant helpful for embedding in applications, or to be used on its own with high performance functions implemented in Rust. The language implementation itself contains a fairly powerful macro system based on the `syntax-rules` style and a bytecode virtual machine. At the moment, it is not explicitly compliant with any individual scheme specification. +`Steel` is an embeddable scheme interpreter, with a standalone cli included as well. Inspired largely by Racket, the language seeks to be ergonomic scheme variant helpful for embedding in applications, or to be used on its own with high performance functions implemented in Rust. The language implementation itself contains a fairly powerful macro system based on the `syntax-rules` style and a bytecode virtual machine. At the moment, it is not explicitly compliant with any individual scheme specification. > **Warning** -> The API is very unstable with no guarantees, and may change at any time while pre 1.0. There are undoubtedly bugs that exist, and I wouldn't consider Steel to be production ready. That being said, I do use it as a daily driver for many scripting tasks myself. +> The API is unstable with no guarantees, and may change at any time while pre 1.0. There are undoubtedly bugs that exist, and any major bug reports will be addressed quickly. That being said, I do use it as a daily driver for many scripting tasks myself. ## Features diff --git a/cogs/clos/clos.scm b/cogs/clos/clos.scm index b354a6633..040ddf74d 100644 --- a/cogs/clos/clos.scm +++ b/cogs/clos/clos.scm @@ -1,13 +1,11 @@ ;; ---------------------------- Class Object definitions -------------------------------------------- -(struct Class-Object (name parents interfaces fields methods)) +(struct Class-Object (name parents interfaces fields methods) #:mutable #:transparent) (struct Interface (name methods)) -(struct Class-Instance (class-object fields)) - +(struct Class-Instance (class-object fields) #:transparent) (define (list-subset? left right) - (hashset-subset? (list->hashset left) - (list->hashset right))) + (hashset-subset? (list->hashset left) (list->hashset right))) ;; Classes contain: ;; A name, which is required to be a symbol (string should also work, but for now a symbol simplifies this) @@ -21,67 +19,52 @@ (->/c symbol? (listof Class-Object?) (listof Interface?) (listof symbol?) hash? Class-Object?) (unless (list-subset? ;; Collect the list of required methods for the given interfaces - (transduce interfaces - (flat-mapping Interface-methods) - (into-list)) + (transduce interfaces (flat-mapping Interface-methods) (into-list)) ;; Extract the methods that have been defined concretely on this class at construction (hash-keys->list methods)) (error! "Not all required methods are implemented for the given interfaces")) - (Class-Object - name - parents - interfaces - ;; Explicitly go collect the fields to flatten into this class given the - ;; class hierarchy - (combine-local-and-parent-fields fields parents) - methods)) - -(define (Make-Class - name - #:fields (fields '()) - #:methods (methods '()) - #:parents (parents '()) - #:interfaces (interfaces '())) - (Class name parents interfaces fields methods)) - + (Class-Object name + parents + interfaces + ;; Explicitly go collect the fields to flatten into this class given the + ;; class hierarchy + (combine-local-and-parent-fields fields parents) + methods)) + +(define (Make-Class name + #:fields (fields '()) + #:methods (methods '()) + #:parents (parents '()) + #:interfaces (interfaces '())) + (Class name parents interfaces fields methods)) (define (contains-duplicates? lst) - (not - (equal? (hashset-length (apply hashset lst)) - (length lst)))) + (not (equal? (hashset-length (apply hashset lst)) (length lst)))) ;; Flatten the incoming list -(define (flatten lst) (transduce lst (flattening) (into-list))) +(define (flatten lst) + (transduce lst (flattening) (into-list))) (define (collect-fields list-of-class-objects) - (transduce list-of-class-objects - (flat-mapping Class-Object-fields) - (into-list))) + (transduce list-of-class-objects (flat-mapping Class-Object-fields) (into-list))) (define (combine-local-and-parent-fields local-fields list-of-class-objects) - (let ((appended (append - local-fields - (collect-fields list-of-class-objects)))) - (if (contains-duplicates? appended) - (error! "Class field is unresolvable") - appended))) - - + (let ([appended (append local-fields (collect-fields list-of-class-objects))]) + (if (contains-duplicates? appended) (error! "Class field is unresolvable") appended))) ;; ----------------------------------------------------------------------------------------------------- - ;; Add a method to a class ;; This can also occur in the root definition of the object in the hash, but the contract ;; won't be checked there at the moment TODO (define/contract (define-method class-object name method) (->/c Class-Object? symbol? function? any/c) - (let ((methods (Class-Object-methods class-object))) + (let ([methods (Class-Object-methods class-object)]) (set-Class-Object-methods! class-object (hash-insert methods name method)))) (define (resolve-parent-method class-object name) - (let ((possible-methods (map (lambda (x) (get-method x name)) (Class-Object-parents class-object)))) + (let ([possible-methods (map (lambda (x) (get-method x name)) (Class-Object-parents class-object))]) (if (equal? 1 (length possible-methods)) (car possible-methods) (error! "Unable to resolve the method on the class instance")))) @@ -92,9 +75,7 @@ ;; which method we intended to call. (define/contract (get-method class-object name) (->/c Class-Object? symbol? function?) - (let ((local-method (-> class-object - (Class-Object-methods) - (hash-try-get name)))) + (let ([local-method (-> class-object (Class-Object-methods) (hash-try-get name))]) ;; If _this_ class object contains the method, then we return this method ;; This way we always select the correct method in the class hierarchy (if local-method @@ -113,17 +94,21 @@ (define list-length (length lst)) (define (loop lst idx) (cond - [(= idx list-length) => (error! "Value not a member of the list")] - [(equal? value (list-ref lst idx)) => idx] - [else => (loop lst (+ idx 1))])) + [(= idx list-length) + => + (error! "Value not a member of the list")] + [(equal? value (list-ref lst idx)) + => + idx] + [else + => + (loop lst (+ idx 1))])) (loop lst 0)) ;; Map the given field name to an index in the class' slot (define/contract (%get-slot-idx class-object field-name) (->/c Class-Object? symbol? integer?) - (-> class-object - (Class-Object-fields) - (position? field-name))) + (-> class-object (Class-Object-fields) (position? field-name))) ;; This returns whatever value is found in the slot ;; This _could_ be any value. TODO: find a way to bind a contract to a slot @@ -136,24 +121,21 @@ ;; TODO: make the contract be dependent to have the result match the value's contract (define/contract (set-slot! class-instance field-name value) (->/c Class-Instance? symbol? any/c any/c) - (vector-set! - (Class-Instance-fields class-instance) - ;; Get the slot index -> maps the field name to the index in the vector - (%get-slot-idx (Class-Instance-class-object class-instance) field-name) - value)) + (vector-set! (Class-Instance-fields class-instance) + ;; Get the slot index -> maps the field name to the index in the vector + (%get-slot-idx (Class-Instance-class-object class-instance) field-name) + value)) ;; Instances should be represented in memory (for now) just as tagged vectors ;; Each of the fields will be zero'd out (define/contract (%allocate-instance class-object) (->/c Class-Object? Class-Instance?) ;; We can just use a normal vector here, not a mutable vector - (Class-Instance - ;; Reference to the class object here - class-object - ;; Fields as a mutable vector - ;; Name resolution should be done via %get-slot method - (apply mutable-vector (map (lambda (x) void) - (Class-Object-fields class-object))))) + ;; Reference to the class object here + (Class-Instance class-object + ;; Fields as a mutable vector + ;; Name resolution should be done via %get-slot method + (apply mutable-vector (map (lambda (x) void) (Class-Object-fields class-object))))) ;; Get the method on the class object denoted by the method name ;; and call it given the arguments here @@ -182,32 +164,28 @@ ;; ------------------- Examples -------------------------- ;; Base object for everything in the class hierarchy -(define Object (Class 'Object - '() - '() - '() - (hash 'println - (lambda (self) - (displayln (-> "#<" - (string-append - (symbol->string (class-instance-name self))) - (string-append ">"))))))) +(define Object + (Class 'Object + '() + '() + '() + (hash 'println + (lambda (self) + (displayln (-> "#<" + (string-append (symbol->string (class-instance-name self))) + (string-append ">"))))))) ;; Define the class object for Animal ;; Is a child of the Object base class -(define Animal (Class 'Animal - (list Object) - '() - '(name color weight) - (hash - 'get-weight (lambda (self) (get-slot self 'weight))))) +(define Animal + (Class 'Animal + (list Object) + '() + '(name color weight) + (hash 'get-weight (lambda (self) (get-slot self 'weight))))) ;; Dog inherits from Animal, adds on the 'good-boy? field -(define Dog (Class 'Dog - (list Animal) - '() - '(good-boy?) - (hash))) +(define Dog (Class 'Dog (list Animal) '() '(good-boy?) (hash))) ;; TODO: Once keyword arguments are a thing, classes could be defined like so: ;; (define Dog (Class #:name 'Dog @@ -216,7 +194,6 @@ ;; #:fields '(good-boy?) ;; #:methods (hash))) - ;; Allocates a new instance of a dog - here all of the fields are default to # (define sherman (%allocate-instance Dog)) ;; Set the weight to be 25 -> this is set in the instance, and all fields are flattened on construction @@ -232,19 +209,15 @@ (define Stinky (Interface 'Stinky '(smelly icky))) -(define Worm (Class 'Worm - (list Dog) - (list Stinky) - '() - (hash - 'smelly (lambda (self) "Smelly!") - 'icky (lambda (self) "Icky!")))) - - -(define New-Worm (Make-Class 'Worm - #:parents (list Dog) - #:interfaces (list Stinky) - #:methods - (hash - 'smelly (lambda (self) "Smelly!") - 'icky (lambda (self) "Icky!")))) \ No newline at end of file +(define Worm + (Class 'Worm + (list Dog) + (list Stinky) + '() + (hash 'smelly (lambda (self) "Smelly!") 'icky (lambda (self) "Icky!")))) + +(define New-Worm + (Make-Class 'Worm + #:parents (list Dog) + #:interfaces (list Stinky) + #:methods (hash 'smelly (lambda (self) "Smelly!") 'icky (lambda (self) "Icky!")))) diff --git a/cogs/collections/dll.scm b/cogs/collections/dll.scm index c1ae385a9..9b9e46003 100644 --- a/cogs/collections/dll.scm +++ b/cogs/collections/dll.scm @@ -1,63 +1,72 @@ +(provide dllist + dllink + insert-between + insert-before + insert-after + insert-head + insert-tail + remove-link + dllist-elements + dllist-head + dllist-tail + dllink-content + dllink-prev + dllink-next) + (struct dllist (head tail) #:mutable #:transparent) (struct dllink (content prev next) #:mutable #:transparent) - + (define (insert-between dlist before after data) - ; Insert a fresh link containing DATA after existing link + ; Insert a fresh link containing DATA after existing link ; BEFORE if not nil and before existing link AFTER if not nil (define new-link (dllink data before after)) - (if before - (set-dllink-next! before new-link) - (set-dllist-head! dlist new-link)) - (if after - (set-dllink-prev! after new-link) - (set-dllist-tail! dlist new-link)) - new-link) - + (if before (set-dllink-next! before new-link) (set-dllist-head! dlist new-link)) + (if after (set-dllink-prev! after new-link) (set-dllist-tail! dlist new-link)) + new-link) + (define (insert-before dlist dlink data) ; Insert a fresh link containing DATA before existing link DLINK (insert-between dlist (dllink-prev dlink) dlink data)) - + (define (insert-after dlist dlink data) ; Insert a fresh link containing DATA after existing link DLINK (insert-between dlist dlink (dllink-next dlink) data)) - + (define (insert-head dlist data) ; Insert a fresh link containing DATA at the head of DLIST (insert-between dlist #f (dllist-head dlist) data)) - + (define (insert-tail dlist data) ; Insert a fresh link containing DATA at the tail of DLIST (insert-between dlist (dllist-tail dlist) #f data)) - + (define (remove-link dlist dlink) ; Remove link DLINK from DLIST and return its content - (let ((before (dllink-prev dlink)) - (after (dllink-next dlink))) - (if before - (set-dllink-next! before after) - (set-dllist-head! dlist after)) - (if after - (set-dllink-prev! after before) - (set-dllist-tail! dlist before)))) - + (let ([before (dllink-prev dlink)] [after (dllink-next dlink)]) + (if before (set-dllink-next! before after) (set-dllist-head! dlist after)) + (if after (set-dllink-prev! after before) (set-dllist-tail! dlist before)))) + (define (dllist-elements dlist) ; Returns the elements of DLIST as a list (define (extract-values dlink acc) - (if dlink - (extract-values (dllink-next dlink) (cons (dllink-content dlink) acc)) - acc)) + (if dlink (extract-values (dllink-next dlink) (cons (dllink-content dlink) acc)) acc)) (reverse (extract-values (dllist-head dlist) '()))) -(let ((dlist (dllist #f #f))) - (insert-head dlist 1) - (displayln dlist) - (insert-tail dlist 4) - (displayln dlist) - (insert-after dlist (dllist-head dlist) 2) - (displayln dlist) - (let* ((next-to-last (insert-before dlist (dllist-tail dlist) 3)) - (bad-link (insert-before dlist next-to-last 42))) - (remove-link dlist bad-link)) - (displayln dlist) - (displayln (dllist-elements dlist)) - (displayln dlist)) \ No newline at end of file +(define (run) + (let ([dlist (dllist #f #f)]) + (insert-head dlist 1) + (displayln dlist) + (insert-tail dlist 4) + (displayln dlist) + (insert-after dlist (dllist-head dlist) 2) + (displayln dlist) + (let* ([next-to-last (insert-before dlist (dllist-tail dlist) 3)] + [bad-link (insert-before dlist next-to-last 42)]) + (remove-link dlist bad-link)) + (displayln dlist) + (displayln (dllist-elements dlist)) + (displayln dlist))) + +(define (loop) + (run) + (loop)) diff --git a/cogs/collections/iterators.scm b/cogs/collections/iterators.scm new file mode 100644 index 000000000..4224ec690 --- /dev/null +++ b/cogs/collections/iterators.scm @@ -0,0 +1,33 @@ +(struct StreamIterator + (iter-instance stream-empty-function stream-first-function stream-next-function)) + +(struct IntoIterator (iter-object next-function) #:prop:procedure 1) + +;; Use the builtin "iterator finished" symbol +(define ITERATOR-FINISHED (load-from-module! %-builtin-module-steel/meta '#%iterator-finished)) + +(define (iter-finished? value) + (eq? value ITERATOR-FINISHED)) + +(define (iter-next into-iterator) + (into-iterator (IntoIterator-iter-object into-iterator))) + +;; Generically get the iterator +(define (into-iter obj) + ;; Check if this is a builtin type - if so, delegate to the underlying iterator + (define maybe-builtin-iterator (value->iterator obj)) + + (if maybe-builtin-iterator + (IntoIterator maybe-builtin-iterator iter-next!) + ((#%struct-property-ref obj '#:prop:into-iter) obj))) + +;; Call value for each thing +(define (iter-for-each iter func) + + (define next-value (iter-next iter)) + + (if (iter-finished? next-value) + void + (begin + (func next-value) + (iter-for-each iter func)))) diff --git a/cogs/collections/mhash.scm b/cogs/collections/mhash.scm new file mode 100644 index 000000000..0b92f2aa1 --- /dev/null +++ b/cogs/collections/mhash.scm @@ -0,0 +1,22 @@ +(require-builtin #%private/steel/mhash as private.) + +(struct mutable-hash (inner) #:mutable) + +(define (mhash-set! mhash key value) + (private.mhash-set! (mutable-hash-inner mhash) key value)) + +(define (mhash-ref mhash key) + (private.mhash-ref (mutable-hash-inner mhash) key)) + +(define (mhash) + (mutable-hash (private.mhash))) + +(define (loop) + (define my-hash (mhash)) + + (mhash-set! my-hash 'foo 'bar) + (mhash-set! my-hash 'bar 'foo) + + (mhash-set! my-hash 'baz my-hash) + + (loop)) diff --git a/cogs/collections/mpair.scm b/cogs/collections/mpair.scm new file mode 100644 index 000000000..58923cc16 --- /dev/null +++ b/cogs/collections/mpair.scm @@ -0,0 +1,27 @@ +;; TODO: Implement mutable pairs +(struct mcons (mcar mcdr) #:mutable) + +(define set-car! set-mcons-mcar!) +(define set-cdr! set-mcons-mcdr!) + +;; Mutable cons! +(define (mcons->list mutable-cons) + + (define (loop mutable-cons builder) + (if (not (mcons? (mcons-mcdr mutable-cons))) + + (cons (mcons-mcar mutable-cons) builder) + + (loop (mcons-mcdr mutable-cons) (cons (mcons-mcar mutable-cons) builder)))) + + (reverse (loop mutable-cons '()))) + +;; Can make a loop, and garbage collection solves it! +(define (loop) + + (define my-cons (mcons 10 (mcons 20 (mcons 30 void)))) + + ;; Make a cycle! + (set-car! my-cons my-cons) + + (loop)) diff --git a/cogs/collections/tests.scm b/cogs/collections/tests.scm new file mode 100644 index 000000000..dee70d2e6 --- /dev/null +++ b/cogs/collections/tests.scm @@ -0,0 +1,72 @@ +(require "dll.scm") +(require "steel/tests/unit-test.scm" + (for-syntax "steel/tests/unit-test.scm")) + +(define __dll-module 'dll-module) + +(provide __dll-module) + +(define (run) + (let ([dlist (dllist #f #f)]) + (insert-head dlist 1) + (displayln dlist) + (insert-tail dlist 4) + (displayln dlist) + (insert-after dlist (dllist-head dlist) 2) + (displayln dlist) + (let* ([next-to-last (insert-before dlist (dllist-tail dlist) 3)] + [bad-link (insert-before dlist next-to-last 42)]) + (remove-link dlist bad-link)) + (displayln dlist) + (displayln (dllist-elements dlist)) + (displayln dlist))) + +(test-module "dll-tests" + (check-equal? "creating dll with cycle works" + #true + (begin + (run) + #true))) + +;; Testing deep collections +(struct ConsCell (car cdr) #:mutable #:transparent) + +(define (build-list x) + (cond + [(equal? x 100000) void] + [else (ConsCell x (build-list (+ x 1)))])) + +(define (build-nested-list x y) + (cond + [(equal? x y) void] + [else (ConsCell x (build-nested-list (+ x 1) y))])) + +(define (build-hashmap-chain x) + (if (equal? x 100000) (hash 'a x) (hash 'a (build-hashmap-chain (+ x 1))))) + +(define (build-list-chain x) + (if (equal? x 10000) (list x) (list x (build-list-chain (+ x 1))))) + +; (define (test-depth) + +; (define (build-deep-hash x) +; (if (equal? x 100000) (hash x x) (hash (build-deep-hash (+ x 1)) x))) + +; (define m (build-deep-hash 0)) +; (define o (build-deep-hash 0)) + +; (equal? m o)) + +(test-module "deep recursive data structures" + ; (check-equal? "deep hash structures" #true (test-depth)) + (check-equal? "dropping deep list doesn't panic" + #true + (let ([foo (build-nested-list 0 100000)]) #true)) + (check-equal? "dropping deep built in list doesn't panic" + #true + (let ([foo (build-list-chain 0)]) + + #true)) + (check-equal? "dropping deep hashmap chain does't panic" + #true + (let ([foo (build-hashmap-chain 0)]) #true))) diff --git a/cogs/contracts/contract-test.scm b/cogs/contracts/contract-test.scm index 566f6e6a9..887804499 100644 --- a/cogs/contracts/contract-test.scm +++ b/cogs/contracts/contract-test.scm @@ -1,13 +1,15 @@ (require "steel/tests/unit-test.scm" - (for-syntax "steel/tests/unit-test.scm") - "contract.scm" - (for-syntax "contract.scm")) + (for-syntax "steel/tests/unit-test.scm")) (provide foo) -(define/c (foo x y) (->c even? odd? odd?) (+ x y)) +(define/contract (foo x y) + (->/c even? odd? odd?) + (+ x y)) -(define/c (simple-higher-order x func) (->c odd? (->c odd? even?) even?) (func x)) +(define/contract (simple-higher-order x func) + (->/c odd? (->/c odd? even?) even?) + (func x)) (define (any? x) (displayln "***** CHECKING ANY? *****") @@ -21,25 +23,20 @@ (number? x)) (define level1 - (bind-contract-to-function - (make-function-contract (make-function-contract (FlatContract number-checker? 'number-checker?))) - (lambda () - (lambda () - (displayln "@@@@@@@@@@ CALLING FUNCTION @@@@@@@@@@@") - 10)) - 'level1)) + (bind/c (make-function/c (make-function/c (FlatContract number-checker? 'number-checker?))) + (lambda () + (lambda () + (displayln "@@@@@@@@@@ CALLING FUNCTION @@@@@@@@@@@") + 10)) + 'level1)) (define level2 - (bind-contract-to-function - (make-function-contract (make-function-contract (FlatContract int-checker? 'int-checker))) - (lambda () (level1)) - 'level2)) + (bind/c (make-function/c (make-function/c (FlatContract int-checker? 'int-checker))) + (lambda () (level1)) + 'level2)) (define level3 - (bind-contract-to-function - (make-function-contract (make-function-contract (FlatContract any? 'any?))) - (lambda () (level2)) - 'level3)) + (bind/c (make-function/c (make-function/c (FlatContract any? 'any?))) (lambda () (level2)) 'level3)) (test-module "check-basic-contract-checking" diff --git a/cogs/contracts/contract.scm b/cogs/contracts/contract.scm index a429b4177..84d1c4f0c 100644 --- a/cogs/contracts/contract.scm +++ b/cogs/contracts/contract.scm @@ -1,5 +1,3 @@ -; (require "../logging/log.scm") - (provide make-function-contract make-contract bind-contract-to-function @@ -113,45 +111,6 @@ (define (apply-contracted-function contracted-function arguments span) ; (displayln "Passed in span: " span) (define span (if span span '(0 0 0))) - - ; (displayln "Applying contracted function") - ; (displayln (ContractedFunction-name contracted-function)) - ; (displayln arguments) - ; (displayln "Parents:") - ; (displayln (FunctionContract-parents (ContractedFunction-contract contracted-function))) - - ; (displayln contracted-function) - - ; (transduce - ; (FunctionContract-parents (ContractedFunction-contract contracted-function)) - ; (into-for-each - ; (lambda (x) - ; (log/info! "Checking parent contracts for: " x) - ; (log/info! "Contracted Function Overall: " contracted-function) - ; (log/info! "Contracted function: " (ContractedFunction-function contracted-function)) - ; (apply-function-contract - ; x - ; (ContractedFunction-name contracted-function) - ; (ContractedFunction-function contracted-function) - ; arguments - ; span)))) - - ; (let ((parent (FunctionContract-parent - ; (ContractedFunction-contract contracted-function)))) - ; (when parent - ; (apply-parents - ; parent - ; (ContractedFunction-name contracted-function) - ; (ContractedFunction-function contracted-function) - ; arguments - ; span))) - - ; (apply-parents (FunctionContract-parent - ; (ContractedFunction-contract contracted-function))) - - ; (log/warn! "apply-contracted-function: " contracted-function) - ; (log/info! span) - (apply-function-contract (ContractedFunction-contract contracted-function) (ContractedFunction-name contracted-function) (ContractedFunction-function contracted-function) @@ -163,10 +122,6 @@ ;; a new list of arguments, with any arguments wrapped in function contracts if they happen ;; to be higher order (define (verify-preconditions self-contract arguments name span) - ; (displayln arguments) - - ; (log/warn! "Contract: " self-contract) - (unless (equal? (length arguments) (length (FunctionContract-pre-conditions self-contract))) (error-with-span span "Arity mismatch, function expected " @@ -185,13 +140,8 @@ (cond [(FlatContract? contract) => - ; (displayln "Applying flat contract in pre condition") - ; (displayln x) - ; (displayln arg) (let ([result (apply-flat-contract contract arg)]) - ; (displayln result) - ; (displayln (FunctionContract-contract-attachment-location self-contract)) (if (ContractViolation? result) (error-with-span span "This function call caused an error" @@ -207,7 +157,6 @@ arg))] [(FunctionContract? contract) => - ; (log/info! "Wrapping contract in precondition: " arg) (if (ContractedFunction? arg) (let ([pre-parent (ContractedFunction-contract arg)]) (let ([parent (new-FunctionContract @@ -230,53 +179,11 @@ (error! "Unexpected value in pre conditions: " contract)])))) (into-list))) -; (verify-preconditions -; (make-function-contract -; (FlatContract int? 'int?) -; (FlatContract int? 'int?) -; (FlatContract boolean? 'boolean?)) - -; '(10 20) -; 'test-function) - (define (apply-function-contract contract name function arguments span) - ; (displayln "--------------------- APPLY FUNCTION CONTRACT ------------------") - - ; (displayln contract) - ; (displayln name) - ; (displayln function) - ; (displayln arguments) - - ; (log/info! "Apply-function-contract: " contract) - ;; Check that each of the arguments abides by the (let ([validated-arguments (verify-preconditions contract arguments name span)]) - ; (displayln "Calling apply - Applying function") - ; (displayln function) - ; (displayln validated-arguments) - ; (displayln "Calling the function itself!") - - ;; TODO: Catch the error from the result of apply here, and attach the correct span - - ; (with-handler (lambda (err) (mark-failed name) - ; (print-failure name) - ; (displayln err)) - ; (test name input expected)) - - ; (log/error! span) - - (let (; (output (apply function validated-arguments)) - - [output (with-handler (lambda (err) - ;; Adding these here forces the correct capturing - ;; for whatever reason, span => getting captured as a function - ;; try to investigate whats going on - ; (displayln function) - ; (displayln span) - ;; TODO: Check if this is the right error reporting? - (raise-error err) - ; (raise-error-with-span err span) - ) + + (let ([output (with-handler (lambda (err) (raise-error err)) (apply function validated-arguments))] [self-contract contract] @@ -286,10 +193,6 @@ (cond [(FlatContract? contract) => - ; (displayln "applying flat contract in post condition") - ; (displayln (FlatContract-name contract)) - ; (displayln contract) - ; (displayln function) (let ([result (apply-flat-contract contract output)]) (if (ContractViolation? result) @@ -315,52 +218,22 @@ (contract->string self-contract) (ContractViolation-error-message result) "blaming: " - blame-location)] - - ; [(equal? (ContractAttachmentLocation-type blame-location) 'DOMAIN) - ; => - ; (displayln "occurred in the domain position") - ; (error-with-span - ; span - ; "this function call resulted in an error - occurred in the range position of this contract: " - ; (contract->string self-contract) (ContractViolation-error-message result) "blaming: " - ; blame-location)] - - ; [(equal? (ContractAttachmentLocation-type blame-location) 'RANGE) - ; => - ; (error-with-span - ; span - ; "this function call resulted in an error - occurred in the range position of this contract: " - ; (contract->string self-contract) (ContractViolation-error-message result) "blaming: " - ; blame-location)] - - ; [else => (error! "Unexpected value found when assigning blame")] - )) + blame-location)])) output))] [(FunctionContract? contract) => - ; (log/info! "Wrapping contract in post condition " contract " " output) - ; (log/info! "Output contract " (get-contract-struct output)) (define original-function output) - ; (displayln contract) - ; (displayln output) - ; (if (ContractedFunction? (get-contract-struct output)) - (if (FunctionContract? (get-contract-struct output)) - ; (if (ContractedFunction? output) - ;; TODO: Come back to this and understand what the heck its doing ;; Figured it out -> its never actually a contracted function, because we're wrapping ;; it directly in a normal function type. (begin (define output (get-contract-struct output)) - ; (log/warn! "Getting here " output) (define pre-parent contract) - ; (log/warn! pre-parent) (define contract-attachment-location (ContractAttachmentLocation 'RANGE (ContractAttachmentLocation-name @@ -376,8 +249,6 @@ #:contract-attachment-location contract-attachment-location #:parents (cons parent (FunctionContract-parents pre-parent)))) - ; (log/info! "Parents found here: " (FunctionContract-parents fc)) - (bind-contract-to-function fc original-function name span)) (bind-contract-to-function contract output name span))] [else @@ -385,15 +256,7 @@ (error! "Unhandled value in post condition: " contract)])))) (define (bind-contract-to-function contract function name . span) - ; (displayln "Binding contract to function") (define post-condition (FunctionContract-post-condition contract)) - ; (displayln post-condition) - ; (displayln contract) - ; (displayln (FunctionContract-pre-conditions contract)) - ; (displayln (FunctionContract-post-condition contract)) - ; (displayln name) - - ; (displayln "Current function span: " (current-function-span)) (let ([updated-preconditions (transduce @@ -416,8 +279,6 @@ (into-list))] [updated-postcondition - ; (begin - ; (displayln post-condition) (cond [(FlatContract? post-condition) => @@ -425,11 +286,6 @@ [(FunctionContract? post-condition) => - ;; TODO: This log here causes an error -> probably to do with offset calculation - ;; during semantic analysis - ; (log/error! "Getting here!") - ; (log/error! post-condition) - (FunctionContract (FunctionContract-pre-conditions post-condition) (FunctionContract-post-condition post-condition) (ContractAttachmentLocation 'RANGE name) @@ -437,21 +293,9 @@ [else => - ; (displayln post-condition) - (error "Unexpected value found in bind-contract-to-function post condition: " post-condition)])]) - ; (displayln "Binding contract to function") - ; (displayln updated-preconditions) - ; (displayln updated-postcondition) - - ; (displayln (FunctionContract-parents contract)) - - ; (log/debug! "Preconditions here: " updated-preconditions) - - ; (log/error! contract) - (let ([contracted-function (ContractedFunction (FunctionContract updated-preconditions updated-postcondition @@ -466,18 +310,9 @@ function name)]) - ; (displayln "prev span: " (current-function-span)) - - ; (displayln "current span: " (current-function-span)) - - ; (log/info! "Parents: " (FunctionContract-parents contract)) - ; (log/info! "Pre conditions: " updated-preconditions) - (let ([resulting-lambda-function (lambda args - ; (define span (current-function-span)) - (apply-contracted-function contracted-function args @@ -491,59 +326,6 @@ (ContractedFunction-contract contracted-function)) resulting-lambda-function)))) -;; ; (define test-function -;; ; (bind-contract-to-function -;; ; (make-function-contract -;; ; (FlatContract int? 'int?) -;; ; (FlatContract int? 'int?) -;; ; (FlatContract boolean? 'boolean?)) -;; ; (lambda (x y) (equal? (+ x y) 10)) -;; ; 'test-function)) - -;; ; (test-function 5 5) -;; ; (test-function "applesauce" 5) - -;; ; (test-function "hello world" 10) - -;; ; (define foo -;; ; (lambda (x) -;; ; (if (= x 100) -;; ; x -;; ; (foo (+ x 1))))) - -;; ; (define bar -;; ; (lambda (x) -;; ; (if (= x 100) -;; ; x -;; ; (foo (+ x 1))))) - -;; ; ; (set! foo foo) - -;; ; (set! foo -;; ; (bind-contract-to-function -;; ; (make-function-contract -;; ; (FlatContract int? 'int?) -;; ; (FlatContract int? 'int?)) -;; ; foo -;; ; 'foo)) - -;; ; (set! bar -;; ; (bind-contract-to-function -;; ; (make-function-contract -;; ; (FlatContract int? 'int?) -;; ; (FlatContract int? 'int?)) -;; ; bar -;; ; 'bar)) - -; (define blagh -; (bind-contract-to-function -; (make-function-contract -; (make-function-contract (FlatContract even? 'even?) (FlatContract odd? 'odd?)) -; (FlatContract even? 'even?) -; (FlatContract even? 'even?)) -; (lambda (func y) (+ 1 (func y))) -; 'blagh)) - (define (make-contract contract name) (cond [(FlatContract? contract) contract] @@ -631,73 +413,3 @@ (syntax-rules () [(contract/out/test name contract) (%require-ident-spec name (bind-contract-to-function contract name 'name))])) - -; (define/c (blagh x) -; (->c string? string?) -; x) - -; (define/c (foo x y) -; (->c even? odd? odd?) -; (+ x y)) - -; (foo 11 11) - -;; ; (blagh (lambda (x) (+ x 2)) 2) - -; (define (any? x) (displayln "***** CHECKING ANY? *****") #true) - -; (define (int-checker? x) (displayln "***** CHECKING INT? ******") (int? x)) -; (define (number-checker? x) (displayln "***** CHECKING NUMBER? ******") (number? x)) - -; (define level1 -; (bind-contract-to-function -; (make-function-contract -; (make-function-contract (FlatContract number-checker? 'number-checker?))) -; (lambda () (lambda () (displayln "@@@@@@@@@@ CALLING FUNCTION @@@@@@@@@@@") 10.2)) -; 'level1)) - -; (define level2 -; (bind-contract-to-function -; (make-function-contract -; (make-function-contract (FlatContract int-checker? 'int-checker))) -; (lambda () (level1)) -; 'level2)) - -; (define level3 -; (bind-contract-to-function -; (make-function-contract -; (make-function-contract (FlatContract any? 'any?))) -; (lambda () (level2)) -; 'level3)) - -; ((level3)) - -; (define/c (foo x y) -; (->c even? odd? odd?) -; (+ x y)) - -;; ; (define plain-function (lambda () (displayln "----CALLING PLAIN FUNCTION----") 10.2)) - -;; ; (define level1 -;; ; (bind-contract-to-function -;; ; (make-function-contract (make-function-contract (FlatContract number-checker? 'number-checker?)) -;; ; (make-function-contract (FlatContract number-checker? 'number-checker?))) -;; ; (lambda (func) func) -;; ; 'level1)) - -;; ; (define level2 -;; ; (bind-contract-to-function -;; ; (make-function-contract (make-function-contract (FlatContract int-checker? 'int-checker?)) -;; ; (make-function-contract (FlatContract int-checker? 'int-checker?))) -;; ; (lambda (func) func) -;; ; 'level2)) - -;; ; ((level2 (level1 (level1 (level1 plain-function))))) - -;; ; (define (int-checker? x) (displayln "***** CHECKING INT? ******") (integer? x)) -;; ; (define (number-checker? x) (displayln "***** CHECKING NUMBER? ******") (number? x)) - -;; ; (define plain-function (lambda () (displayln "----CALLING PLAIN FUNCTION-----") 10.2)) -;; ; (define/contract (level1 func) -;; ; (-> (-> number-checker?) (-> number-checker?)) -;; ; func) diff --git a/cogs/coop/threads.scm b/cogs/coop/threads.scm index 67e32c26e..ca4445b5a 100644 --- a/cogs/coop/threads.scm +++ b/cogs/coop/threads.scm @@ -6,24 +6,22 @@ ; current-continuation : -> continuation (define (current-continuation) - (call/cc - (lambda (cc) - (cc cc)))) + (call/cc (lambda (cc) (cc cc)))) ; spawn : (-> anything) -> void (define (spawn thunk) - (let ((cc (current-continuation))) + (let ([cc (current-continuation)]) (if (continuation? cc) (set! *thread-queue* (append *thread-queue* (list cc))) - (begin - (thunk) - (quit))))) + (begin + (thunk) + (quit))))) ; yield : value -> void (define (yield) - (let ((cc (current-continuation))) + (let ([cc (current-continuation)]) (if (and (continuation? cc) (pair? *thread-queue*)) - (let ((next-thread (car *thread-queue*))) + (let ([next-thread (car *thread-queue*)]) (set! *thread-queue* (append (cdr *thread-queue*) (list cc))) (next-thread 'resume)) void))) @@ -31,47 +29,47 @@ ; quit : -> ... (define (quit) (if (pair? *thread-queue*) - (let ((next-thread (car *thread-queue*))) + (let ([next-thread (car *thread-queue*)]) (set! *thread-queue* (cdr *thread-queue*)) (next-thread 'resume)) (halt))) - + ; start-threads : -> ... (define (start-threads) - (let ((cc (current-continuation))) + (let ([cc (current-continuation)]) ; (displayln cc) (if cc (begin - ; (displayln cc) - (set! halt (lambda () - ; (inspect-bytecode cc) - ; (displayln cc) - (cc #f))) - ; (displayln cc) + ; (displayln cc) + (set! halt + (lambda () + ; (inspect-bytecode cc) + ; (displayln cc) + (cc #f))) + ; (displayln cc) (if (null? *thread-queue*) void (begin - (let ((next-thread (car *thread-queue*))) + (let ([next-thread (car *thread-queue*)]) (set! *thread-queue* (cdr *thread-queue*)) (next-thread 'resume))))) void))) - ;; Example cooperatively threaded program (define counter 10) (define (make-thread-thunk name) (define (loop) - (when (< counter 0) - (quit)) - (display "in thread ") - (display name) - (display "; counter = ") - (display counter) - (newline) - (set! counter (- counter 1)) - (yield) - (loop)) + (when (< counter 0) + (quit)) + (display "in thread ") + (display name) + (display "; counter = ") + (display counter) + (newline) + (set! counter (- counter 1)) + (yield) + (loop)) loop) (spawn (make-thread-thunk 'a)) diff --git a/cogs/download.scm b/cogs/download.scm index fdb80193f..068f8501e 100644 --- a/cogs/download.scm +++ b/cogs/download.scm @@ -64,7 +64,7 @@ ;; on crates.io ;; -(git-clone "helix-configuration" - "https://github.com/mattwparas/helix-config.git" - *COG_DIR* - #:sha "ae01ad7a3e7a48dad0ddbe8b812ab162aba31732") +; (git-clone "helix-configuration" +; "https://github.com/mattwparas/helix-config.git" +; *COG_DIR* +; #:sha "ae01ad7a3e7a48dad0ddbe8b812ab162aba31732") diff --git a/cogs/dump.scm b/cogs/dump.scm deleted file mode 100644 index 090c08e42..000000000 --- a/cogs/dump.scm +++ /dev/null @@ -1,2263 +0,0 @@ -(begin - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*SUCCESS-COUNT* - 0) - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*FAILURE-COUNT* - 0) - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*failures* - (quote - ())) - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-success - (λ () - (set! mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*SUCCESS-COUNT* - (+ - mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*SUCCESS-COUNT* - 1)))) - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - (λ (name) - (begin - (set! mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*FAILURE-COUNT* - (+ - mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*FAILURE-COUNT* - 1)) - (set! mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*failures* - (cons - name - mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*failures*))))) - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-success - (λ (name) - (begin - (display "test > " name " ... ") - (display-color "Ok" (quote green)) - (newline)))) - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - (λ (name) - (begin - (display "test > " name " ... ") - (display-color "FAILED" (quote red)) - (newline)))) - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - (λ (name input expected) - (if (equal? input expected) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-success) - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-success - name)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - name) - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - name) - (displayln - " Expected: " - expected - ", Found " - input))))) - (define mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmget-test-stats - (λ () - (hash - (quote - success-count) - mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*SUCCESS-COUNT* - (quote - failure-count) - mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*FAILURE-COUNT* - (quote - failures) - mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm*failures*))) - (define __module-mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm - (hash - (quote - test) - mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - (quote - get-test-stats) - mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmget-test-stats))) - -(define test - (hash-get - __module-mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm - (quote - test))) - -(define get-test-stats - (hash-get - __module-mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm - (quote - get-test-stats))) - -(define test - (hash-get - __module-mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm - (quote - test))) - -(define get-test-stats - (hash-get - __module-mangler/home/matt/Documents/steel/cogs/tests/unit-test.scm - (quote - get-test-stats))) - -(set-test-mode!) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "addition") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "addition") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "addition" - 8 - (+ x x)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Variable arity function call") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Variable arity function call") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Variable arity function call" - (quote - (3 4 5 6)) - x))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Rest arguments") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Rest arguments") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Rest arguments" - (quote - (5 6)) - (quote - (5 6))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Branching with >") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Branching with >") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Branching with >" - (quote - yes) - (quote - yes)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Branch with <") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Branch with <") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Branch with <" - (quote - no) - (quote - no)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Numeric operations with if") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Numeric operations with if") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Numeric operations with if" - 1 - 1))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Cond with >") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Cond with >") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Cond with >" - (quote - greater) - (quote - greater)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Cond with equal") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Cond with equal") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Cond with equal" - (quote - equal) - (quote - equal)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Case macro") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Case macro") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Case macro" - (quote - composite) - (if (member 6 (quote (2 3 5 7))) - (quote - prime) - (if (member 6 (quote (1 4 6 8 9))) - (quote - composite) - void))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Case with chars") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Case with chars") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Case with chars" - (quote - consonant) - (let ((##atom-key (quote c))) - (if (member ##atom-key (quote (a e i o u))) - (quote - vowel) - (if (member ##atom-key (quote (w y))) - (quote - semivowel) - (quote - consonant))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "and true") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "and true") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "and true" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "and false") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "and false") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "and false" - #false - #false))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "and returns last in the list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "and returns last in the list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "and returns last in the list" - (quote - (f g)) - (quote - (f g))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "and defaults to true") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "and defaults to true") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "and defaults to true" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "or true on the first") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "or true on the first") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "or true on the first" - #true - (quote - #true)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "or true on the first, second not true") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "or true on the first, second not true") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "or true on the first, second not true" - #true - (quote - #true)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "basic let") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "basic let") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "basic let" - 6 - (* x y)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "basic let with multiple levels") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "basic let with multiple levels") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "basic let with multiple levels" - 35 - (let ((x 7) (z (+ x y))) - (* z x))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "basic let*") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "basic let*") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "basic let*" - 70 - (let ((z (+ x y))) - (* z x))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "interior define") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "interior define") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "interior define" - -2 - (let ((x 2) (f 123)) - (let ((_____f1 (λ () (- x)))) - (begin (set! f _____f1) (f))))))))) - -(define let*-def - 1) - -#false - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Redefine top level with interior define, stays the same") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Redefine top level with interior define, stays the same") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Redefine top level with interior define, stays the same" - 1 - 1))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "simple quasiquote and unquote") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "simple quasiquote and unquote") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "simple quasiquote and unquote" - (quote - (list 3 4)) - (cons - (quote - list) - (cons 3 (cons (quote 4) (quote ()))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "quasiquote and unquote with more") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "quasiquote and unquote with more") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "quasiquote and unquote with more" - (quote - (list a (quote a))) - (let ((name (quote a))) - (cons - (quote - list) - (cons - name - (cons - (quote - (quote - (unquote name))) - (quote - ())))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "unquote splicing") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "unquote splicing") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "unquote splicing" - (quote - (a 3 4 5 6 b)) - (cons - (quote - a) - (cons - 3 - (append - (map abs (quote (4 -5 6))) - (cons (quote b) (quote ())))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "unquote splicing with unquote") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "unquote splicing with unquote") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "unquote splicing with unquote" - (quote - (10 5 4 16 9 8)) - (cons - (quote - 10) - (cons - (quote - 5) - (cons - (expt 2 2) - (append - (map - (λ (n) - (expt n 2)) - (quote - (4 3))) - (cons - (quote - 8) - (quote - ()))))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "named quasiquote") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "named quasiquote") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "named quasiquote" - (quote - (list 3 4)) - (cons - (quote - list) - (cons 3 (cons (quote 4) (quote ()))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Symbols are interned") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Symbols are interned") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Symbols are interned" - #true - (eq? (quote a) (quote a))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "lists don't get interned") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "lists don't get interned") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "lists don't get interned" - #false - (eq? (quote (a)) (quote (a)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Empty lists are interned") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Empty lists are interned") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Empty lists are interned" - #true - (eq? (quote ()) (quote ()))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "functions are equal") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "functions are equal") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "functions are equal" - #true - (eq? car car)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Local vars that are constant point to the same object") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Local vars that are constant point to the same object") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Local vars that are constant point to the same object" - #true - (eq? x x)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Function objects are eq? via pointer equality") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Function objects are eq? via pointer equality") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Function objects are eq? via pointer equality" - #true - (let ((p (λ (x) x))) - (eq? p p))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Value equality for interned symbols") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Value equality for interned symbols") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Value equality for interned symbols" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Value equality for interned lists") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Value equality for interned lists") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Value equality for interned lists" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Value equality for nested interned lists") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Value equality for nested interned lists") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Value equality for nested interned lists" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "String equality") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "String equality") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "String equality" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "String inequality") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "String inequality") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "String inequality" - #false - #false))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "String inequality, first char") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "String inequality, first char") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "String inequality, first char" - #false - #false))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Integer equality") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Integer equality") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Integer equality" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "max over ints") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "max over ints") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "max over ints" - 4 - (max 3 4)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Addition binop") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Addition binop") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Addition binop" - 7 - 7))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Addition unary op") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Addition unary op") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Addition unary op" - 3 - 3))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Addition no args") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Addition no args") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Addition no args" - 0 - 0))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Multiplication one arg, int") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Multiplication one arg, int") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Multiplication one arg, int" - 4 - 4))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Multiplication no args, int ") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Multiplication no args, int ") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Multiplication no args, int " - 1 - 1))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Subtraction binop") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Subtraction binop") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Subtraction binop" - -1 - -1))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Subtract three args") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Subtract three args") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Subtract three args" - -6 - -6))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Subtraction unary op") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Subtraction unary op") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Subtraction unary op" - -3 - -3))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Subtraction, floating point and int") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Subtraction, floating point and int") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Subtraction, floating point and int" - -1.0 - -1.0))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "abs int") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "abs int") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "abs int" - 7 - (abs -7)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "integers are truthy") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "integers are truthy") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "integers are truthy" - #false - (not 3)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "lists are truthy") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "lists are truthy") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "lists are truthy" - #false - (not (quote (3)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "empty lists are true") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "empty lists are true") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "empty lists are true" - #false - (not (quote ()))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "empty lists are true, constructor") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "empty lists are true, constructor") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "empty lists are true, constructor" - #false - (not (quote ()))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "ints are not bools") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "ints are not bools") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "ints are not bools" - #false - #false))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "empty list is not a boolean") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "empty list is not a boolean") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "empty list is not a boolean" - #false - #false))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "lists are considered pairs") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "lists are considered pairs") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "lists are considered pairs" - #true - (pair? (quote (a b c)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "cons onto empty list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "cons onto empty list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "cons onto empty list" - (quote - (a)) - (cons (quote a) (quote ()))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "cons list onto list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "cons list onto list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "cons list onto list" - (quote - ((a) b c d)) - (cons (quote (a)) (quote (b c d)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "cons string onto list of symbols") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "cons string onto list of symbols") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "cons string onto list of symbols" - (quote - ("a" b c)) - (cons "a" (quote (b c)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "take the car of a list of symbols") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "take the car of a list of symbols") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "take the car of a list of symbols" - (quote - a) - (quote - a)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "take the car, where the car is a list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "take the car, where the car is a list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "take the car, where the car is a list" - (quote - (a)) - (quote - (a))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "take the cdr of a list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "take the cdr of a list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "take the cdr of a list" - (quote - (b c d)) - (cdr (quote ((a) b c d)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Check list predicate") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Check list predicate") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Check list predicate" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Empty list is a list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Empty list is a list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Empty list is a list" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "List constructor") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "List constructor") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "List constructor" - (quote - (a 7 c)) - (quote - (a 7 c))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "empty list constructor") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "empty list constructor") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "empty list constructor" - (quote - ()) - (quote - ())))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "length of a flat list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "length of a flat list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "length of a flat list" - 3 - 3))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "length of a non flat list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "length of a non flat list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "length of a non flat list" - 3 - 3))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "empty list has a length of 0") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "empty list has a length of 0") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "empty list has a length of 0" - 0 - 0))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "append two lists") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "append two lists") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "append two lists" - (quote - (x y)) - (append (quote (x)) (quote (y)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "append big list to small list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "append big list to small list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "append big list to small list" - (quote - (a b c d)) - (append (quote (a)) (quote (b c d)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "append nested lists") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "append nested lists") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "append nested lists" - (quote - (a (b) (c))) - (append (quote (a (b))) (quote ((c))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "append to empty list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "append to empty list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "append to empty list" - (quote - a) - (append (quote ()) (quote a))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "reverse list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "reverse list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "reverse list" - (quote - (c b a)) - (quote - (c b a))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "reverse nested list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "reverse nested list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "reverse nested list" - (quote - ((e (f)) d (b c) a)) - (quote - ((e (f)) d (b c) a))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "simple list-ref") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "simple list-ref") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "simple list-ref" - (quote - c) - (list-ref (quote (a b c d)) 2)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "simple member") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "simple member") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "simple member" - (quote - ((a) c)) - (member (quote (a)) (quote (b (a) c)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "symbol predicate") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "symbol predicate") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "symbol predicate" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "symbol predicate from constant list") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "symbol predicate from constant list") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "symbol predicate from constant list" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "symbol predicate fails on string") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "symbol predicate fails on string") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "symbol predicate fails on string" - #false - #false))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "nil symbol is symbol") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "nil symbol is symbol") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "nil symbol is symbol" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "empty list is not a symbol") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "empty list is not a symbol") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "empty list is not a symbol" - #false - #false))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "symbol->string basic case") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "symbol->string basic case") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "symbol->string basic case" - "flying-fish" - (symbol->string (quote flying-fish))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "symbol-string works") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "symbol-string works") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "symbol-string works" - "Martin" - (symbol->string (quote Martin))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "string losslessly moves into symbol and back") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "string losslessly moves into symbol and back") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "string losslessly moves into symbol and back" - "Malvina" - (symbol->string - (string->symbol "Malvina"))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "string predicate correctly identifies a string") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "string predicate correctly identifies a string") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "string predicate correctly identifies a string" - #true - #true))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "string predicate fails on a symbol") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "string predicate fails on a symbol") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "string predicate fails on a symbol" - #false - #false))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "empty string has a length of 0") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "empty string has a length of 0") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "empty string has a length of 0" - 0 - (string-length "")))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "string length correctly reported for standard string") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "string length correctly reported for standard string") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "string length correctly reported for standard string" - 3 - (string-length "abc")))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "string-append with empty string") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "string-append with empty string") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "string-append with empty string" - "abc" - "abc"))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "string-append with empty string on the lhs") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "string-append with empty string on the lhs") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "string-append with empty string on the lhs" - "abc" - "abc"))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "string-append with two non empty strings") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "string-append with two non empty strings") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "string-append with two non empty strings" - "abc" - "abc"))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "function correctly identified as a procedure") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "function correctly identified as a procedure") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "function correctly identified as a procedure" - #true - (procedure? car)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "symbol correctly identified as NOT as a procedure") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "symbol correctly identified as NOT as a procedure") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "symbol correctly identified as NOT as a procedure" - #false - (procedure? (quote car))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "user defined function correctly identified as a procedure") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "user defined function correctly identified as a procedure") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "user defined function correctly identified as a procedure" - #true - (procedure? (λ (x) (* x x)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "quoted expression correctly identified as NOT as procedure") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "quoted expression correctly identified as NOT as procedure") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "quoted expression correctly identified as NOT as procedure" - #false - (procedure? (quote (lambda (x) (* x x))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "basic call/cc with native predicate") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "basic call/cc with native predicate") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "basic call/cc with native predicate" - #true - (call-with-current-continuation - procedure?)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "basic call/cc with user defined function") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "basic call/cc with user defined function") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "basic call/cc with user defined function" - 7 - (call-with-current-continuation (λ (k) 7))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "more complex call/cc with user defined function") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "more complex call/cc with user defined function") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "more complex call/cc with user defined function" - 3 - (call-with-current-continuation - (λ (k) - (+ 2 5 (k 3))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "apply with native function") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "apply with native function") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "apply with native function" - 7 - (apply + (quote (3 4)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "map with user defined function") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "map with user defined function") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "map with user defined function" - (quote - (b e h)) - (map cadr (quote ((a b) (d e) (g h))))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "map with numeric op") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "map with numeric op") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "map with numeric op" - (quote - (1 4 27 256 3125)) - (map - (λ (n) - (expt n n)) - (quote - (1 2 3 4 5)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "map with multiple list arguments") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "map with multiple list arguments") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "map with multiple list arguments" - (quote - (5 7 9)) - (map + (quote (1 2 3)) (quote (4 5 6)))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "using else as a variable") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "using else as a variable") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "using else as a variable" - (quote - ok) - (quote - ok)))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Using an arrow as a variable") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Using an arrow as a variable") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Using an arrow as a variable" - (quote - ok) - (begin 1 (quote ok))))))) - -(*reset - (λ () - (call-with-exception-handler - (λ (##err) - (begin - (let ((##err4 ##err)) - (begin - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmmark-failed - "Multiple mutations inside local context") - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmprint-failure - "Multiple mutations inside local context") - (displayln ##err4))) - (*shift (λ (k) (k void))))) - (λ () - (mangler/home/matt/Documents/steel/cogs/tests/unit-test.scmtest - "Multiple mutations inside local context" - (quote - (2 3)) - (let ((x 1)) - (let ((y x)) - (begin - (set! x 2) - (set! y 3) - (list x y))))))))) diff --git a/cogs/dump.txt b/cogs/dump.txt new file mode 100644 index 000000000..aecdfb94e --- /dev/null +++ b/cogs/dump.txt @@ -0,0 +1,338 @@ +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__hash -> #%prim.hash +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__#%vtable-update-entry! -> #%prim.#%vtable-update-entry! +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__void -> #%prim.void +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list-ref -> #%prim.list-ref +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list-ref -> #%prim.list-ref +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list-ref -> #%prim.list-ref +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list-ref -> #%prim.list-ref +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__make-struct-type -> #%prim.make-struct-type +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list -> #%prim.list +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__void -> #%prim.void +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__null? -> #%prim.null? +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list? -> #%prim.list? +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__append -> #%prim.append +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__car -> #%prim.car +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__cdr -> #%prim.cdr +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list -> #%prim.list +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__= -> #%prim.= +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__length -> #%prim.length +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__push-back -> #%prim.push-back +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty? -> #%prim.empty? +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list -> #%prim.list +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__< -> #%prim.< +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__cons -> #%prim.cons +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__equal? -> #%prim.equal? +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__cons -> #%prim.cons +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__rest -> #%prim.rest +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__cons -> #%prim.cons +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__rest -> #%prim.rest +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__push-back -> #%prim.push-back +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty? -> #%prim.empty? +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list -> #%prim.list +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__rest -> #%prim.rest +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__< -> #%prim.< +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__cons -> #%prim.cons +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__rest -> #%prim.rest +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__equal? -> #%prim.equal? +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__cons -> #%prim.cons +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__rest -> #%prim.rest +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__rest -> #%prim.rest +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__cons -> #%prim.cons +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__rest -> #%prim.rest +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__string->list -> #%prim.string->list +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__< -> #%prim.< +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__= -> #%prim.= +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__length -> #%prim.length +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__first -> #%prim.first +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__rest -> #%prim.rest +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__cons -> #%prim.cons +MUTATED IDENT TO BE: mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__list->string -> #%prim.list->string +(define ##__lifted_pure_function78793 + (λ (struct-type-descriptor + constructor-proto + predicate-proto + getter-proto) + (begin + (set! mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__struct:trie + struct-type-descriptor) + (#%prim.#%vtable-update-entry! + struct-type-descriptor + #false + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#_____trie-options___) + (set! mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + constructor-proto) + (set! mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie? + predicate-proto) + (set! mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-char + (λ (this) + (getter-proto this 0))) + (set! mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-children + (λ (this) + (getter-proto this 1))) + (set! mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-end-word? + (λ (this) + (getter-proto this 2))) + (set! mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-word-up-to + (λ (this) + (getter-proto this 3))) + #%prim.void))) + +(begin + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#_____trie-options___ + (#%prim.hash + (quote + #:mutable) + #false + (quote + #:transparent) + #false + (quote + #:fields) + (quote + (char children end-word? word-up-to)) + (quote + #:printer) + #false + (quote + #:name) + (quote + trie))) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + (quote + unintialized)) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__struct:trie + (quote + uninitialized)) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie? + (quote + uninitialized)) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-char + (quote + uninitialized)) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-children + (quote + uninitialized)) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-end-word? + (quote + uninitialized)) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-word-up-to + (quote + uninitialized)) + (let ((prototypes (#%prim.make-struct-type + (quote + trie) + 4))) + (##__lifted_pure_function78793 + (#%prim.list-ref prototypes 0) + (#%prim.list-ref prototypes 1) + (#%prim.list-ref prototypes 2) + (#%prim.list-ref prototypes 3))) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty + (quote + ())) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty-trie + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + #%prim.void + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty + #false + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty)) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__flatten + (λ (lst) + (if (#%prim.null? lst) + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty + (if (#%prim.list? lst) + (#%prim.append + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__flatten + (#%prim.car lst)) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__flatten + (#%prim.cdr lst))) + (#%prim.list lst))))) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__create-children + (λ (char-list lst prefix-chars) + (if (#%prim.= (#%prim.length char-list) 1) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__handle-last-letter + char-list + lst + prefix-chars) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__handle-intern-letter + char-list + lst + prefix-chars)))) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__handle-last-letter + (λ (char-list lst prefix-chars) + (let ((char (#%prim.first char-list))) + (let ((next-prefix (#%prim.push-back + prefix-chars + char))) + (if (#%prim.empty? lst) + (#%prim.list + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + char + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty + #true + next-prefix)) + (if (#%prim.< + char + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-char + (#%prim.first lst))) + (#%prim.cons + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + char + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty + #true + next-prefix) + lst) + (if (#%prim.equal? + char + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-char + (#%prim.first lst))) + (#%prim.cons + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + char + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-children + (#%prim.first lst)) + #true + next-prefix) + (#%prim.rest lst)) + (#%prim.cons + (#%prim.first lst) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__create-children + char-list + (#%prim.rest lst) + prefix-chars))))))))) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__handle-intern-letter + (λ (char-list lst prefix-chars) + (let ((char (#%prim.first char-list))) + (let ((next-prefix (#%prim.push-back + prefix-chars + char))) + (if (#%prim.empty? lst) + (#%prim.list + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + char + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__create-children + (#%prim.rest char-list) + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty + next-prefix) + #false + next-prefix)) + (if (#%prim.< + char + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-char + (#%prim.first lst))) + (#%prim.cons + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + char + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__create-children + (#%prim.rest char-list) + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty + next-prefix) + #false + next-prefix) + lst) + (if (#%prim.equal? + char + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-char + (#%prim.first lst))) + (#%prim.cons + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + char + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__create-children + (#%prim.rest char-list) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-children + (#%prim.first lst)) + next-prefix) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-end-word? + (#%prim.first lst)) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-word-up-to + (#%prim.first lst))) + (#%prim.rest lst)) + (#%prim.cons + (#%prim.first lst) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__create-children + char-list + (#%prim.rest lst) + prefix-chars))))))))) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__insert + (λ (root-trie word) + (let ((char-list (#%prim.string->list word))) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-char + root-trie) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__create-children + char-list + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-children + root-trie) + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__empty) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-end-word? + root-trie) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-word-up-to + root-trie))))) + (define mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__triestring + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-word-up-to + trie-node)) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__flatten + (map + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__pre-order + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-children + trie-node)))) + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__flatten + (map + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__pre-order + (mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-children + trie-node)))))) + (define __module-mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__ + (hash + (quote + trie-sort) + mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__trie-sort))) + +(define trie-sort + (%proto-hash-get% + __module-mangler/home/matt/Documents/steel/cogs/sorting/trie-sort.scm__%#__ + (quote + trie-sort))) diff --git a/cogs/foo.scm b/cogs/foo.scm index 136ed488f..aae839562 100644 --- a/cogs/foo.scm +++ b/cogs/foo.scm @@ -1,9 +1,3 @@ -(define (crunch composer lsts) - (if (null? lsts) composer (crunch (compose composer (zipping (car lsts))) (cdr lsts)))) +(set-test-mode!) -(define (map-many func lst . lsts) - (if (null? lsts) - (map func lst) - ;; Handle the case for many lists - (let ([composed-transducer (crunch (compose) lsts)]) - (transduce lst composed-transducer (mapping (lambda (x) (apply func x))) (into-list))))) +(require "sorting/tests.scm") diff --git a/cogs/fs/fs.scm b/cogs/fs/fs.scm index 523bde1b8..8ea2d7690 100644 --- a/cogs/fs/fs.scm +++ b/cogs/fs/fs.scm @@ -1,7 +1,5 @@ -(require "steel/contracts/contract.scm" - (for-syntax "steel/contracts/contract.scm")) - -(provide walk-files) +(provide walk-files + file->string) (define (for-each func lst) (if (null? lst) @@ -12,10 +10,13 @@ (return! void)) (for-each func (cdr lst))))) +(define (file->string path) + (let ([file (open-input-file path)]) (read-port-to-string file))) + ;; Walk the file system, applying a function to each file found -(define/c (walk-files path func) - (->c string? (->c string? any/c) any/c) - (cond - [(is-file? path) (func path)] - [(is-dir? path) (for-each (lambda (x) (walk-files x func)) (read-dir path))] - [else void])) +(define/contract (walk-files path func) + (->/c string? (->/c string? any/c) any/c) + (cond + [(is-file? path) (func path)] + [(is-dir? path) (for-each (lambda (x) (walk-files x func)) (read-dir path))] + [else void])) diff --git a/cogs/installer/package.scm b/cogs/installer/package.scm index cba4dbded..1a2fe967b 100644 --- a/cogs/installer/package.scm +++ b/cogs/installer/package.scm @@ -6,9 +6,9 @@ ;; Storing versions in a manifest would be nice - a project has an associated manifest that pins versions. ;; Load in contracts for stress testing -(require "../contracts/contract.scm" - (for-syntax "../contracts/contract.scm") - "steel/result") +(require "steel/result") + +(provide package-installer-main) (define (append-with-separator path) (if (ends-with? path "/") (string-append path "cogs") (string-append path "/cogs"))) @@ -16,57 +16,57 @@ ;; Should make this lazy? (define *STEEL_HOME* (~> "STEEL_HOME" (env-var) (unwrap-ok) (append-with-separator))) -(define/c (parse-cog module) - (->c string? list?) - (if (is-dir? module) - (let ([cog-path (string-append module "/cog.scm")]) - (if (is-file? cog-path) - ;; Update the resulting map with the path to the module - (list (hash-insert (parse-cog-file cog-path) 'path module)) +(define/contract (parse-cog module) + (->/c string? list?) + (if (is-dir? module) + (let ([cog-path (string-append module "/cog.scm")]) + (if (is-file? cog-path) + ;; Update the resulting map with the path to the module + (list (hash-insert (parse-cog-file cog-path) 'path module)) - (hash-values->list (discover-cogs module)))) - (error! "Unable to locate the module " module))) + (hash-values->list (discover-cogs module)))) + (error! "Unable to locate the module " module))) ;; Parses a cog file directly into a hashmap -(define/c (parse-cog-file path) - (->c string? hash?) - (define contents (let ([file (open-input-file path)]) (read-port-to-string file))) - (transduce (read! contents) (mapping cdr) (into-hashmap))) +(define/contract (parse-cog-file path) + (->/c string? hash?) + (define contents (let ([file (open-input-file path)]) (read-port-to-string file))) + (transduce (read! contents) (mapping cdr) (into-hashmap))) ;; Discover the cogs located at the path, return as a list of hash maps -(define/c (discover-cogs path) - (->c string? hash?) - (when (not (path-exists? path)) - (displayln "cogs directory does not exist, creating now...") - (create-directory! path)) - (transduce (read-dir path) - (filtering is-dir?) - (mapping parse-cog) - (flattening) - (mapping (lambda (package) (list (hash-get package 'package-name) package))) - (into-hashmap))) +(define/contract (discover-cogs path) + (->/c string? hash?) + (when (not (path-exists? path)) + (displayln "cogs directory does not exist, creating now...") + (create-directory! path)) + (transduce (read-dir path) + (filtering is-dir?) + (mapping parse-cog) + (flattening) + (mapping (lambda (package) (list (hash-get package 'package-name) package))) + (into-hashmap))) ;; Given a package spec, install that package directly to the file system -(define/c (install-package package) - (->c hash? string?) - (define destination - (string-append *STEEL_HOME* "/" (symbol->string (hash-get package 'package-name)))) - (copy-directory-recursively! (hash-get package 'path) destination) - destination) +(define/contract (install-package package) + (->/c hash? string?) + (define destination + (string-append *STEEL_HOME* "/" (symbol->string (hash-get package 'package-name)))) + (copy-directory-recursively! (hash-get package 'path) destination) + destination) ;; Given a package pec, uninstall that package by deleting the contents of the installation -(define/c (uninstall-package package) - (->c hash? string?) - (define destination - (string-append *STEEL_HOME* "/" (symbol->string (hash-get package 'package-name)))) - (displayln destination)) - -(define/c (install-package-and-log cog-to-install) - (->c hash? void?) - (let ([output-dir (install-package cog-to-install)]) - (display-color "✅ Installed package to: " 'green) - (displayln output-dir) - (newline))) +(define/contract (uninstall-package package) + (->/c hash? string?) + (define destination + (string-append *STEEL_HOME* "/" (symbol->string (hash-get package 'package-name)))) + (displayln destination)) + +(define/contract (install-package-and-log cog-to-install) + (->/c hash? void?) + (let ([output-dir (install-package cog-to-install)]) + (display-color "✅ Installed package to: " 'green) + (displayln output-dir) + (newline))) (define (check-install-package installed-cogs cog-to-install) (define package-name (hash-get cog-to-install 'package-name)) @@ -84,7 +84,6 @@ (define (parse-cogs-from-command-line) (if (empty? std::env::args) (list (current-directory)) std::env::args)) -(provide package-installer-main) (define (package-installer-main) (define cogs-to-install (parse-cogs-from-command-line)) diff --git a/cogs/other.scm b/cogs/other.scm index 330067ccb..748e7d8d4 100644 --- a/cogs/other.scm +++ b/cogs/other.scm @@ -3,5 +3,5 @@ ; (apples 10) ;; Lookup multiple keys at a time -(define (href table keys .) - (foldl (lambda (key t) (hash-get t key)) table keys)) \ No newline at end of file +(define (href table . keys) + (foldl (lambda (key t) (hash-get t key)) table keys)) diff --git a/cogs/r5rs.scm b/cogs/r5rs.scm index 4a8d149e7..153db307b 100644 --- a/cogs/r5rs.scm +++ b/cogs/r5rs.scm @@ -116,15 +116,15 @@ (check-equal '#(0 1 2 3 4) (do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))) (check-equal 25 - (let ([x '(1 3 5 7 9)]) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum)))) - ;; TODO named `let` - ; (check-equal '((6 1 3) (-5 -2)) - ; (let loop ([numbers '(3 -2 1 6 -5)] [nonneg '()] [neg '()]) - ; (cond - ; [(null? numbers) (list nonneg neg)] - ; [(>= (car numbers) 0) (loop (cdr numbers) (cons (car numbers) nonneg) neg)] - ; [(< (car numbers) 0) (loop (cdr numbers) nonneg (cons (car numbers) neg))]))) - ) + (let ([x '(1 3 5 7 9)]) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum))))) + +(check-equal? "named let" + '((6 1 3) (-5 -2)) + (let loop ([numbers '(3 -2 1 6 -5)] [nonneg '()] [neg '()]) + (cond + [(null? numbers) (list nonneg neg)] + [(>= (car numbers) 0) (loop (cdr numbers) (cons (car numbers) nonneg) neg)] + [(< (car numbers) 0) (loop (cdr numbers) nonneg (cons (car numbers) neg))]))) (check-equal? "simple quasiquote and unquote" '(list 3 4) `(list ,(+ 1 2) 4)) @@ -386,8 +386,12 @@ (check-equal? "string >=, true" #t (string>=? "aa" "a")) (check-equal? "string >=, same string" #t (string>=? "a" "a")) -(check-equal? "case-insensitive string-equality with constructor, equal" #t (string-ci=? "A" (string #\a))) -(check-equal? "case-insensitive string-equality with constructor, not equal" #f (string-ci=? "A" (string #\b))) +(check-equal? "case-insensitive string-equality with constructor, equal" + #t + (string-ci=? "A" (string #\a))) +(check-equal? "case-insensitive string-equality with constructor, not equal" + #f + (string-ci=? "A" (string #\b))) (check-equal? "case-insensitive string<, true" #t (string-ci 'ok]))) -; (check-equal '(,foo) (let ([unquote 1]) `(,foo))) +(check-equal? "Override unquote in a local context" '(,foo) (let ([unquote 1]) `(,foo))) +(check-equal? "Override unquote-splicing in a local context" + '(,@foo) + (let ([unquote-splicing 1]) `(,@foo))) -(skip-compile (check-equal? "Override unquote in a local context" '(,foo) (let ([unquote 1]) `(,foo))) - (check-equal '(,@foo) (let ([unquote-splicing 1]) `(,@foo))) - ; (check-equal 'ok - ; (let ([... 2]) - ; (let-syntax ([s (syntax-rules () - ; [(_ x ...) 'bad] - ; [(_ . r) 'ok])]) - ; (s a b c)))) - (check-equal 'ok +;; TODO: Implement let-syntax +(skip-compile (check-equal 'ok (let () (let-syntax () (define internal-def 'ok)) @@ -492,7 +492,6 @@ (define internal-def 'ok)) internal-def))) -; TODO: This causes a free identifier error (check-equal? "mutation within local function" '(2 1) ((lambda () @@ -501,7 +500,6 @@ (set! x 2) (list x y)))))) -; TODO: This causes a free identifier error (check-equal? "multiple levels of let with mutation" '(2 2) ((lambda () @@ -509,7 +507,6 @@ (set! x 2) (let ([y x]) (list x y)))))) -; TODO: This causes a free identifier error (check-equal? "local mutation" '(1 2) ((lambda () @@ -518,7 +515,6 @@ (set! y 2) (list x y)))))) -;; TODO: This causes a free identifier error (check-equal? "Multiple mutations inside local context" '(2 3) ((lambda () @@ -528,12 +524,15 @@ (set! y 3) (list x y)))))) -(skip-compile - (check-equal '(a b c) +; (skip-compile +(check-equal? "Dyanmic wind" + '(a b c) (let* ([path '()] [add (lambda (s) (set! path (cons s path)))]) (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) (reverse path))) - (check-equal '(connect talk1 disconnect connect talk2 disconnect) + +(check-equal? "Dynamic wind more complex" + '(connect talk1 disconnect connect talk2 disconnect) (let ([path '()] [c #f]) (let ([add (lambda (s) (set! path (cons s path)))]) (dynamic-wind (lambda () (add 'connect)) @@ -543,17 +542,18 @@ 'talk1)))) (lambda () (add 'disconnect))) (if (< (length path) 4) (c 'talk2) (reverse path))))) - ; (check-equal 2 - ; (let-syntax ([foo (syntax-rules ::: - ; [] - ; [(foo ... args :::) (args ::: ...)])]) - ; (foo 3 - 5))) - ; (check-equal - ; '(5 4 1 2 3) - ; (let-syntax ([foo (syntax-rules () - ; [(foo args ... penultimate ultimate) (list ultimate penultimate args ...)])]) - ; (foo 1 2 3 4 5))) - ) +; (check-equal 2 +; (let-syntax ([foo (syntax-rules ::: +; [] +; [(foo ... args :::) (args ::: ...)])]) +; (foo 3 - 5))) +; (check-equal +; '(5 4 1 2 3) +; (let-syntax ([foo (syntax-rules () +; [(foo args ... penultimate ultimate) (list ultimate penultimate args ...)])]) +; (foo 1 2 3 4 5))) + +; ) ;; -------------- Report ------------------ diff --git a/cogs/r7rs.scm b/cogs/r7rs.scm index 8f11398fc..f04878a5b 100644 --- a/cogs/r7rs.scm +++ b/cogs/r7rs.scm @@ -38,6 +38,38 @@ (set-test-mode!) (require "lists/lists.scm") + +;;;; Parameters + +(define location (make-parameter "here")) + +(check-equal? "Simple parameterize" + "there" + (parameterize ([location "there"]) + (location))) ;; "there" + +(check-equal? "parameter keeps original value" "here" (location)) ;; "here" + +(check-equal? "Parameter changes multiple times" + (list "in a house" "with a mouse" "in a house") + (parameterize ([location "in a house"]) + (list (location) + (parameterize ([location "with a mouse"]) + (location)) + (location)))) ;; '("in a house" "with a mouse" "in a house") + +(check-equal? "parameter keeps original value after" "here" (location)) ;; "here" + +(define (would-you-could-you?) + (and (not (equal? (location) "here")) (not (equal? (location) "there")))) + +(check-equal? "Parameters refer to the same location" #false (would-you-could-you?)) + +(check-equal? "Parameters refer to the same location, changed to be the same" + #true + (parameterize ([location "on a bus"]) + (would-you-could-you?))) + (define r7rs-test-stats (get-test-stats)) (displayln "Passed: " (hash-ref r7rs-test-stats 'success-count)) diff --git a/cogs/require.scm b/cogs/require.scm new file mode 100644 index 000000000..18710a30a --- /dev/null +++ b/cogs/require.scm @@ -0,0 +1,2 @@ +(require "sorting/trie-sort.scm") +; (require "transducers/transducers.scm") diff --git a/cogs/slack/main.scm b/cogs/slack/main.scm index 1ac43f5ed..d3b735ebb 100644 --- a/cogs/slack/main.scm +++ b/cogs/slack/main.scm @@ -1,15 +1,12 @@ (require "slack.scm") -(require "steel/time/time.scm" - (for-syntax "steel/time/time.scm")) - -(require "steel/contracts/contract.scm" - (for-syntax "steel/contracts/contract.scm")) +(require "steel/time/time.scm" + (for-syntax "steel/time/time.scm")) (require "steel/logging/log.scm") -(define/c (process-message body) - (->c hash? any/c) -; (displayln body) +(define/contract (process-message body) + (->/c hash? any/c) + ; (displayln body) (log/info! body) @@ -18,11 +15,11 @@ (define channel (hash-get event-json 'channel)) (when (and text (starts-with? text "!ping")) - (time! (send-message channel "pong!")))) + (time! (send-message channel "pong!")))) (define (process-message-timed body) - (time! (process-message body))) + (time! (process-message body))) (define *ws-url* (get-ws-url)) -(event-loop *ws-url* (connect-to-slack-socket *ws-url*) process-message-timed) \ No newline at end of file +(event-loop *ws-url* (connect-to-slack-socket *ws-url*) process-message-timed) diff --git a/cogs/slack/slack.scm b/cogs/slack/slack.scm index 187d1d896..78b1b9631 100644 --- a/cogs/slack/slack.scm +++ b/cogs/slack/slack.scm @@ -4,17 +4,16 @@ (require "steel/logging/log.scm") (require-builtin steel/time) -(provide event-loop send-message connect-to-slack-socket get-ws-url) +(provide event-loop + send-message + connect-to-slack-socket + get-ws-url) (define (env-var! var) - (let ((e (env-var var))) - (if (Err? e) - "TODO" - (unwrap-ok e)))) + (let ([e (env-var var)]) (if (Err? e) "TODO" (unwrap-ok e)))) (define client (request/client)) - (define *SLACK_API_TOKEN* (env-var! "SLACK_API_TOKEN")) (define *SLACK_API_WS_TOKEN* (env-var! "SLACK_API_WS_TOKEN")) @@ -22,73 +21,78 @@ (define *ws-connection-url* "https://slack.com/api/apps.connections.open") (define (send-message channel content) - (~> client - (client/post *post-message-url*) - (request/bearer-auth *SLACK_API_TOKEN*) - (request/json (hash 'channel channel 'text content)) - (request/send) - (unwrap-ok))) + (~> client + (client/post *post-message-url*) + (request/bearer-auth *SLACK_API_TOKEN*) + (request/json (hash 'channel channel 'text content)) + (request/send) + (unwrap-ok))) (define (get-ws-url) - (log/info! "Requesting a websocket url") - (~> client - (client/post *ws-connection-url*) - (request/bearer-auth *SLACK_API_WS_TOKEN*) - (request/json (hash)) - (request/send) - (unwrap-ok) - (response->json) - (unwrap-ok) - (hash-get 'url))) + (log/info! "Requesting a websocket url") + (~> client + (client/post *ws-connection-url*) + (request/bearer-auth *SLACK_API_WS_TOKEN*) + (request/json (hash)) + (request/send) + (unwrap-ok) + (response->json) + (unwrap-ok) + (hash-get 'url))) ; (define *ws-url* (get-ws-url)) (define (connect-to-slack-socket url) - (~> url - (ws/connect) - (unwrap-ok) - (first))) + (~> url (ws/connect) (unwrap-ok) (first))) (define (send-acknowledgement socket body) - (ws/write-message! socket - (ws/message-text - (value->jsexpr-string - (hash 'envelope_id (hash-get body 'envelope_id)))))) + (ws/write-message! socket + (ws/message-text (value->jsexpr-string (hash 'envelope_id + (hash-get body 'envelope_id)))))) (define (loop url socket message-thunk) (define message (ws/read-message! socket)) - (cond [(Err? message) => - (displayln "Unable to read the message from the socket, retrying connection") - ;; Try to reconnect and see what happens - ;; Probably need to add a sleep here at some point to retry with a backoff - (loop url (connect-to-slack-socket (get-ws-url)) message-thunk)] - [else => - ;; At this point, the message should be guaranteed to be here, unwrap and continue - (define message (unwrap-ok message)) - (log/info! message) - ;; If its a ping, respond with a pong - (cond [(ws/message-ping? message) - => - (ws/write-message! socket (ws/message-ping->pong message)) - (loop url socket message-thunk)] - ;; If its a text message, check if its a hello message - otherwise, continue - ;; And process the message - [(ws/message-text? message) - => - (define body (string->jsexpr (ws/message->text-payload message))) - (cond [(equal? "hello" (hash-try-get body 'type)) => - (loop url socket message-thunk)] + (cond + [(Err? message) + => + (displayln "Unable to read the message from the socket, retrying connection") + ;; Try to reconnect and see what happens + ;; Probably need to add a sleep here at some point to retry with a backoff + (loop url (connect-to-slack-socket (get-ws-url)) message-thunk)] + [else + => + ;; At this point, the message should be guaranteed to be here, unwrap and continue + (define message (unwrap-ok message)) + (log/info! message) + ;; If its a ping, respond with a pong + (cond + [(ws/message-ping? message) + => + (ws/write-message! socket (ws/message-ping->pong message)) + (loop url socket message-thunk)] + ;; If its a text message, check if its a hello message - otherwise, continue + ;; And process the message + [(ws/message-text? message) + => + (define body (string->jsexpr (ws/message->text-payload message))) + (cond + [(equal? "hello" (hash-try-get body 'type)) + => + (loop url socket message-thunk)] - [(equal? "disconnect" (hash-try-get body 'type)) => - (log/info! "Refreshing the connection, sleeping for 500 ms") - (time/sleep-ms 500) - (loop url (connect-to-slack-socket (get-ws-url)) message-thunk)] + [(equal? "disconnect" (hash-try-get body 'type)) + => + (log/info! "Refreshing the connection, sleeping for 500 ms") + (time/sleep-ms 500) + (loop url (connect-to-slack-socket (get-ws-url)) message-thunk)] - [else - => - (send-acknowledgement socket body) - (message-thunk body) - (loop url socket message-thunk)])] - [else => (loop url socket message-thunk)])])) + [else + => + (send-acknowledgement socket body) + (message-thunk body) + (loop url socket message-thunk)])] + [else + => + (loop url socket message-thunk)])])) -(define event-loop loop) \ No newline at end of file +(define event-loop loop) diff --git a/cogs/sorting/tests.scm b/cogs/sorting/tests.scm index c3bf40440..6372b7677 100644 --- a/cogs/sorting/tests.scm +++ b/cogs/sorting/tests.scm @@ -1,5 +1,5 @@ -(require "steel/tests/unit-test.scm" - (for-syntax "steel/tests/unit-test.scm") +(require "steel/tests/unit-test.scm" + (for-syntax "steel/tests/unit-test.scm") "merge-sort.scm" "trie-sort.scm" "quick-sort.scm") @@ -9,6 +9,6 @@ (define __module__ "tests") (test-module "trie-sort-tests" - (check-equal? "basic sorting" - (trie-sort (list "zebras" "bananas" "apples" "foo" "bar")) - '("apples" "bananas" "bar" "foo" "zebras" ))) \ No newline at end of file + (check-equal? "basic sorting" + (trie-sort (list "zebras" "bananas" "apples" "foo" "bar")) + '("apples" "bananas" "bar" "foo" "zebras"))) diff --git a/cogs/test-runner.scm b/cogs/test-runner.scm index dc1ac2134..8300d03a5 100644 --- a/cogs/test-runner.scm +++ b/cogs/test-runner.scm @@ -4,21 +4,50 @@ (run! shared-engine "(set-test-mode!)") +;; If the path contains a cog file, respect it +; (define (parse-cog-file path) +; (define contents (let ([file (open-input-file path)]) (read-port-to-string file))) +; (transduce (read! contents) (mapping cdr) (into-hashmap))) + +(define (read-file-to-string path) + (let ([file (open-input-file path)]) (read-port-to-string file))) + +(define (expression-contains-provide expr-list) + (contains? (λ (expr) + (cond + [(and (list? expr) (not (empty? expr))) + (cond + [(equal? 'provide (car expr)) #t] + [(equal? 'begin (car expr)) (expression-contains-provide (cdr expr))] + [else #f])] + [else #f])) + expr-list)) + +;; Open file, read it +(define (path-contains-provide path) + (~> (read-file-to-string path) read! expression-contains-provide)) + (define (require-file path) - (when (ends-with? path ".scm") - (run! shared-engine (list (list 'require path))))) + (when (and (ends-with? path ".scm") (path-contains-provide path)) + + (displayln "Loading: " path) + + ;; First parse the file and check that it provides something + (let ([result (run! shared-engine (list (list 'require path)))]) + + (when (Err? result) + + (error result))))) -(define (get-directory-from-args) - (if (empty? std::env::args) - "." - (car std::env::args))) +(define (get-directory-from-args) + (if (empty? std::env::args) "." (car std::env::args))) (walk-files (get-directory-from-args) require-file) (define test-stats - (~> (run! shared-engine '((require "steel/tests/unit-test.scm") (get-test-stats))) - (Ok->value) - (last))) + (~> (run! shared-engine '((require "steel/tests/unit-test.scm") (get-test-stats))) + (Ok->value) + (last))) (when (not (empty? (hash-get test-stats 'failures))) - (error! "There were test failures!")) \ No newline at end of file + (error! "There were test failures!")) diff --git a/cogs/threads/test-threads.scm b/cogs/threads/test-threads.scm index 8a0bdd148..f54da2025 100644 --- a/cogs/threads/test-threads.scm +++ b/cogs/threads/test-threads.scm @@ -18,6 +18,8 @@ (range 0 10))]) (map (lambda (x) (unwrap-ok (thread-join! x))) tasks))) +; (error "HELLO WORLD") + (test-module "Basic threads works" (check-equal? "spawn-threads" (spawn-concurrent-tasks) (map (lambda (x) void) (range 0 10)))) diff --git a/cogs/transducers/transducers.scm b/cogs/transducers/transducers.scm index 1d7c6f42c..d5b6dc147 100644 --- a/cogs/transducers/transducers.scm +++ b/cogs/transducers/transducers.scm @@ -57,15 +57,13 @@ ;; TODO: Come back to this when there is a better understanding ;; of how to implement let loop -; (define (vector-reduce f identity vec) -; (let ((len (vector-length vec))) -; (let loop ((i 0) (acc identity)) -; (if (= i len) -; acc -; (let ((acc (f acc (vector-ref vec i)))) -; (if (reduced? acc) -; (unreduce acc) -; (loop (+ i 1) acc))))))) +(define (vector-reduce f identity vec) + (let ([len (vector-length vec)]) + (let loop ([i 0] [acc identity]) + (if (= i len) + acc + (let ([acc (f acc (vector-ref vec i))]) + (if (reduced? acc) (unreduce acc) (loop (+ i 1) acc))))))) ; (define (string-reduce f identity str) ; (let ((len (string-length str))) @@ -199,14 +197,10 @@ [(xform f coll) (list-transduce xform f (f) coll)] [(xform f init coll) (let* ([xf (xform f)] [result (list-reduce xf init coll)]) (xf result))])) -; (define vector-transduce -; (case-lambda -; ((xform f coll) -; (vector-transduce xform f (f) coll)) -; ((xform f init coll) -; (let* ((xf (xform f)) -; (result (vector-reduce xf init coll))) -; (xf result))))) +(define vector-transduce + (case-lambda + [(xform f coll) (vector-transduce xform f (f) coll)] + [(xform f init coll) (let* ([xf (xform f)] [result (vector-reduce xf init coll)]) (xf result))])) ; (define string-transduce ; (case-lambda diff --git a/core/contracts.rkt b/core/contracts.rkt index 2fad8f445..e860315d7 100644 --- a/core/contracts.rkt +++ b/core/contracts.rkt @@ -1,42 +1,42 @@ -(provide - listof /c <=/c >=/c any/c and/c or/c) - -;; Contract combinators -(define (listof pred) - (lambda (lst) - (define (loop lst) - (cond [(null? lst) #t] - [(pred (car lst)) (loop (cdr lst))] - [else #f])) - (cond [(null? lst) #t] - [(list? lst) - (loop lst)] - [else #f]))) - -;; Contracts for < -(define ( -(define (>/c n) - (make/c (fn (x) (> x n)) (list '>/c n))) - -;; Contracts for <= -(define (<=/c n) - (make/c (fn (x) (<= x n)) (list '<=/c n))) - -;; Contracts for >= -(define (>=/c n) - (make/c (fn (x) (>= x n)) (list '>=/c n))) - -;; Satisfies any single value -(define (any/c x) - (make/c (fn (x) #t) 'any/c)) - -;; produces a function compatible with contract definitions -(define (and/c x y) - (lambda (z) (and (x z) (y z)))) - -;; produces a function compatible with contract definitions -(define (or/c x y) - (lambda (z) (or (x z) (y z)))) \ No newline at end of file +; (provide +; listof /c <=/c >=/c any/c and/c or/c) + +; ;; Contract combinators +; (define (listof pred) +; (lambda (lst) +; (define (loop lst) +; (cond [(null? lst) #t] +; [(pred (car lst)) (loop (cdr lst))] +; [else #f])) +; (cond [(null? lst) #t] +; [(list? lst) +; (loop lst)] +; [else #f]))) + +; ;; Contracts for < +; (define ( +; (define (>/c n) +; (make/c (fn (x) (> x n)) (list '>/c n))) + +; ;; Contracts for <= +; (define (<=/c n) +; (make/c (fn (x) (<= x n)) (list '<=/c n))) + +; ;; Contracts for >= +; (define (>=/c n) +; (make/c (fn (x) (>= x n)) (list '>=/c n))) + +; ;; Satisfies any single value +; (define (any/c x) +; (make/c (fn (x) #t) 'any/c)) + +; ;; produces a function compatible with contract definitions +; (define (and/c x y) +; (lambda (z) (and (x z) (y z)))) + +; ;; produces a function compatible with contract definitions +; (define (or/c x y) +; (lambda (z) (or (x z) (y z)))) diff --git a/crates/steel-core/Cargo.toml b/crates/steel-core/Cargo.toml index b46ccbe47..cbadec0ff 100644 --- a/crates/steel-core/Cargo.toml +++ b/crates/steel-core/Cargo.toml @@ -27,7 +27,7 @@ serde = { version = "1.0.152", features = ["derive", "rc"] } serde_derive = "1.0.152" bincode = "1.3.3" pretty = "0.12.1" -im-lists = "0.4.0" +im-lists = "0.5.0" quickscope = "0.2.0" lasso = { version = "0.6.0", features = ["multi-threaded", "serialize"] } once_cell = "1.17.0" @@ -72,7 +72,7 @@ ureq = { version = "2.6.2", features = ["json"], optional = true } [dev-dependencies] proptest = "1.1.0" -criterion = "0.4.0" +criterion = "0.5.1" steel-core = { path = ".", features = ["modules"] } env_logger = "0.10.0" @@ -94,8 +94,11 @@ dylibs = ["dep:abi_stable", "dep:async-ffi"] blocking_requests = ["dep:ureq"] markdown = ["dep:termimad"] smallvec = ["dep:smallvec"] - +without-drop-protection = [] [[bench]] name = "my_benchmark" harness = false + +# TODO: Put this in the CI to gather the benchmarks +# cargo bench --bench my_benchmark -- --output-format bencher | tee output.txt diff --git a/crates/steel-core/benches/my_benchmark.rs b/crates/steel-core/benches/my_benchmark.rs index 9bed470c1..96a2511d4 100644 --- a/crates/steel-core/benches/my_benchmark.rs +++ b/crates/steel-core/benches/my_benchmark.rs @@ -91,9 +91,9 @@ fn ten_thousand_iterations_letrec(c: &mut Criterion) { benchmark_template(c, "ten-thousand-iterations-letrec", script, warmup); } -fn trie_sort_without_optimizations(c: &mut Criterion) { +fn trie_sort(c: &mut Criterion) { let mut vm = Engine::new(); - vm.compile_and_run_raw_program(PRELUDE).unwrap(); + // vm.compile_and_run_raw_program(PRELUDE).unwrap(); vm.compile_and_run_raw_program(steel::stdlib::TRIESORT) .unwrap(); @@ -127,49 +127,13 @@ fn trie_sort_without_optimizations(c: &mut Criterion) { }); } -fn trie_sort_with_optimizations(c: &mut Criterion) { - let mut vm = Engine::new(); - vm.compile_and_run_raw_program(PRELUDE).unwrap(); - vm.compile_and_run_raw_program(steel::stdlib::TRIESORT) - .unwrap(); - - let warmup = "(define lst - (list - \"suppose\" - \"believe\" - \"changeable\" - \"absent\" - \"busy\" - \"float\" - \"debonair\" - \"throat\" - \"grey\" - \"use\" - \"measure\" - \"van\" - \"thirsty\" - \"notify\" - \"star\"))"; - - vm.compile_and_run_raw_program(black_box(warmup)).unwrap(); - - let script = "(trie-sort lst)"; - - let program = vm.emit_raw_program_no_path(script).unwrap(); - let executable = vm.raw_program_to_executable(program).unwrap(); - - c.bench_function("trie-sort-with-optimizations", |b| { - b.iter(|| vm.run_executable(&executable)) - }); -} - fn fib_28(c: &mut Criterion) { // std::env::set_var("CODE_GEN_V2", "true"); let mut vm = Engine::new(); - vm.compile_and_run_raw_program(PRELUDE).unwrap(); + // vm.compile_and_run_raw_program(PRELUDE).unwrap(); vm.compile_and_run_raw_program( - "(define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))", + "(define (fib n) (#%black-box) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))", ) .unwrap(); @@ -239,164 +203,81 @@ fn register_function(c: &mut Criterion) { }); } -/* +fn binary_trees(c: &mut Criterion) { + let mut vm = Engine::new(); + vm.compile_and_run_raw_program( + r#" -fn trie_sort(c: &mut Criterion) { - let mut interpreter = SteelInterpreter::new(); - // interpreter.require(PRELUDE).unwrap(); - // require the trie sort library - interpreter.require(steel::stdlib::TRIESORT).unwrap(); +; #lang racket/base - let warmup = "(define lst - (list - \"suppose\" - \"believe\" - \"changeable\" - \"absent\" - \"busy\" - \"float\" - \"debonair\" - \"throat\" - \"grey\" - \"use\" - \"measure\" - \"van\" - \"thirsty\" - \"notify\" - \"star\"))"; - interpreter.evaluate(black_box(&warmup)).unwrap(); - let script = "(trie-sort lst)"; - c.bench_function("trie-sort", |b| { - b.iter(|| interpreter.evaluate(black_box(&script))) - }); -} +;;; The Computer Language Benchmarks Game +;;; https://salsa.debian.org/benchmarksgame-team/benchmarksgame/ -fn merge_sort(c: &mut Criterion) { - let mut interpreter = SteelInterpreter::new(); - // interpreter.require(PRELUDE).unwrap(); - let warmup = " -;;; ----------------------------------------------------------------- -;;; Merge two lists of numbers which are already in increasing order - - (define merge-lists - (lambda (l1 l2) - (if (null? l1) - l2 - (if (null? l2) - l1 - (if (< (car l1) (car l2)) - (cons (car l1) (merge-lists (cdr l1) l2)) - (cons (car l2) (merge-lists (cdr l2) l1))))))) - -;;; ------------------------------------------------------------------- -;;; Given list l, output those tokens of l which are in even positions - - (define even-numbers - (lambda (l) - (if (null? l) - '() - (if (null? (cdr l)) - '() - (cons (car (cdr l)) (even-numbers (cdr (cdr l)))))))) - -;;; ------------------------------------------------------------------- -;;; Given list l, output those tokens of l which are in odd positions - - (define odd-numbers - (lambda (l) - (if (null? l) - '() - (if (null? (cdr l)) - (list (car l)) - (cons (car l) (odd-numbers (cdr (cdr l)))))))) - -;;; --------------------------------------------------------------------- -;;; Use the procedures above to create a simple and efficient merge-sort - - (define merge-sort - (lambda (l) - (if (null? l) - l - (if (null? (cdr l)) - l - (merge-lists - (merge-sort (odd-numbers l)) - (merge-sort (even-numbers l))))))) - (define lst - (list - \"suppose\" - \"believe\" - \"changeable\" - \"absent\" - \"busy\" - \"float\" - \"debonair\" - \"throat\" - \"grey\" - \"use\" - \"measure\" - \"van\" - \"thirsty\" - \"notify\" - \"star\")) - "; - interpreter.evaluate(black_box(&warmup)).unwrap(); - let script = "(merge-sort lst)"; - c.bench_function("merge-sort", |b| { - b.iter(|| interpreter.evaluate(black_box(&script))) - }); -} +;;; Derived from the Chicken variant by Sven Hartrumpf +;;; contributed by Matthew Flatt +;;; *reset* -fn struct_construct(c: &mut Criterion) { - let mut interpreter = SteelInterpreter::new(); - // interpreter.require(PRELUDE).unwrap(); - let warmup = "(struct node (left right))"; - interpreter.evaluate(black_box(&warmup)).unwrap(); - let script = "(node (list 1 2 3 4) (list 1 2 3 4))"; - c.bench_function("struct-construct", |b| { - b.iter(|| interpreter.evaluate(black_box(&script))) - }); -} +; (require racket/cmdline) -fn struct_construct_bigger(c: &mut Criterion) { - let mut interpreter = SteelInterpreter::new(); - // interpreter.require(PRELUDE).unwrap(); - let warmup = "(struct node (left right middle back))"; - interpreter.evaluate(black_box(&warmup)).unwrap(); - let script = "(node (list 1 2 3 4) (list 1 2 3 4) (list 1 2 3 4) (list 1 2 3 4))"; - c.bench_function("struct-construct-big", |b| { - b.iter(|| interpreter.evaluate(black_box(&script))) - }); -} +(struct node (left val right)) -fn struct_get(c: &mut Criterion) { - let mut interpreter = SteelInterpreter::new(); - // interpreter.require(PRELUDE).unwrap(); - let warmup = "(struct node (left right)) (define test (node (list 1 2 3) (list 1 2 3)))"; - interpreter.evaluate(black_box(&warmup)).unwrap(); - let script = "(node-left test)"; - c.bench_function("struct-get", |b| { - b.iter(|| interpreter.evaluate(black_box(&script))) - }); -} +;; Instead of (define-struct leaf (val)): +(define (leaf val) + (node #f val #f)) +(define (leaf? l) + (not (node-left l))) +(define (leaf-val l) + node-val) -fn struct_set(c: &mut Criterion) { - let mut interpreter = SteelInterpreter::new(); - // interpreter.require(PRELUDE).unwrap(); - let warmup = "(struct node (left right)) (define test (node (list 1 2 3) (list 1 2 3)))"; - interpreter.evaluate(black_box(&warmup)).unwrap(); - let script = "(set-node-left! test (list 1 2 3))"; - c.bench_function("struct-set", |b| { - b.iter(|| interpreter.evaluate(black_box(&script))) - }); -} +(define (make item d) + (if (= d 0) + (leaf item) + (%plain-let ((item2 (* item 2)) (d2 (- d 1))) + (node (make (- item2 1) d2) item (make item2 d2))))) -// fn function_applications(c: &mut Criterion) { -// let mut interpreter = SteelInterpreter::new(); -// interpreter.require(PRELUDE).unwrap(); -// } +(define (check t) + (if (leaf? t) 1 (+ 1 (+ (check (node-left t)) (check (node-right t)))))) + +(define (iterate n m d sum) + (if (equal? n m) sum (iterate (+ n 1) m d (+ sum (check (make n d)))))) + +(define (loop d end max-depth min-depth) + (if (>= d end) + void + (begin + (let ([iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth))]) + (displayln iterations " trees of depth " d " check: " (iterate 0 iterations d 0))) + (loop (+ 2 d) end max-depth min-depth)))) + +(define (main n) + (let* ([min-depth 4] [max-depth (max (+ min-depth 2) n)]) + (let ([stretch-depth (+ max-depth 1)]) + (displayln "stretch tree of depth " stretch-depth " check: " (check (make 0 stretch-depth)))) + (let ([long-lived-tree (make 0 max-depth)]) + ; (begin + ; (define end ) + + (loop 4 (add1 max-depth) max-depth min-depth) + + ; ) -*/ + (displayln "long lived tree of depth " max-depth " check: " (check long-lived-tree))))) + + + "#, + ) + .unwrap(); + + let script = "(main 12)"; + let program = vm.emit_raw_program_no_path(script).unwrap(); + let executable = vm.raw_program_to_executable(program).unwrap(); + + let mut group = c.benchmark_group("binary-trees"); + group.bench_function("binary-trees", |b| { + b.iter(|| vm.run_executable(&executable)) + }); + group.finish(); +} criterion_group!( benches, @@ -406,12 +287,12 @@ criterion_group!( filter, ten_thousand_iterations, ten_thousand_iterations_letrec, - trie_sort_without_optimizations, - trie_sort_with_optimizations, + trie_sort, fib_28, engine_creation, register_function, multiple_transducers, + binary_trees, // fib_28_contract, ackermann // trie_sort, // merge_sort, diff --git a/crates/steel-core/build.rs b/crates/steel-core/build.rs index 4746d9309..939a6371f 100644 --- a/crates/steel-core/build.rs +++ b/crates/steel-core/build.rs @@ -7,45 +7,11 @@ fn main() { use std::fs; use std::path::Path; - use steel_gen::generate_opcode_map; - use steel_gen::OpCode::*; - let out_dir = env::var_os("OUT_DIR").unwrap(); - let dest_path = Path::new(&out_dir).join("dynamic.rs"); + let dest_path = Path::new(&out_dir).join("generated.rs"); - // TODO: Come up with better way for this to make it in - let patterns: Vec> = vec![ - vec![ - (MOVEREADLOCAL0, 0), - (LOADINT2, 225), - (SUB, 2), - (CALLGLOBAL, 1), - ], - vec![(READLOCAL0, 0), (LOADINT1, 219), (SUB, 2), (CALLGLOBAL, 1)], - vec![(READLOCAL0, 0), (LOADINT2, 225), (LTE, 2), (IF, 7)], - vec![ - (READLOCAL0, 0), - (LOADINT1, 219), - (SUB, 2), - (MOVEREADLOCAL0, 0), - (MOVEREADLOCAL1, 1), - (LOADINT1, 219), - (SUB, 2), - (CALLGLOBAL, 2), - ], - ]; + fs::write(dest_path, steel_gen::permutations::code_gen()).unwrap(); - fs::write(dest_path, generate_opcode_map(patterns)).unwrap(); + println!("cargo:rerun-if-changed=build.rs"); } - - use std::env; - use std::fs; - use std::path::Path; - - let out_dir = env::var_os("OUT_DIR").unwrap(); - let dest_path = Path::new(&out_dir).join("generated.rs"); - - fs::write(dest_path, steel_gen::permutations::code_gen()).unwrap(); - - println!("cargo:rerun-if-changed=build.rs"); } diff --git a/crates/steel-core/output.txt b/crates/steel-core/output.txt new file mode 100644 index 000000000..9aec0a27e --- /dev/null +++ b/crates/steel-core/output.txt @@ -0,0 +1,6 @@ +test range-big ... bench: 73 ns/iter (+/- 1) + +test map-big ... bench: 424146 ns/iter (+/- 1702) + +test transducer-map ... bench: 977324 ns/iter (+/- 4113) + diff --git a/crates/steel-core/src/compiler/code_gen.rs b/crates/steel-core/src/compiler/code_gen.rs index c3b9fcab0..cd663bfc8 100644 --- a/crates/steel-core/src/compiler/code_gen.rs +++ b/crates/steel-core/src/compiler/code_gen.rs @@ -606,13 +606,24 @@ impl<'a> VisitorMut for CodeGenerator<'a> { return Ok(()); } - for expr in &begin.exprs { + let (last, elements) = begin.exprs.split_last().unwrap(); + + // Just insert a single pop value from stack + // when + // for expr in &begin.exprs { + // self.visit(expr)?; + // } + + for expr in elements { self.visit(expr)?; + self.push(LabeledInstruction::builder(OpCode::POPSINGLE)); } - if begin.exprs.len() > 1 { - self.push(LabeledInstruction::builder(OpCode::POPN).payload(begin.exprs.len() - 1)); - } + self.visit(last)?; + + // if begin.exprs.len() > 1 { + // self.push(LabeledInstruction::builder(OpCode::POPN).payload(begin.exprs.len() - 1)); + // } Ok(()) } diff --git a/crates/steel-core/src/compiler/compiler.rs b/crates/steel-core/src/compiler/compiler.rs index 3ce014e60..392606b83 100644 --- a/crates/steel-core/src/compiler/compiler.rs +++ b/crates/steel-core/src/compiler/compiler.rs @@ -261,6 +261,7 @@ pub struct Compiler { opt_level: OptLevel, pub(crate) kernel: Option, memoization_table: MemoizationTable, + mangled_identifiers: HashSet, } #[derive(Serialize, Deserialize)] @@ -269,6 +270,34 @@ pub struct SerializableCompiler { pub(crate) constant_map: SerializableConstantMap, pub(crate) macro_env: HashMap, pub(crate) opt_level: OptLevel, + pub(crate) module_manager: ModuleManager, + // pub(crate) mangled_identifiers: +} + +impl SerializableCompiler { + pub(crate) fn into_compiler(self) -> Compiler { + let mut compiler = Compiler::default(); + + compiler.symbol_map = self.symbol_map; + compiler.constant_map = ConstantMap::from_serialized(self.constant_map).unwrap(); + compiler.macro_env = self.macro_env; + compiler.opt_level = self.opt_level; + compiler.module_manager = self.module_manager; + + compiler + } +} + +impl Compiler { + pub(crate) fn into_serializable_compiler(self) -> Result { + Ok(SerializableCompiler { + symbol_map: self.symbol_map, + constant_map: self.constant_map.into_serializable_map(), + macro_env: self.macro_env, + opt_level: self.opt_level, + module_manager: self.module_manager, + }) + } } impl Default for Compiler { @@ -297,6 +326,7 @@ impl Compiler { opt_level: OptLevel::Three, kernel: None, memoization_table: MemoizationTable::new(), + mangled_identifiers: HashSet::new(), } } @@ -315,6 +345,7 @@ impl Compiler { opt_level: OptLevel::Three, kernel: Some(kernel), memoization_table: MemoizationTable::new(), + mangled_identifiers: HashSet::new(), } } @@ -437,11 +468,24 @@ impl Compiler { let mut semantic = SemanticAnalysis::from_analysis(&mut expanded_statements, analysis); + // let mut table = HashSet::new(); + // This is definitely broken still semantic - // .replace_anonymous_function_calls_with_plain_lets(); - .lift_pure_local_functions(); - // .lift_all_local_functions(); + .elide_single_argument_lambda_applications() + // .lift_pure_local_functions() + // .lift_all_local_functions() + .replace_non_shadowed_globals_with_builtins( + &mut self.macro_env, + &mut self.module_manager, + &mut self.mangled_identifiers, + ) + .remove_unused_globals_with_prefix("mangler", &self.macro_env, &self.module_manager) + .lift_pure_local_functions() + .lift_all_local_functions(); + + // TODO: Just run this... on each module in particular + // .remove_unused_globals_with_prefix("mangler"); debug!("About to expand defines"); let mut expanded_statements = flatten_begins_and_expand_defines(expanded_statements); @@ -564,7 +608,7 @@ impl Compiler { path: Option, sources: &mut Sources, ) -> Result { - log::info!(target: "expansion-phase", "Expanding macros -> phase 0"); + log::debug!(target: "expansion-phase", "Expanding macros -> phase 0"); let mut expanded_statements = self.expand_expressions(exprs, path, sources, builtin_modules.clone())?; @@ -579,14 +623,14 @@ impl Compiler { ); } - log::info!(target: "expansion-phase", "Expanding macros -> phase 1"); + log::debug!(target: "expansion-phase", "Expanding macros -> phase 1"); expanded_statements = expanded_statements .into_iter() .map(|x| expand_kernel(x, self.kernel.as_mut(), builtin_modules.clone())) .collect::>>()?; - log::info!(target: "expansion-phase", "Beginning constant folding"); + log::debug!(target: "expansion-phase", "Beginning constant folding"); let mut expanded_statements = self.apply_const_evaluation(constants.clone(), expanded_statements, false)?; @@ -598,18 +642,33 @@ impl Compiler { let mut semantic = SemanticAnalysis::from_analysis(&mut expanded_statements, analysis); + // let mut table = HashSet::new(); + // This is definitely broken still semantic - // .replace_anonymous_function_calls_with_plain_lets(); - .lift_pure_local_functions(); - // .lift_all_local_functions(); + .elide_single_argument_lambda_applications() + .replace_non_shadowed_globals_with_builtins( + &mut self.macro_env, + &mut self.module_manager, + &mut self.mangled_identifiers, + ) + // TODO: To get this to work, we have to check the macros to make sure those + // are safe to eliminate. In interactive mode, we'll + // be unable to optimize those away + .remove_unused_globals_with_prefix("mangler", &self.macro_env, &self.module_manager) + .lift_pure_local_functions() + .lift_all_local_functions(); + // .remove_unused_globals_with_prefix("manglersteel/"); // debug!("About to expand defines"); - log::info!(target: "expansion-phase", "Flattening begins, converting internal defines to let expressions"); + log::debug!(target: "expansion-phase", "Flattening begins, converting internal defines to let expressions"); let mut expanded_statements = flatten_begins_and_expand_defines(expanded_statements); + // let mut expanded_statements = + // self.apply_const_evaluation(constants.clone(), expanded_statements, false)?; + let mut analysis = Analysis::from_exprs(&expanded_statements); analysis.populate_captures(&expanded_statements); @@ -630,7 +689,7 @@ impl Compiler { ); } - log::info!(target: "expansion-phase", "Expanding multiple arity functions"); + log::debug!(target: "expansion-phase", "Expanding multiple arity functions"); // TODO - make sure I want to keep this let expanded_statements = @@ -638,14 +697,36 @@ impl Compiler { log::info!(target: "expansion-phase", "Aggressive constant evaluation with memoization"); + // let expanded_statements = expanded_statements + // .into_iter() + // .flat_map(|x| { + // if let ExprKind::Begin(b) = x { + // b.exprs.into_iter() + // } else { + // vec![x].into_iter() + // } + // }) + // .collect(); + let expanded_statements = self.apply_const_evaluation(constants, expanded_statements, true)?; + // let expanded_statements = expanded_statements + // .into_iter() + // .flat_map(|x| { + // if let ExprKind::Begin(b) = x { + // b.exprs.into_iter() + // } else { + // vec![x].into_iter() + // } + // }) + // .collect(); + // TODO: // Here we're gonna do the constant evaluation pass, using the kernel for execution of the // constant functions w/ memoization: - log::info!(target: "expansion-phase", "Generating instructions"); + log::debug!(target: "expansion-phase", "Generating instructions"); let instructions = self.generate_instructions_for_executable(expanded_statements)?; diff --git a/crates/steel-core/src/compiler/constants.rs b/crates/steel-core/src/compiler/constants.rs index 14bc49c9b..345cd6fb6 100644 --- a/crates/steel-core/src/compiler/constants.rs +++ b/crates/steel-core/src/compiler/constants.rs @@ -39,6 +39,10 @@ impl ConstantMap { ConstantMap(Rc::new(RefCell::new(Vec::new()))) } + pub(crate) fn into_serializable_map(self) -> SerializableConstantMap { + SerializableConstantMap(self.to_bytes().unwrap()) + } + pub fn to_serializable_vec(&self) -> Vec { self.0 .borrow() @@ -77,9 +81,15 @@ impl ConstantMap { Ok(result.unwrap()) } + pub fn from_serialized(map: SerializableConstantMap) -> Result { + Self::from_bytes(&map.0) + } + pub fn from_bytes(encoded: &[u8]) -> Result { let str_vector: Vec = bincode::deserialize(encoded).unwrap(); + // println!("{:?}", str_vector); + str_vector .into_iter() .map(|x| { diff --git a/crates/steel-core/src/compiler/modules.rs b/crates/steel-core/src/compiler/modules.rs index 41cf4a03b..6d1b8c005 100644 --- a/crates/steel-core/src/compiler/modules.rs +++ b/crates/steel-core/src/compiler/modules.rs @@ -1,6 +1,12 @@ #![allow(unused)] use crate::{ - compiler::{passes::VisitorMutRefUnit, program::PROVIDE}, + compiler::{ + passes::{ + analysis::{Analysis, SemanticAnalysis}, + VisitorMutRefUnit, + }, + program::PROVIDE, + }, expr_list, parser::{ ast::{AstTools, Atom, Begin, Define, ExprKind, List, Quote}, @@ -38,26 +44,49 @@ use super::{ program::{CONTRACT_OUT, FOR_SYNTAX, ONLY_IN, PREFIX_IN, REQUIRE_IDENT_SPEC}, }; -const OPTION: &str = include_str!("../scheme/modules/option.scm"); -const OPTION_NAME: &str = "steel/option"; +static OPTION: &str = include_str!("../scheme/modules/option.scm"); +static OPTION_NAME: &str = "steel/option"; + +static RESULT: &str = include_str!("../scheme/modules/result.scm"); +static RESULT_NAME: &str = "steel/result"; + +static CONTRACT: &str = include_str!("../scheme/modules/contracts.scm"); +static CONTRACT_NAME: &str = "#%private/steel/contract"; + +static ITERATORS: &str = include_str!("../scheme/modules/iterators.scm"); +static ITERATORS_NAME: &str = "steel/iterators"; -const RESULT: &str = include_str!("../scheme/modules/result.scm"); -const RESULT_NAME: &str = "steel/result"; +static MUTABLE_VECTORS: &str = include_str!("../scheme/modules/mvector.scm"); +static MUTABLE_VECTORS_NAME: &str = "steel/mutable-vectors"; -// const DICT: &str = include_str!("../scheme/modules/test.rkt"); -// const TEST_NAME: &str = "std::test"; +static PRINTING: &str = include_str!("../scheme/print.scm"); +static PRINTING_NAME: &str = "#%private/steel/print"; -static BUILT_INS: &[(&str, &str)] = &[(OPTION_NAME, OPTION), (RESULT_NAME, RESULT)]; +static DYNAMIC_WIND_NAME: &str = "#%private/steel/control"; +static DYNAMIC_WIND: &str = include_str!("../scheme/modules/parameters.scm"); + +static BUILT_INS: &[(&str, &str)] = &[ + (OPTION_NAME, OPTION), + (RESULT_NAME, RESULT), + (CONTRACT_NAME, CONTRACT), + (ITERATORS_NAME, ITERATORS), + (MUTABLE_VECTORS_NAME, MUTABLE_VECTORS), + (PRINTING_NAME, PRINTING), + (DYNAMIC_WIND_NAME, DYNAMIC_WIND), +]; + +pub(crate) const MANGLER_SEPARATOR: &str = "__%#__"; /// Manages the modules /// keeps some visited state on the manager for traversal /// Also keeps track of the metadata for each file in order to determine /// if it needs to be recompiled -#[derive(Clone)] +#[derive(Clone, serde::Serialize, serde::Deserialize)] pub(crate) struct ModuleManager { compiled_modules: HashMap, file_metadata: HashMap, visited: HashSet, + custom_builtins: HashMap, } impl ModuleManager { @@ -69,13 +98,22 @@ impl ModuleManager { compiled_modules, file_metadata, visited: HashSet::new(), + custom_builtins: HashMap::new(), } } + pub fn add_builtin_module(&mut self, module_name: String, text: String) { + self.custom_builtins.insert(module_name, text); + } + pub fn modules(&self) -> &HashMap { &self.compiled_modules } + pub fn modules_mut(&mut self) -> &mut HashMap { + &mut self.compiled_modules + } + pub(crate) fn default() -> Self { Self::new(HashMap::new(), HashMap::new()) } @@ -169,7 +207,9 @@ impl ModuleManager { .require_objects .iter() .filter(|x| !x.for_syntax) - .map(|x| "mangler".to_string() + x.path.get_path().to_str().unwrap()) + .map(|x| { + "mangler".to_string() + x.path.get_path().to_str().unwrap() + MANGLER_SEPARATOR + }) .collect::>(); let mut explicit_requires = HashMap::new(); @@ -201,7 +241,8 @@ impl ModuleManager { let module = if let Some(module) = module_builder.compiled_modules.get(path.as_ref()) { module } else { - log::info!("No provides found for module, skipping: {:?}", path); + log::debug!(target: "modules", "No provides found for module, skipping: {:?}", path); + continue; }; @@ -215,7 +256,8 @@ impl ModuleManager { // Would be nice if this could be handled by some macro expansion... // See if contract/out - let other_module_prefix = "mangler".to_string() + module.name.to_str().unwrap(); + let other_module_prefix = + "mangler".to_string() + module.name.to_str().unwrap() + MANGLER_SEPARATOR; // TODO: Expand the contract out into something we expect // Otherwise, this is going to blow up @@ -243,7 +285,7 @@ impl ModuleManager { let contract = l.args.get(2).unwrap(); let hash_get = expr_list![ - ExprKind::ident("hash-get"), + ExprKind::ident("%proto-hash-get%"), ExprKind::atom( "__module-".to_string() + &other_module_prefix ), @@ -280,15 +322,7 @@ impl ModuleManager { let define = ExprKind::Define(Box::new(Define::new( owned_name, - // expr_list![ - // ExprKind::ident("bind/c"), - // contract.clone(), hash_get, - // ExprKind::Quote(Box::new(Quote::new( - // name.clone(), - // SyntaxObject::default(TokenType::Quote) - // ))), - // ], SyntaxObject::default(TokenType::Define), ))); @@ -311,7 +345,7 @@ impl ModuleManager { } let hash_get = expr_list![ - ExprKind::ident("hash-get"), + ExprKind::ident("%proto-hash-get%"), ExprKind::atom( "__module-".to_string() + &other_module_prefix ), @@ -348,15 +382,7 @@ impl ModuleManager { let define = ExprKind::Define(Box::new(Define::new( owned_name, - // expr_list![ - // ExprKind::ident("bind/c"), - // contract.clone(), hash_get, - // ExprKind::Quote(Box::new(Quote::new( - // name.clone(), - // SyntaxObject::default(TokenType::Quote) - // ))), - // ], SyntaxObject::default(TokenType::Define), ))); @@ -381,7 +407,7 @@ impl ModuleManager { } let hash_get = expr_list![ - ExprKind::ident("hash-get"), + ExprKind::ident("%proto-hash-get%"), ExprKind::atom("__module-".to_string() + &other_module_prefix), ExprKind::Quote(Box::new(Quote::new( provide.clone(), @@ -439,12 +465,20 @@ impl ModuleManager { .filter(|x| x.for_syntax) .map(|x| x.path.get_path()) { - let (module, in_scope_macros) = Self::find_in_scope_macros( + let (module, mut in_scope_macros) = Self::find_in_scope_macros( &self.compiled_modules, require_for_syntax.as_ref(), &mut mangled_asts, ); + // dbg!(&in_scope_macros); + + // for (key, value) in &mut in_scope_macros { + // for line in value.exprs_mut() { + // println!("{}", line); + // } + // } + // ast = ast.into_iter().map(|x| ) // ast.pretty_print(); @@ -466,44 +500,12 @@ impl ModuleManager { // expand(x, &module.macro_map) }) .collect::>()?; - } - - // dbg!(mangled_prefixes.len()); - // dbg!(module_statements.len()); - // println!("------------------"); - // module_statements.pretty_print(); - // println!("------------------"); - - // let duped_prefixes = mangled_prefixes - // .clone() - // .into_iter() - // .interleave(mangled_prefixes.into_iter()); - - // let mut module_statements = duped_prefixes - // .into_iter() - // .zip(module_statements.into_iter()) - // .map(|(prefix, require_define)| { - // println!("---- Unmangling: {prefix} ----"); - - // let mut expanded = expand(require_define, global_macro_map)?; - - // let mut name_unmangler = NameUnMangler::new(&prefix); - - // name_unmangler.unmangle_expr(&mut expanded); - - // println!("--- {}", expanded.to_pretty(60)); - - // Ok(expanded) - // }) - // .collect::>>()?; - - // println!("before expanding global macros"); - // println!("----------"); - // module_statements.pretty_print(); - // println!("----------"); - // Include the mangled asts in the resulting asts returned - // module_statements.append(&mut mangled_asts); + // TODO: @Matt 10/16/12 + // This won't work if the macros expand to other private macros. + // Tracking issue here: + global_macro_map.extend(in_scope_macros); + } // Include the defines from the modules now imported module_statements.append(&mut require_defines); @@ -531,7 +533,7 @@ impl ModuleManager { .get(require_for_syntax) .expect(&format!("Module missing!: {:?}", require_for_syntax)); - let prefix = "mangler".to_string() + module.name.to_str().unwrap(); + let prefix = "mangler".to_string() + module.name.to_str().unwrap() + MANGLER_SEPARATOR; let globals = collect_globals(&module.ast); @@ -589,14 +591,13 @@ impl ModuleManager { } } -#[derive(Debug, Clone)] +#[derive(Debug, Clone, serde::Serialize, serde::Deserialize)] pub struct CompiledModule { name: PathBuf, provides: Vec, - // TODO: Change this to be an ID instead of a string directly require_objects: Vec, provides_for_syntax: Vec, - macro_map: HashMap, + pub(crate) macro_map: HashMap, ast: Vec, emitted: bool, } @@ -644,7 +645,7 @@ impl CompiledModule { let mut exprs = self.ast.clone(); let mut provide_definitions = Vec::new(); - let prefix = "mangler".to_string() + self.name.to_str().unwrap(); + let prefix = "mangler".to_string() + self.name.to_str().unwrap() + MANGLER_SEPARATOR; // Now we should be able to set up a series of requires with the right style // ;; Refresh the module definition in this namespace @@ -676,7 +677,8 @@ impl CompiledModule { // println!("{:?}", modules.keys().collect::>()); let module = modules.get(path.as_ref()).unwrap(); - let other_module_prefix = "mangler".to_string() + module.name.to_str().unwrap(); + let other_module_prefix = + "mangler".to_string() + module.name.to_str().unwrap() + MANGLER_SEPARATOR; for provide_expr in &module.provides { // For whatever reason, the value coming into module.provides is an expression like: (provide expr...) @@ -730,7 +732,7 @@ impl CompiledModule { globals.insert(*name.atom_identifier().unwrap()); let hash_get = expr_list![ - ExprKind::ident("hash-get"), + ExprKind::ident("%proto-hash-get%"), ExprKind::atom( "__module-".to_string() + &other_module_prefix ), @@ -745,15 +747,7 @@ impl CompiledModule { prefix.clone() + name.atom_identifier().unwrap().resolve(), ), - // expr_list![ - // ExprKind::ident("bind/c"), - // contract.clone(), hash_get, - // ExprKind::Quote(Box::new(Quote::new( - // name.clone(), - // SyntaxObject::default(TokenType::Quote) - // ))), - // ], SyntaxObject::default(TokenType::Define), ))); @@ -811,7 +805,7 @@ impl CompiledModule { let define = ExprKind::Define(Box::new(Define::new( ExprKind::atom(prefix.clone() + provide_ident.resolve()), expr_list![ - ExprKind::ident("hash-get"), + ExprKind::ident("%proto-hash-get%"), ExprKind::atom("__module-".to_string() + &other_module_prefix), ExprKind::Quote(Box::new(Quote::new( provide.clone(), @@ -828,10 +822,6 @@ impl CompiledModule { } } } - - // exprs.push(define); - - // todo!() } } @@ -998,6 +988,17 @@ impl CompiledModule { // TODO: Perhaps mangle these as well, especially if they have contracts associated with them provide_definitions.append(&mut exprs); + // Try this out? + // let mut analysis = Analysis::from_exprs(&provide_definitions); + // let mut semantic = SemanticAnalysis::from_analysis(&mut provide_definitions, analysis); + + // // This is definitely broken still + // semantic.remove_unused_globals_with_prefix("mangler"); + // .replace_non_shadowed_globals_with_builtins() + // .remove_unused_globals_with_prefix("mangler"); + + // println!("------ {}", provide_definitions.to_pretty(60)); + Ok(ExprKind::Begin(Begin::new( provide_definitions, SyntaxObject::default(TokenType::Begin), @@ -1037,21 +1038,21 @@ impl CompiledModule { // TODO clean this up let res = ExprKind::List(List::new(body)); - if log_enabled!(target: "requires", log::Level::Info) { - info!(target: "requires", "Module ast node: {}", res.to_string()); + if log_enabled!(target: "requires", log::Level::Debug) { + debug!(target: "requires", "Module ast node: {}", res.to_string()); } res } } -#[derive(Debug, Clone, PartialEq)] +#[derive(Debug, Clone, PartialEq, serde::Serialize, serde::Deserialize)] enum MaybeRenamed { Normal(ExprKind), Renamed(ExprKind, ExprKind), } -#[derive(Debug, Clone)] +#[derive(Debug, Clone, serde::Serialize, serde::Deserialize)] pub struct RequireObject { path: PathOrBuiltIn, for_syntax: bool, @@ -1059,9 +1060,9 @@ pub struct RequireObject { prefix: Option, } -#[derive(Debug, Clone)] +#[derive(Debug, Clone, serde::Serialize, serde::Deserialize)] enum PathOrBuiltIn { - BuiltIn(&'static str), + BuiltIn(Cow<'static, str>), Path(PathBuf), } @@ -1069,7 +1070,7 @@ impl PathOrBuiltIn { pub fn get_path(&self) -> Cow<'_, PathBuf> { match self { Self::Path(p) => Cow::Borrowed(p), - Self::BuiltIn(p) => Cow::Owned(PathBuf::from(p)), + Self::BuiltIn(p) => Cow::Owned(PathBuf::from(p.to_string())), } } } @@ -1169,24 +1170,43 @@ impl<'a> ModuleBuilder<'a> { fn compile(&mut self) -> Result> { debug!(target: "requires", "Visiting: {:?}", self.name); + // @Matt - 10/3/23 + // This has a relatively fatal flaw at the moment: + /* + + (define-syntax register-plugin + (syntax-rules () + [(register-plugin plugin-path identifiers ...) + (begin + (require plugin-path + (only-in identifiers ...)) + (provide identifiers ...))])) + */ + // This will fail to compile - anything that expands into a require will fail since + // require is more or less a top level primitive. What we need to do is figure + // out a way to have this be recursive - the whole compilation step should + // go again once we discover that there is another require. It shouldn't be too bad, + // but the base case has to be figured out such that we don't get infinite recursion. + // I think the condition is probably something along the following: + // + // - Did we expand anything + // - Are there require statements + // + // If we expanded anything, we then should check for require statements... maybe + + let mut new_exprs = Vec::new(); + + // self.source_ast.pretty_print(); + self.collect_requires()?; - // let contains_provides = self.contains_provides(); self.collect_provides()?; if log_enabled!(log::Level::Info) { - info!("Requires: {:#?}", self.require_objects); - // info!("Requires for-syntax: {:?}", self.requires_for_syntax); - - info!("Provides: {:#?}", self.provides); - info!("Provides for-syntax: {:?}", self.provides_for_syntax); + debug!(target: "requires", "Requires: {:#?}", self.require_objects); + debug!(target: "requires", "Provides: {:#?}", self.provides); + debug!(target: "requires", "Provides for-syntax: {:?}", self.provides_for_syntax); } - // if self.provides.is_empty() && !self.main { - // self.visited.insert(self.name.clone()); - - // return Ok(Vec::new()); - // } - if self.visited.contains(&self.name) { stop!(Generic => format!("circular dependency found during module resolution with: {:?}", self.name)) } @@ -1209,17 +1229,11 @@ impl<'a> ModuleBuilder<'a> { } self.extract_macro_defs()?; - let mut new_exprs = Vec::new(); // TODO include built ins here if self.require_objects.is_empty() && !self.main { // We're at a leaf, put into the cache - // println!("putting {:?} in the cache", self.name); - // if !self.provides.is_empty() { new_exprs.push(self.compile_module()?); - // } else { - // println!("SKIPPING"); - // } } else { // TODO come back for parsing built ins for module in self @@ -1279,8 +1293,11 @@ impl<'a> ModuleBuilder<'a> { // ast.append(&mut module_exprs); // new_module.source_ast = ast; + // Probably want to evaluate a module even if it has no provides? if !new_module.provides.is_empty() { new_exprs.push(new_module.compile_module()?); + } else { + log::debug!(target: "requires", "Found no provides, skipping compilation of module: {:?}", new_module.name); } } @@ -1335,6 +1352,7 @@ impl<'a> ModuleBuilder<'a> { // debug!("Inside {:?} - append {:?}", self.name, module); if log_enabled!(log::Level::Debug) { debug!( + target: "modules", "appending with {:?}", module_exprs.iter().map(|x| x.to_string()).join(" SEP ") ); @@ -1348,64 +1366,46 @@ impl<'a> ModuleBuilder<'a> { // ast.append(&mut module_exprs); // new_module.source_ast = ast; + // dbg!(&new_module.name); + // dbg!(&new_module.compiled_modules.contains_key(&new_module.name)); + + // If we need to, revisit because there are new provides if !new_module.provides.is_empty() { new_exprs.push(new_module.compile_module()?); + // If the module hasn't yet been compiled, compile it anyway + } else if !new_module.compiled_modules.contains_key(&new_module.name) { + // else if !new_module.compiled_modules.contains_key(&new_module.name) { + new_exprs.push(new_module.compile_module()?); + } else { + log::debug!(target: "requires", "Found no provides, skipping compilation of module: {:?}", new_module.name); + log::debug!(target: "requires", "Module already in the cache: {}", new_module.compiled_modules.contains_key(&new_module.name)); + log::debug!(target: "requires", "Compiled modules: {:?}", new_module.compiled_modules.keys().collect::>()); } + + // else { + // log::debug!(target: "requires", "Found no provides, skipping compilation of module: {:?}", new_module.name); + // } } } - // Define the actual - - // println!("compiling: {}", self.name); - - // println!( - // "Exiting with {:?}", - // new_exprs.iter().map(|x| x.to_string()).collect::>() - // ); + // new_exprs.pretty_print(); Ok(new_exprs) } + // TODO: This should run again on itself, probably fn compile_module(&mut self) -> Result { let mut ast = std::mem::take(&mut self.source_ast); let mut provides = std::mem::take(&mut self.provides); - - // let mut ast = self.source_ast.clone(); - // let provides = self.provides.clone(); - // Clone the requires... I suppose let requires = self.require_objects.clone(); - // println!("built ins: {:?}", self.built_ins); - - // requires.append(&mut self.built_ins.clone()); - - // TODO -> qualified requires as well - // qualified requires should be able to adjust the names of the exported functions - - // for require in &self.requires { - // @Matt 10/8/22 - // Here, instead of building out the entire AST node, just insert a reference to the module at the top level - // Something like: (require ) - - // let m = self - // .compiled_modules - // .get(require) - // .unwrap() - // .to_module_ast_node(); - // requires.push(m); - // } - info!( + target: "requires", "Into compiled module: provides for syntax: {:?}", self.provides_for_syntax ); - // info!( - // "Into compiled module: requires for syntax: {:?}", - // self.requires_for_syntax - // ); - // Expand first with the macros from *this* module ast = ast .into_iter() @@ -1416,9 +1416,6 @@ impl<'a> ModuleBuilder<'a> { }) .collect::>>()?; - // @Matt - provide expansion - // TODO: Extend the provides with any provides that are yielded from the above - // Expand provides for any macros that exist within there provides = provides .into_iter() @@ -1444,8 +1441,6 @@ impl<'a> ModuleBuilder<'a> { &mut mangled_asts, ); - // ast.pretty_print(); - ast = ast .into_iter() .map(|x| { @@ -1459,14 +1454,9 @@ impl<'a> ModuleBuilder<'a> { } else { Ok(first_round_expanded) } - - // expand(x, &module.macro_map) }) .collect::>()?; - // @Matt - provide expansion - // TODO: Do the same here. Extend the provides with any provides that are yielded from the above expansion - provides = provides .into_iter() .map(|x| { @@ -1480,18 +1470,36 @@ impl<'a> ModuleBuilder<'a> { } else { Ok(first_round_expanded) } - - // expand(x, &module.macro_map) }) .collect::>()?; } + // let requires_before = self.require_objects.len(); + + // self.collect_requires()?; + + // if self.require_objects.len() > requires_before { + // println!("EXPANDED INTO A REQUIRE"); + // } + + // TODO: Check HERE for whether there are more requires than were previously found. + // If so, we should go back and compile the module again + // TODO: @Matt - fix this hack { self.source_ast = ast; self.provides = provides; + self.collect_provides(); + // let requires_before = self.require_objects.len(); + + // self.collect_requires()?; + + // if self.require_objects.len() > requires_before { + // println!("EXPANDED INTO A REQUIRE"); + // } + provides = std::mem::take(&mut self.provides); ast = std::mem::take(&mut self.source_ast); } @@ -1500,29 +1508,6 @@ impl<'a> ModuleBuilder<'a> { // then include the ast there mangled_asts.append(&mut ast); - // let duped_prefixes = mangled_prefixes - // .clone() - // .into_iter() - // .interleave(mangled_prefixes.into_iter()); - - // let mut mangled_asts = duped_prefixes - // .into_iter() - // .zip(mangled_asts.into_iter()) - // .map(|(prefix, require_define)| { - // println!("---- Unmangling: {prefix} ----"); - - // let mut expanded = expand(require_define, self.global_macro_map)?; - - // let mut name_unmangler = NameUnMangler::new(&prefix); - - // name_unmangler.unmangle_expr(&mut expanded); - - // println!("--- {}", expanded.to_pretty(60)); - - // Ok(expanded) - // }) - // .collect::>>()?; - // Take ast, expand with self modules, then expand with each of the require for-syntaxes // Then mangle the require-for-syntax, include the mangled directly in the ast @@ -1541,18 +1526,18 @@ impl<'a> ModuleBuilder<'a> { module.set_emitted(true); - // dbg!(&module); + let mut result = + module.to_top_level_module(self.compiled_modules, self.global_macro_map)?; - // let result = module.to_module_ast_node(); + // let mut analysis = Analysis::from_exprs(&[result]); - let result = module.to_top_level_module(self.compiled_modules, self.global_macro_map)?; + // let mut semantic = SemanticAnalysis::from_analysis(&mut result, analysis); - // println!( - // "Into compiled module inserted into the cache: {:?}", - // self.name - // ); + // // This is definitely broken still + // semantic + // .remove_unused_globals_with_prefix("mangler"); - // debug!("Adding {:?} to the module cache", self.name); + log::debug!(target: "requires", "Adding compiled module: {:?}", self.name); self.compiled_modules.insert(self.name.clone(), module); @@ -1708,7 +1693,7 @@ impl<'a> ModuleBuilder<'a> { if let Some(lib) = BUILT_INS.iter().find(|x| x.0 == s.as_str()) { // self.built_ins.push(PathBuf::from(lib.0)); - require_object.path = Some(PathOrBuiltIn::BuiltIn(lib.0)); + require_object.path = Some(PathOrBuiltIn::BuiltIn(lib.0.into())); return Ok(()); // continue; @@ -1813,25 +1798,35 @@ impl<'a> ModuleBuilder<'a> { } if let Some(path) = l.args[1].string_literal() { - let mut current = self.name.clone(); - if current.is_file() { - current.pop(); - } - current.push(path); + if let Some(lib) = BUILT_INS.iter().find(|x| x.0 == path) { + // self.built_ins.push(PathBuf::from(lib.0)); - if !current.exists() { - if let Some(mut home) = home.clone() { - home.push(path); - current = home; + require_object.path = Some(PathOrBuiltIn::BuiltIn(lib.0.into())); + require_object.for_syntax = true; - log::info!("Searching STEEL_HOME for {:?}", current); - } else { - stop!(Generic => format!("Module not found: {:?}", self.name)) + return Ok(()); + // continue; + } else { + let mut current = self.name.clone(); + if current.is_file() { + current.pop(); } - } + current.push(path); + + if !current.exists() { + if let Some(mut home) = home.clone() { + home.push(path); + current = home; - require_object.for_syntax = true; - require_object.path = Some(PathOrBuiltIn::Path(current)); + log::info!("Searching STEEL_HOME for {:?}", current); + } else { + stop!(Generic => format!("Module not found: {:?}", self.name)) + } + } + + require_object.for_syntax = true; + require_object.path = Some(PathOrBuiltIn::Path(current)); + } } else { stop!(BadSyntax => "for-syntax expects a string literal referring to a file or module"; r.location.span; r.location.source.clone()); } @@ -1895,23 +1890,6 @@ impl<'a> ModuleBuilder<'a> { walk(self, &home, &mut exprs_without_requires, exprs)?; - // for expr in exprs { - // match &expr { - // // Include require/for-syntax here - // // This way we have some understanding of what dependencies a file has - // ExprKind::Require(r) => { - // for atom in &r.modules { - // let require_object = self.parse_require_object(&home, r, atom)?; - - // self.require_objects.push(require_object); - // } - // } - // _ => exprs_without_requires.push(expr), - // } - // } - - // println!("Exprs without requires: {:?}", exprs_without_requires); - self.source_ast = exprs_without_requires; Ok(()) } @@ -2006,10 +1984,18 @@ impl<'a> ModuleBuilder<'a> { fn parse_from_path(mut self) -> Result { log::info!("Opening: {:?}", self.name); - let mut file = std::fs::File::open(&self.name)?; + let mut file = std::fs::File::open(&self.name).map_err(|err| { + let mut err = crate::SteelErr::from(err); + err.prepend_message(&format!("Attempting to load module from: {:?}", self.name)); + err + })?; self.file_metadata .insert(self.name.clone(), file.metadata()?.modified()?); - let mut exprs = String::new(); + + // TODO: DEFAULT MODULE LOADER PREFIX + // let mut exprs = String::new(); + + let mut exprs = PRELUDE_STRING.to_string(); // Add the modules here: @@ -2034,6 +2020,12 @@ impl<'a> ModuleBuilder<'a> { Ok(self) } - - // fn search_index } + +// pub static PRELUDE_STRING: &str = ""; + +pub static PRELUDE_STRING: &str = "(require-builtin steel/base) +(require \"#%private/steel/contract\" (for-syntax \"#%private/steel/contract\")) +(require \"#%private/steel/print\") +(require \"#%private/steel/control\" (for-syntax \"#%private/steel/control\")) +"; diff --git a/crates/steel-core/src/compiler/passes/analysis.rs b/crates/steel-core/src/compiler/passes/analysis.rs index 4be690e8f..0b8462f22 100644 --- a/crates/steel-core/src/compiler/passes/analysis.rs +++ b/crates/steel-core/src/compiler/passes/analysis.rs @@ -4,12 +4,13 @@ use std::{ }; use im_rc::HashMap as ImmutableHashMap; -// use itertools::Itertools; use quickscope::ScopeMap; use crate::{ + compiler::modules::{ModuleManager, MANGLER_SEPARATOR}, parser::{ ast::{Atom, Define, ExprKind, LambdaFunction, Let, List, Quote}, + expander::SteelMacro, interner::InternedString, parser::{RawSyntaxObject, SyntaxObject, SyntaxObjectId}, span::Span, @@ -57,6 +58,7 @@ pub struct SemanticInformation { pub captured_from_enclosing: bool, pub heap_offset: Option, pub read_heap_offset: Option, + pub is_shadowed: bool, } impl SemanticInformation { @@ -79,6 +81,7 @@ impl SemanticInformation { captured_from_enclosing: false, heap_offset: None, read_heap_offset: None, + is_shadowed: false, } } @@ -311,6 +314,8 @@ impl Analysis { ); if define.is_a_builtin_definition() { + println!("FOUND A BUILTIN: {}", name); + semantic_info.mark_builtin(); } @@ -320,7 +325,7 @@ impl Analysis { semantic_info = semantic_info.shadows(shadowed_var.id) } - log::info!("Defining global: {:?}", define.name); + log::trace!("Defining global: {:?}", define.name); define_var(scope, define); self.insert(define.name.atom_syntax_object().unwrap(), semantic_info); @@ -337,11 +342,20 @@ impl Analysis { self.visit_top_level_define_function_without_body(&mut scope, define); } } + + if let ExprKind::Begin(b) = expr { + for expr in &b.exprs { + if let ExprKind::Define(define) = expr { + if define.body.lambda_function().is_some() { + self.visit_top_level_define_function_without_body(&mut scope, define); + } + } + } + } } for expr in exprs { let mut pass = AnalysisPass::new(self, &mut scope); - // pass.visit(expr); if let ExprKind::Define(define) = expr { if define.body.lambda_function().is_some() { @@ -352,7 +366,6 @@ impl Analysis { // Continue with the rest of the body here pass.visit(&define.body); pass.defining_context = None; - // pass.defining_context_depth = 0; } else { pass.visit_top_level_define_value_without_body(define); pass.visit(&define.body); @@ -361,8 +374,6 @@ impl Analysis { pass.visit(expr); } } - - // log::info!("Global scope: {:?}", scope.iter_top().collect::>()); } pub fn get_function_info(&self, function: &LambdaFunction) -> Option<&FunctionInformation> { @@ -576,15 +587,34 @@ impl<'a> AnalysisPass<'a> { // If this variable name is already in scope, we should mark that this variable // shadows the previous id if let Some(shadowed_var) = self.scope.get(name) { - semantic_info = semantic_info.shadows(shadowed_var.id) + // println!("FOUND SHADOWED VAR: {}", name); + + semantic_info = semantic_info.shadows(shadowed_var.id); + + if let Some(existing_analysis) = self.info.info.get_mut(&shadowed_var.id) { + if existing_analysis.builtin { + // println!("FOUND A VALUE THAT SHADOWS AN EXISTING BUILTIN: {}", name); + + existing_analysis.is_shadowed = true; + } + // else { + // println!("DOES NOT SHADOW A BUILT IN: {}", name); + // } + } } if define.is_a_builtin_definition() { + // println!("FOUND A BUILTIN: {}", name); + semantic_info.mark_builtin(); } + // if let Some(shadowed_var) = self.scope.get(name) { + // semantic_info = semantic_info.shadows(shadowed_var.id) + // } + if let Some(aliases) = define.is_an_alias_definition() { - log::info!( + log::debug!( "Found definition that aliases - {} aliases {}: {:?} -> {:?}", define.name, define.body, @@ -594,7 +624,7 @@ impl<'a> AnalysisPass<'a> { semantic_info = semantic_info.aliases_to(aliases); } - log::info!("Defining global: {:?}", define.name); + log::trace!("Defining global: {:?}", define.name); define_var(self.scope, define); self.info.insert(name_syntax_object, semantic_info); @@ -625,8 +655,8 @@ impl<'a> AnalysisPass<'a> { // If this variable name is already in scope, we should mark that this variable // shadows the previous id if let Some(shadowed_var) = self.scope.get(name) { - log::warn!("Redefining previous variable: {:?}", name); - semantic_info = semantic_info.shadows(shadowed_var.id) + log::debug!("Redefining previous variable: {:?}", name); + semantic_info = semantic_info.shadows(shadowed_var.id); } define_var(self.scope, define); @@ -639,11 +669,6 @@ impl<'a> AnalysisPass<'a> { // and also defaulting them to be local identifiers. This way, in the event of a set! // we have something to refer to fn visit_func_args(&mut self, lambda_function: &LambdaFunction, depth: usize) { - // let function_info = self - // .info - // .function_info - // .get(&lambda_function.syntax_object_id); - let alloc_capture_count = self .info .function_info @@ -724,7 +749,6 @@ impl<'a> AnalysisPass<'a> { let arguments = self .scope .iter_top() - // .cloned() .map(|x| (x.0.clone(), x.1.clone())) .collect::>(); @@ -743,39 +767,21 @@ impl<'a> AnalysisPass<'a> { for var in &lambda_function.args { let ident = var.atom_identifier().unwrap(); - // let mut heap_offset = None; - // let mut read_heap_offset = None; - let kind = if let Some(info) = captured_vars.get(ident) { if info.mutated { - // heap_offset = info.heap_offset; - // read_heap_offset = info.read_heap_offset; - IdentifierStatus::HeapAllocated } else { IdentifierStatus::Captured } } else if let Some(info) = self.info.get(var.atom_syntax_object().unwrap()) { match info.kind { - IdentifierStatus::HeapAllocated => { - // heap_offset = info.heap_offset; - // read_heap_offset = info.read_heap_offset; - - IdentifierStatus::HeapAllocated - } - // IdentifierStatus::Captured => IdentifierStatus::Captured, + IdentifierStatus::HeapAllocated => IdentifierStatus::HeapAllocated, _ => IdentifierStatus::Local, } } else { IdentifierStatus::Local }; - // let kind = if captured_vars.contains_key(ident) { - // IdentifierStatus::Captured - // } else { - // IdentifierStatus::Local - // }; - let mut semantic_info = SemanticInformation::new(kind, depth, var.atom_syntax_object().unwrap().span); @@ -786,14 +792,9 @@ impl<'a> AnalysisPass<'a> { if count == 0 { // TODO: Emit warning with the span - log::warn!("Found unused argument: {:?}", ident); + log::debug!("Found unused argument: {:?}", ident); } - // if kind == IdentifierStatus::HeapAllocated { - // semantic_info = semantic_info.with_heap_offset(heap_offset.unwrap()); - // semantic_info = semantic_info.with_read_heap_offset(read_heap_offset.unwrap()); - // } - semantic_info = semantic_info.with_usage_count(count); // If this variable name is already in scope, we should mark that this variable @@ -802,10 +803,6 @@ impl<'a> AnalysisPass<'a> { semantic_info = semantic_info.shadows(shadowed_var.id) } - // if let Some(info) = self.info.get(&var.atom_syntax_object().unwrap()) { - // println!("{:#?}", info); - // } - self.info .update_with(var.atom_syntax_object().unwrap(), semantic_info); } @@ -860,25 +857,11 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { // the function call. let stack_offset = self.stack_offset; - // let mut last_used_vars = HashSet::new(); - - // // Find each variable that is actually referenced in this tail position - // // let mut last_used_vars = HashSet::new(); - // std::mem::swap( - // &mut self.ids_referenced_in_tail_position, - // &mut last_used_vars, - // ); - for expr in &l.args[1..] { self.escape_analysis = true; - // self.stack_offset += 1; self.visit(expr); - // println!("Stack offset: {:?}", self.stack_offset); - self.stack_offset += 1; - // println!("Visiting argument: {}", expr); - // self.escape_analysis = true; } if !l.is_empty() { @@ -889,21 +872,9 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { self.escape_analysis = false; } - // println!( - // "Visiting argument: {}, with tail call eligibility: {} and escape: {}", - // &l.args[0], self.tail_call_eligible, self.escape_analysis - // ); - self.visit(&l.args[0]); } - // std::mem::swap( - // &mut self.ids_referenced_in_tail_position, - // &mut last_used_vars, - // ); - - // self.ids_referenced_in_tail_position = HashSet::new(); - self.stack_offset = stack_offset; self.tail_call_eligible = eligibility; self.escape_analysis = escape; @@ -915,16 +886,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { if !l.is_empty() { // Mark the call site - see what happens let mut call_site_kind = if eligibility && self.scope.depth() > 1 { - // Update the last usage of any of these variables now... - // TODO: This doesn't seem like it will work. - // for id in self.scope.iter().map(|x| x.1).filter_map(|x| x.last_used) { - // self.info.get_mut(&id).unwrap().last_usage = true; - // } - - // for id in last_used_vars { - // self.info.get_mut(&id).unwrap().last_usage = true; - // } - CallKind::TailCall } else { CallKind::Normal @@ -976,7 +937,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { } let last = begin.exprs.len() - 1; - // let stack_offset = self.stack_offset; // TODO: Clean up this bad pattern let eligibility = self.tail_call_eligible; @@ -1008,7 +968,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { } self.tail_call_eligible = false; - // self.stack_offset += 1; } // Overall, 1 for the total @@ -1018,7 +977,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { } self.tail_call_eligible = eligibility; - // self.stack_offset = stack_offset } #[allow(dead_code, unused)] @@ -1059,7 +1017,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { for arg in l.local_bindings() { let name = arg.atom_identifier().unwrap(); let id = arg.atom_syntax_object().unwrap().syntax_object_id; - // println!("Inserting local: {:?} at offset: {}", arg, stack_offset); let heap_alloc = if let Some(info) = self.info.let_info.get(&l.syntax_object_id) { if let Some(info) = info.arguments.get(name) { @@ -1157,7 +1114,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { { // TODO: see if this was necessary if function_info.escapes { - // println!("Function escapes!"); self.defining_context = None; } @@ -1178,9 +1134,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { // So for now, we sort by id, then map these directly to indices that will live in the // corresponding captured closure for (index, (key, value)) in sorted_vars.iter_mut().enumerate() { - // value.capture_offset = Some(index); - // value.read_capture_offset = Some(index); - // If we've already captured this variable, mark it as being captured from the enclosing environment // TODO: If there is shadowing, this might not work? if let Some(captured_var) = self.captures.get(key) { @@ -1191,11 +1144,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { // notion that this is a fresh variable // if let Some(analysis) = self.captures.contains_key_at_top(key) { if self.captures.depth_of(key).unwrap() > 1 { - // todo!() - - // if analysis.shadows.is_some() { - // println!("Found a shadowed var!: {}", key); - value.capture_offset = Some(index); value.read_capture_offset = Some(index); let mut value = value.clone(); @@ -1204,7 +1152,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { self.captures.define(key.clone(), value); continue; - // } } value.capture_offset = captured_var.read_capture_offset; @@ -1214,9 +1161,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { let mut value = value.clone(); value.captured_from_enclosing = true; - // println!("Marking var as captured from the enclosing: {}", key); - // println!("value: {:#?}", value); - self.captures.define(key.clone(), value) } else { value.capture_offset = Some(index); @@ -1234,8 +1178,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { vars.iter_mut().filter(|x| x.1.mutated).collect::>(); captured_and_mutated.sort_by_key(|x| x.1.id); - // println!("Captured and mutated: {:?}", captured_and_mutated); - for (index, (key, value)) in captured_and_mutated.iter_mut().enumerate() { // value.heap_offset = Some(index); @@ -1261,8 +1203,8 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { // i.e. heap offset just patches in the read offset from the parent value.heap_offset = self.captures.get(key).and_then(|x| x.read_heap_offset); - value.read_heap_offset = - self.captures.get(key).and_then(|x| x.read_heap_offset); + // value.read_heap_offset = + // self.captures.get(key).and_then(|x| x.read_heap_offset); value.read_heap_offset = Some(index); @@ -1291,14 +1233,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { } } - // Before we enter this, these are all of the variables that should be reset after capturing - // let uncaptured_from_latest_layer: HashSet = self - // .scope - // .iter_top() - // .filter(|x| x.1.captured) - // .map(|x| x.0.clone()) - // .collect(); - // We're entering a new scope since we've entered a lambda function self.scope.push_layer(); @@ -1314,21 +1248,9 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { self.defining_context_depth += 1; - // Try to extract the actual variables that are used - // Otherwise, we're capturing an insane amount of extra variables - // let mut used_vars = im_rc::HashSet::new(); - - // Save the state of things that have been used on the way down - // let mut overall_used_down = self.vars_used.clone(); - // Set the single used to this scope to be a new set self.vars_used = im_rc::HashSet::new(); - // std::mem::swap(&mut self.vars_used, &mut used_vars); - - // These are the possible captures that _could_ happen - // let possible_captures = self.get_possible_captures(&let_level_bindings); - self.contains_lambda_func = false; // TODO: Better abstract this pattern - perhaps have the function call be passed in? @@ -1338,11 +1260,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { self.contains_lambda_func = true; - // Put it back - // std::mem::swap(&mut self.vars_used, &mut used_vars); - - // self.vars_used += used_vars.clone(); - for var in &self.vars_used { self.total_vars_used.insert(var.clone()); } @@ -1356,16 +1273,15 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { // Perhaps take the diff of the vars before visiting this, and after? Then reset the state after visiting this tree? let mut captured_vars = self.get_captured_vars(&let_level_bindings); - // println!("{:?}", ) - for (var, value) in self.captures.iter() { if let Some(scope_info) = captured_vars.get_mut(var) { scope_info.captured_from_enclosing = value.captured_from_enclosing; } } - log::info!("Captured variables: {:?}", captured_vars); - // println!("Captured variables: {:?}", captured_vars); + if log::log_enabled!(log::Level::Trace) { + log::trace!("Captured variables: {:?}", captured_vars); + } // Get the arguments to get the counts // Pop the layer here - now, we check if any of the arguments below actually already exist @@ -1375,8 +1291,6 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { // Pop off of the captures self.captures.pop_layer(); - // println!("Captures: {:#?}", self.captures.iter().collect::>()); - // Mark the last usage of the variable after the values go out of scope // TODO: This should get moved to every tail call -> if its a tail call, mark // the last usage of the variables there. That way, all exit points of the function @@ -1475,7 +1389,7 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { // var.refers } else { - log::warn!("Unable to find var: {name} in info map to update to set!"); + log::debug!("Unable to find var: {name} in info map to update to set!"); } } else { log::debug!("Variable not yet in scope: {name}"); @@ -1514,6 +1428,10 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { .with_usage_count(1) .refers_to(global_var.id); + // if self.info.info.get(&global_var.id).unwrap().builtin { + // println!("FOUND USAGE OF BUILTIN: {}", ident); + // } + // TODO: We _really_ should be providing the built-ins in a better way thats not // passing around a thread local if crate::steel_vm::primitives::PRELUDE_MODULE @@ -1557,7 +1475,7 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { if let Some(stack_offset) = mut_ref.stack_offset { semantic_info = semantic_info.with_offset(stack_offset); } else { - log::warn!("Stack offset missing from local define") + log::debug!("Stack offset missing from local define") } if mut_ref.captured && mut_ref.mutated { @@ -1639,14 +1557,14 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { // semantic_info = semantic_info.with_heap_offset(heap_offset); semantic_info = semantic_info.with_read_heap_offset(heap_offset); } else { - log::warn!("Stack offset missing from local define") + log::debug!("Stack offset missing from local define") } if let Some(heap_offset) = captured.heap_offset { // semantic_info = semantic_info.with_heap_offset(heap_offset); semantic_info = semantic_info.with_heap_offset(heap_offset); } else { - log::warn!("Stack offset missing from local define") + log::debug!("Stack offset missing from local define") } // if semantic_info.kind == IdentifierStatus::HeapAllocated @@ -1700,7 +1618,7 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { if let Some(stack_offset) = is_captured.stack_offset { semantic_info = semantic_info.with_offset(stack_offset); } else { - log::warn!("Stack offset missing from local define") + log::debug!("Stack offset missing from local define") } // println!("Variable {} refers to {}", ident, is_captured.id); @@ -1710,43 +1628,69 @@ impl<'a> VisitorMutUnitRef<'a> for AnalysisPass<'a> { return; } - let mut semantic_info = - SemanticInformation::new(IdentifierStatus::Free, depth, a.syn.span); + // TODO: Check if we've already marked it as free - also count its usage! - // TODO: We _really_ should be providing the built-ins in a better way thats not - // passing around a thread local - if crate::steel_vm::primitives::PRELUDE_MODULE.with(|x| x.contains(ident.resolve())) { - semantic_info.mark_builtin(); - semantic_info.kind = IdentifierStatus::Global + if let Some(analysis) = self.info.info.get_mut(&a.syn.syntax_object_id) { + analysis.usage_count += 1; + } else { + let mut semantic_info = + SemanticInformation::new(IdentifierStatus::Free, depth, a.syn.span); + + // TODO: We _really_ should be providing the built-ins in a better way thats not + // passing around a thread local + if crate::steel_vm::primitives::PRELUDE_MODULE.with(|x| x.contains(ident.resolve())) + { + semantic_info.mark_builtin(); + semantic_info.kind = IdentifierStatus::Global + } + + // Otherwise, we've hit a free variable at this point + // TODO: WE don't need to do this? + self.info.insert(&a.syn, semantic_info); } - // Otherwise, we've hit a free variable at this point - self.info.insert(&a.syn, semantic_info); + // let mut semantic_info = + // SemanticInformation::new(IdentifierStatus::Free, depth, a.syn.span); + + // // TODO: We _really_ should be providing the built-ins in a better way thats not + // // passing around a thread local + // if crate::steel_vm::primitives::PRELUDE_MODULE.with(|x| x.contains(ident.resolve())) { + // semantic_info.mark_builtin(); + // semantic_info.kind = IdentifierStatus::Global + // } + + // // Otherwise, we've hit a free variable at this point + // // TODO: WE don't need to do this? + // self.info.insert(&a.syn, semantic_info); - // log::warn!("Found free var: {}", a); + // println!("Free identifier: {}", a); } } } impl<'a> VisitorMutUnitRef<'a> for Analysis { fn visit_atom(&mut self, a: &'a crate::parser::ast::Atom) { - log::info!( - "Id: {:?}, Atom: {:?}, Semantic Information: {:?}", - a.syn.syntax_object_id, - a.syn.ty, - self.get(&a.syn) - ); + if log::log_enabled!(log::Level::Trace) { + log::trace!( + "Id: {:?}, Atom: {:?}, Semantic Information: {:?}", + a.syn.syntax_object_id, + a.syn.ty, + self.get(&a.syn) + ); + } } fn visit_lambda_function(&mut self, lambda_function: &'a crate::parser::ast::LambdaFunction) { for arg in &lambda_function.args { if let Some(arg) = arg.atom_syntax_object() { - log::info!( - "Id: {:?}, Atom in function argument: {:?}, Semantic Information: {:?}", - arg.syntax_object_id, - arg.ty, - self.get(arg) - ); + if log::log_enabled!(log::Level::Trace) { + log::trace!( + "Id: {:?}, Atom in function argument: {:?}, Semantic Information: {:?}", + arg.syntax_object_id, + arg.ty, + self.get(arg) + ); + } } } @@ -1769,7 +1713,7 @@ pub fn query_top_level_define>( } if found_defines.len() > 1 { - log::info!( + log::debug!( "Multiple defines found, unable to find one unique value to associate with a name" ); return None; @@ -2032,7 +1976,7 @@ where if let ExprKind::Let(_) = &let_expr { if (self.func)(self.analysis, let_expr) { - log::info!("Modified let expression"); + log::debug!("Modified let expression"); } } } @@ -2084,7 +2028,7 @@ where // In the state of the analysis if (self.func)(self.analysis, list) { // return self.visit(list); - log::info!("Modified anonymous function call site!"); + log::debug!("Modified anonymous function call site!"); } } } @@ -2252,6 +2196,21 @@ impl<'a> VisitorMutUnitRef<'a> for UnusedArguments<'a> { } } +/// Takes functions that have one argument that is used one time, and inline the function +/// body and replace the call site. +// struct InlineFunctionsWithArgumentsUsedOnce<'a> { +// analysis: &'a Analysis, +// functions_to_inline: FxHashMap, +// } + +// struct FunctionInliner { +// variable_to_substitute: ExprKind, +// } + +// impl FunctionInliner { + +// } + // TODO: If its _not_ a pure function, we need to both assert that the function // does not escape, and then find the captured arguments, assert that those also // are immutable captures, and then modify the callsites to pass in those variables @@ -2300,8 +2259,19 @@ impl<'a> VisitorMutRefUnit for LiftPureFunctionsToGlobalScope<'a> { return; } + for arg in info.arguments().values() { + if arg.mutated { + return; + } + } + // If we have no captured variables, this is a pure function for our purposes if info.captured_vars.is_empty() { + // TODO: If the function is of the shape: + // (lambda (x) (function-call x)) + // Don't lift - just replace the lambda with the body, and replace the argument + // with the right thing + // Name the closure something mangled, but something we can refer to later let constructed_name = "##__lifted_pure_function".to_string() + l.syntax_object_id.to_string().as_ref(); @@ -2348,6 +2318,86 @@ impl<'a> VisitorMutRefUnit for LiftPureFunctionsToGlobalScope<'a> { } } +struct ElideSingleArgumentLambdaApplications<'a> { + analysis: &'a Analysis, + re_run_analysis: bool, +} + +impl<'a> VisitorMutRefUnit for ElideSingleArgumentLambdaApplications<'a> { + fn visit(&mut self, expr: &mut ExprKind) { + match expr { + ExprKind::If(f) => self.visit_if(f), + ExprKind::Define(d) => self.visit_define(d), + ExprKind::LambdaFunction(l) => self.visit_lambda_function(l), + ExprKind::Begin(b) => self.visit_begin(b), + ExprKind::Return(r) => self.visit_return(r), + ExprKind::Quote(q) => self.visit_quote(q), + ExprKind::Macro(m) => self.visit_macro(m), + ExprKind::Atom(a) => self.visit_atom(a), + application @ ExprKind::List(_) => { + if let ExprKind::List(l) = application { + for expr in &mut l.args { + self.visit(expr); + } + + if !l.is_anonymous_function_call() { + return; + } + + if l.args.len() != 2 { + return; + } + + if l.args[1].atom_identifier().is_none() { + return; + } + + let mut replacement: Option = None; + + if let ExprKind::LambdaFunction(lf) = &l.args[0] { + if lf.args.len() != 1 { + return; + } + + if let Some(info) = self.analysis.get_function_info(&lf) { + for arg in info.arguments().values() { + if arg.mutated { + return; + } + } + + if !info.captured_vars.is_empty() { + return; + } + + if let ExprKind::List(lst) = &lf.body { + if lst.len() == 2 + && lst.args[0].atom_identifier().is_some() + && lst.args[1].atom_identifier() == lf.args[0].atom_identifier() + { + self.re_run_analysis = true; + + replacement = Some(lst.args[0].clone()); + } + } + } + } else { + unreachable!(); + } + + if let Some(replacement) = replacement { + l.args[0] = replacement; + } + } + } + ExprKind::SyntaxRules(s) => self.visit_syntax_rules(s), + ExprKind::Set(s) => self.visit_set(s), + ExprKind::Require(r) => self.visit_require(r), + ExprKind::Let(l) => self.visit_let(l), + } + } +} + struct LiftLocallyDefinedFunctions<'a> { analysis: &'a Analysis, lifted_functions: Vec, @@ -2384,14 +2434,40 @@ impl<'a> VisitorMutRefUnit for LiftLocallyDefinedFunctions<'a> { if ident_info.depth > 1 { if !info.captured_vars.is_empty() { - log::info!( - target: "lambda-lifting", - "Found a local function which captures variables: {} - captures vars: {:#?}", - define.name, - info.captured_vars - ); + if log::log_enabled!(log::Level::Trace) { + log::trace!( + target: "lambda-lifting", + "Found a local function which captures variables: {} - captures vars: {:#?}", + define.name, + info.captured_vars + ); + } + + for (var, _) in info.captured_vars() { + log::debug!(target: "lambda-lifting", "{}", var.resolve()); + } + + if info.captured_vars().len() == 1 { + // TODO: Check if the number of captured vars is 1, and if that 1 is equivalent to the + // define name. If it is, then we should just mark this as a pure local function, because + // then we can lift it and be happy about it! + + for (_, info) in info.captured_vars() { + if info.id == define.name_id().unwrap() { + log::trace!(target: "lambda-lifting", "Local define where it only captures itself!"); + + functions.push(( + index, + define.name.atom_identifier().unwrap().to_string(), + define.name_id().unwrap(), + )); + } + } + } + + // println!("{}", define.body); } else { - log::info!(target: "lambda-lifting", "Found a pure local function: {}", define.name); + log::trace!(target: "lambda-lifting", "Found a pure local function: {}", define.name); functions.push(( index, define.name.atom_identifier().unwrap().to_string(), @@ -2423,6 +2499,119 @@ impl<'a> VisitorMutRefUnit for LiftLocallyDefinedFunctions<'a> { } } +struct CollectReferences { + idents: fxhash::FxHashSet, +} + +impl<'a> VisitorMutUnitRef<'a> for CollectReferences { + fn visit_atom(&mut self, a: &'a Atom) { + if let TokenType::Identifier(ident) = a.syn.ty { + if ident.resolve().starts_with("mangler") { + self.idents.insert(ident); + } + } + } +} + +struct ReplaceBuiltinUsagesInsideMacros<'a> { + identifiers_to_replace: &'a mut HashSet, +} + +impl<'a> VisitorMutRefUnit for ReplaceBuiltinUsagesInsideMacros<'a> { + fn visit_define(&mut self, define: &mut Define) { + self.visit(&mut define.body); + } + + fn visit_atom(&mut self, a: &mut Atom) { + if let Some(ident) = a.ident_mut() { + // println!("CHECKING: {}", ident); + + if self.identifiers_to_replace.contains(ident) { + if let Some((_, builtin_name)) = ident.resolve().split_once(MANGLER_SEPARATOR) { + // println!("RENAMING: {}", ident); + + *ident = ("#%prim.".to_string() + builtin_name).into(); + } + } + } + } +} + +struct ReplaceBuiltinUsagesWithReservedPrimitiveReferences<'a> { + analysis: &'a Analysis, + identifiers_to_replace: &'a mut HashSet, +} + +impl<'a> ReplaceBuiltinUsagesWithReservedPrimitiveReferences<'a> { + pub fn new( + analysis: &'a Analysis, + identifiers_to_replace: &'a mut HashSet, + ) -> Self { + Self { + analysis, + identifiers_to_replace, + } + } +} + +impl<'a> VisitorMutRefUnit for ReplaceBuiltinUsagesWithReservedPrimitiveReferences<'a> { + #[inline] + fn visit_define(&mut self, define: &mut Define) { + // Don't visit the name! + self.visit(&mut define.body); + } + + fn visit_atom(&mut self, a: &mut Atom) { + if let Some(info) = self.analysis.get(&a.syn) { + if info.builtin && !info.is_shadowed && info.shadows.is_none() { + // todo!() + + // println!("FOUND UNSHADOWED USAGE OF BUILTIN: {}", a); + + if let Some(ident) = a.ident_mut() { + if let Some((_, builtin_name)) = ident.resolve().split_once(MANGLER_SEPARATOR) { + // let original = *ident; + + self.identifiers_to_replace.insert(*ident); + + *ident = ("#%prim.".to_string() + builtin_name).into(); + + // println!("top level - MUTATED IDENT TO BE: {} -> {}", original, ident); + } + } + } else { + // Check if this _refers_ to a builtin + + if let Some(refers_to) = info.refers_to { + if let Some(info) = self.analysis.info.get(&refers_to) { + if info.builtin && !info.is_shadowed && info.shadows.is_none() { + // todo!() + + // println!("FOUND UNSHADOWED USAGE OF BUILTIN: {}", a); + + if let Some(ident) = a.ident_mut() { + if let Some((_, builtin_name)) = + ident.resolve().split_once(MANGLER_SEPARATOR) + { + // let original = *ident; + + self.identifiers_to_replace.insert(*ident); + + *ident = ("#%prim.".to_string() + builtin_name).into(); + + // println!("MUTATED IDENT TO BE: {} -> {}", original, ident); + + // println!("{:#?}", info); + } + } + } + } + } + } + } + } +} + struct ExprContainsIds<'a> { analysis: &'a Analysis, ids: &'a HashSet, @@ -2555,14 +2744,37 @@ impl<'a> FunctionCallCollector<'a> { should_mangle, }; + // TODO: @Matt - This needs to get the for expr in exprs.iter() { - if let ExprKind::Define(define) = expr { - if let ExprKind::LambdaFunction(_) = &define.body { - let name = define.name.atom_identifier().unwrap().clone(); + match expr { + ExprKind::Define(define) => { + if let ExprKind::LambdaFunction(_) = &define.body { + let name = define.name.atom_identifier().unwrap().clone(); - collector.functions.entry(name).or_default(); + collector.functions.entry(name).or_default(); + } } + ExprKind::Begin(b) => { + for expr in &b.exprs { + if let ExprKind::Define(define) = expr { + if let ExprKind::LambdaFunction(_) = &define.body { + let name = define.name.atom_identifier().unwrap().clone(); + + collector.functions.entry(name).or_default(); + } + } + } + } + _ => {} } + + // if let ExprKind::Define(define) = expr { + // if let ExprKind::LambdaFunction(_) = &define.body { + // let name = define.name.atom_identifier().unwrap().clone(); + + // collector.functions.entry(name).or_default(); + // } + // } } for expr in exprs { @@ -2694,8 +2906,6 @@ impl<'a> SemanticAnalysis<'a> { // Takes the function call, and inlines it at the call sites. In theory, with constant evaluation and // dead code elimination, this should help streamline some of the more complex cases. This is also just a start. pub fn inline_function_call>(&mut self, name: A) -> Result<(), SteelErr> { - // find_call_sites_and_mutate_with - // TODO: Cloning here is expensive. We should strive to make these trees somehow share the nodes a bit more elegantly. // As it stands, each time we close a syntax tree, we're going to do a deep clone of the whole thing, which we really don't // want to do. @@ -2761,7 +2971,7 @@ impl<'a> SemanticAnalysis<'a> { *self.exprs = lifter.lifted_functions; - log::info!("Re-running the analysis after lifting local functions"); + log::debug!("Re-running the analysis after lifting local functions"); self.analysis = Analysis::from_exprs(self.exprs); self.analysis.populate_captures(self.exprs); } @@ -2769,6 +2979,213 @@ impl<'a> SemanticAnalysis<'a> { self } + pub(crate) fn replace_non_shadowed_globals_with_builtins( + &mut self, + macros: &mut HashMap, + module_manager: &mut ModuleManager, + table: &mut HashSet, + ) -> &mut Self { + // for identifier in table.iter() { + // println!("Table => {}", identifier); + // } + + let mut replacer = + ReplaceBuiltinUsagesWithReservedPrimitiveReferences::new(&self.analysis, table); + + for expr in self.exprs.iter_mut() { + replacer.visit(expr); + } + + // for identifier in replacer.identifiers_to_replace.iter() { + // println!("Replaced => {}", identifier); + // } + + let mut macro_replacer = ReplaceBuiltinUsagesInsideMacros { + identifiers_to_replace: replacer.identifiers_to_replace, + }; + + for steel_macro in macros.values_mut() { + if !steel_macro.is_mangled() { + for expr in steel_macro.exprs_mut() { + macro_replacer.visit(expr); + } + + steel_macro.mark_mangled(); + } + } + + for module in module_manager.modules_mut() { + for steel_macro in module.1.macro_map.values_mut() { + if !steel_macro.is_mangled() { + for expr in steel_macro.exprs_mut() { + macro_replacer.visit(expr); + } + } + + steel_macro.mark_mangled(); + } + } + + for expr in self.exprs.iter_mut() { + macro_replacer.visit(expr); + } + + self.analysis = Analysis::from_exprs(self.exprs); + + // replace.vi + + self + } + + pub(crate) fn remove_unused_globals_with_prefix( + &mut self, + prefix: &str, + macros: &HashMap, + module_manager: &ModuleManager, + ) -> &mut Self { + let module_get_interned: InternedString = "%module-get%".into(); + let proto_hash_get: InternedString = "%proto-hash-get%".into(); + + let steel_constant_module: InternedString = "%-builtin-module-steel/constants".into(); + let void: InternedString = "void".into(); + + let mut collected = CollectReferences { + idents: fxhash::FxHashSet::default(), + }; + + for steel_macro in macros.values() { + if !steel_macro.is_mangled() { + for expr in steel_macro.exprs() { + collected.visit(expr); + } + } + } + + for module in module_manager.modules() { + for steel_macro in module.1.macro_map.values() { + if !steel_macro.is_mangled() { + for expr in steel_macro.exprs() { + collected.visit(expr); + } + } + } + } + + let found = collected.idents; + + // for ident in &found { + // println!("{}", ident); + // } + + self.exprs.retain_mut(|expression| { + match expression { + ExprKind::Define(define) => { + if let Some(name) = define.name.atom_identifier() { + if name.resolve().starts_with(prefix) { + if let Some(analysis) = define + .name + .atom_syntax_object() + .and_then(|x| self.analysis.get(x)) + { + if analysis.usage_count == 0 { + if let Some(func) = + define.body.list().and_then(|x| x.first_ident()) + { + if *func == module_get_interned || *func == proto_hash_get { + // If this is found inside of a macro, do not remove it + if found.contains(&name) { + return true; + } + + // println!("REMOVING: {}", name); + + return false; + } + } + } + } + } + } + } + ExprKind::Begin(b) => { + let mut offset = 0; + let total_length = b.exprs.len(); + + b.exprs.retain_mut(|expression| { + if let ExprKind::Define(define) = expression { + if let Some(name) = define.name.atom_identifier() { + if name.resolve().starts_with(prefix) { + if let Some(analysis) = define + .name + .atom_syntax_object() + .and_then(|x| self.analysis.get(x)) + { + if analysis.usage_count == 0 { + if let Some(func) = + define.body.list().and_then(|x| x.first_ident()) + { + // (%module-get% + // %-builtin-module-steel/constants + // (quote + // void)) + + if *func == module_get_interned + || *func == proto_hash_get + { + // If this is found inside of a macro, do not remove it + if found.contains(&name) { + offset += 1; + return true; + } + + // println!("REMOVING: {}", name); + + offset += 1; + return false; + } + } + } + } + } + } + } else { + if let ExprKind::List(l) = expression { + if let Some(func) = l.first_ident() { + if *func == module_get_interned { + if l[1].atom_identifier() == Some(&steel_constant_module) { + if let ExprKind::Quote(q) = &l[2] { + if q.expr.atom_identifier() == Some(&void) + && offset < total_length + { + offset += 1; + return false; + } + } + } + } + } + } + } + + offset += 1; + return true; + }); + } + _ => {} + } + + return true; + }); + + // self.exprs.push(ExprKind::ident("void")); + + log::debug!("Re-running the semantic analysis after removing unused globals"); + + self.analysis = Analysis::from_exprs(self.exprs); + + self + } + /// Find lets without arguments and replace these with just the body of the function. /// For instance: /// ```scheme @@ -2806,7 +3223,7 @@ impl<'a> SemanticAnalysis<'a> { self.find_let_call_sites_and_mutate_with(func); if re_run_analysis { - log::info!("Re-running the semantic analysis after modifying let call sites"); + log::debug!("Re-running the semantic analysis after modifying let call sites"); self.analysis = Analysis::from_exprs(self.exprs); } @@ -2864,7 +3281,7 @@ impl<'a> SemanticAnalysis<'a> { let analysis = analysis.get_function_info(f).unwrap(); if analysis.captured_vars.is_empty() { - log::info!("Found a function that does not capture variables"); + log::debug!("Found a function that does not capture variables"); if f.args.is_empty() && arg_count == 0 { // Take out the body of the function - we're going to want to use that now @@ -2891,7 +3308,7 @@ impl<'a> SemanticAnalysis<'a> { self.find_anonymous_function_calls_and_mutate_with(func); if re_run_analysis { - log::info!("Re-running the semantic analysis after modifications"); + log::debug!("Re-running the semantic analysis after modifications"); self.analysis = Analysis::from_exprs(self.exprs); } @@ -2923,7 +3340,7 @@ impl<'a> SemanticAnalysis<'a> { *anon = ExprKind::Let(let_expr.into()); re_run_analysis = true; - log::info!("Replaced anonymous function call with let"); + log::debug!("Replaced anonymous function call with let"); true } else { @@ -2939,7 +3356,7 @@ impl<'a> SemanticAnalysis<'a> { self.find_anonymous_function_calls_and_mutate_with(func); if re_run_analysis { - log::info!("Re-running the semantic analysis after modifications"); + log::debug!("Re-running the semantic analysis after modifications"); self.analysis = Analysis::from_exprs(self.exprs); } @@ -3041,6 +3458,38 @@ impl<'a> SemanticAnalysis<'a> { unused.unused_args } + /// Converts function applications of the form: + /// + /// ((lambda (x) (global-function-call x)) foo) + /// + /// Into: + /// + /// (global-function-call foo) + /// + /// Note: It is important to run this before lambda lifting, since currently + /// all `lets` are implemented naively as lambdas. + pub fn elide_single_argument_lambda_applications(&mut self) -> &mut Self { + let mut elider = ElideSingleArgumentLambdaApplications { + analysis: &self.analysis, + re_run_analysis: false, + }; + + for expr in self.exprs.iter_mut() { + elider.visit(expr); + } + + if elider.re_run_analysis { + log::debug!( + "Re-running the semantic analysis after modifications during lambda lifting" + ); + + self.analysis = Analysis::from_exprs(self.exprs); + self.analysis.populate_captures(self.exprs); + } + + self + } + // TODO: Right now this lifts and renames, but it does not handle // The extra arguments necessary for this to work pub fn lift_pure_local_functions(&mut self) -> &mut Self { @@ -3067,7 +3516,7 @@ impl<'a> SemanticAnalysis<'a> { .iter() .map(|x| { if let ExprKind::Define(d) = x { - log::info!("Found a local function to lift: {}", d.name); + log::debug!("Found a local function to lift: {}", d.name); d.name.atom_syntax_object().unwrap().syntax_object_id } else { unreachable!() @@ -3150,7 +3599,7 @@ impl<'a> SemanticAnalysis<'a> { *self.exprs = overall_lifted; if re_run_analysis { - log::info!( + log::debug!( "Re-running the semantic analysis after modifications during lambda lifting" ); @@ -3772,14 +4221,6 @@ mod analysis_pass_tests { fn check_analysis_pass() { // let mut builder = Builder::new(); - // builder - // .is_test(true) - // .filter( - // Some("steel::compiler::passes::analysis"), - // LevelFilter::Trace, - // ) - // .init(); - let script = r#" (define + (%module-get%)) @@ -3852,49 +4293,39 @@ mod analysis_pass_tests { ); } - let unused_args = analysis.find_unused_arguments(); + let _unused_args = analysis.find_unused_arguments(); - println!("Unused args: {unused_args:?}"); + // println!("Unused args: {unused_args:?}"); - for var in analysis.unused_variables() { - crate::rerrs::report_warning( - ErrorKind::FreeIdentifier.to_error_code(), - "input.rkt", - script, - "Unused variable".to_string(), - var.span, - ); - } - - for var in analysis.global_defs() { - crate::rerrs::report_info( - ErrorKind::FreeIdentifier.to_error_code(), - "input.rkt", - script, - "global var".to_string(), - var.span, - ); - } + // for var in analysis.unused_variables() { + // crate::rerrs::report_warning( + // ErrorKind::FreeIdentifier.to_error_code(), + // "input.rkt", + // script, + // "Unused variable".to_string(), + // var.span, + // ); + // } - // for var in analysis.built_ins() { + // for var in analysis.global_defs() { // crate::rerrs::report_info( // ErrorKind::FreeIdentifier.to_error_code(), // "input.rkt", // script, - // format!("built in function"), + // "global var".to_string(), // var.span, // ); // } - for var in analysis.last_usages() { - crate::rerrs::report_info( - ErrorKind::FreeIdentifier.to_error_code(), - "input.rkt", - script, - "last usage of variable".to_string(), - var.span, - ); - } + // for var in analysis.last_usages() { + // crate::rerrs::report_info( + // ErrorKind::FreeIdentifier.to_error_code(), + // "input.rkt", + // script, + // "last usage of variable".to_string(), + // var.span, + // ); + // } analysis.lift_pure_local_functions(); // analysis.lift_local_functions(); @@ -3925,21 +4356,5 @@ mod analysis_pass_tests { "List id: {list_id}, list 4 id: {alias_list_4_id}, resolved alias id: {found:?}" ); } - - // println!("{}", exprs[0]); - - // let function_definit - - // analysis.find_call_sites_and_call(name, func) - - // analysis.run(&exprs); - - // for expr in &exprs { - // analysis.visit(expr); - // } - - // find_call_sites_and_modify_with("foo", &analysis, &mut exprs, |l| { - // log::info!("Found a call site: {:?}", l.to_string()) - // }); } } diff --git a/crates/steel-core/src/compiler/passes/mod.rs b/crates/steel-core/src/compiler/passes/mod.rs index 5b6392b80..60053977e 100644 --- a/crates/steel-core/src/compiler/passes/mod.rs +++ b/crates/steel-core/src/compiler/passes/mod.rs @@ -389,7 +389,9 @@ pub trait VisitorMutUnitRef<'a> { } #[inline] - fn visit_macro(&mut self, _m: &'a Macro) {} + fn visit_macro(&mut self, m: &'a Macro) { + self.visit_syntax_rules(&m.syntax_rules); + } #[inline] fn visit_atom(&mut self, _a: &'a Atom) {} @@ -402,7 +404,11 @@ pub trait VisitorMutUnitRef<'a> { } #[inline] - fn visit_syntax_rules(&mut self, _l: &'a SyntaxRules) {} + fn visit_syntax_rules(&mut self, s: &'a SyntaxRules) { + for pattern in &s.patterns { + self.visit(&pattern.body); + } + } #[inline] fn visit_set(&mut self, s: &'a Set) { diff --git a/crates/steel-core/src/compiler/program.rs b/crates/steel-core/src/compiler/program.rs index 3c6a0d884..c07051947 100644 --- a/crates/steel-core/src/compiler/program.rs +++ b/crates/steel-core/src/compiler/program.rs @@ -27,6 +27,8 @@ use log::{debug, log_enabled}; use super::{compiler::DebruijnIndicesInterner, map::SymbolMap}; +const _TILE_SUPER_INSTRUCTIONS: bool = false; + /// evaluates an atom expression in given environment fn eval_atom(t: &SyntaxObject) -> Result { match &t.ty { @@ -47,51 +49,6 @@ fn eval_atom(t: &SyntaxObject) -> Result { } } -// pub fn gimmick_super_instruction(instructions: &mut [Instruction]) { -// for i in 0..instructions.len() { -// let read_local = instructions.get(i); -// let load_int = instructions.get(i + 1); -// let lte = instructions.get(i + 2); -// let pass_instr = instructions.get(i + 3); -// let if_instr = instructions.get(i + 4); - -// match (read_local, load_int, lte, pass_instr, if_instr) { -// ( -// Some(Instruction { -// op_code: OpCode::READLOCAL, -// .. -// }), -// Some(Instruction { -// op_code: OpCode::LOADINT2, -// .. -// }), -// Some(Instruction { -// op_code: OpCode::LTE, -// .. -// }), -// Some(Instruction { -// op_code: OpCode::PASS, -// .. -// }), -// // HAS to be arity 2 in this case -// Some(Instruction { -// op_code: OpCode::IF, -// .. -// }), -// ) => { -// if let Some(x) = instructions.get_mut(i) { -// x.op_code = OpCode::GIMMICK; -// } - -// instructions[i + 1].op_code = OpCode::PASS; -// instructions[i + 2].op_code = OpCode::PASS; -// instructions[i + 4].op_code = OpCode::PASS; -// } -// _ => {} -// } -// } -// } - // pub fn move_read_local_call_global(instructions: &mut [Instruction]) { // for i in 0..instructions.len() { // let move_read_local = instructions.get(i); @@ -344,6 +301,7 @@ pub fn convert_call_globals(instructions: &mut [Instruction]) { Some(Instruction { op_code: OpCode::PUSH, payload_size: index, + contents: Some(ident), .. }), Some(Instruction { @@ -355,9 +313,29 @@ pub fn convert_call_globals(instructions: &mut [Instruction]) { let arity = *arity; let index = *index; - // println!("Converting call global"); - // println!("Arity: {}", arity); - // println!("Index: {}", index); + if let TokenType::Identifier(ident) = ident.ty { + match ident { + _ if ident == *CONS_SYMBOL || ident == *PRIM_CONS_SYMBOL => { + if let Some(x) = instructions.get_mut(i) { + x.op_code = OpCode::CONS; + x.payload_size = 2; + continue; + } + } + + // Specialize lists, cons, hashmap, etc. - anything that we expect to be used often in + // real code. + _ if ident == *LIST_SYMBOL || ident == *PRIM_LIST_SYMBOL => { + if let Some(x) = instructions.get_mut(i) { + x.op_code = OpCode::LIST; + x.payload_size = arity; + continue; + } + } + + _ => {} + } + } if let Some(x) = instructions.get_mut(i) { x.op_code = OpCode::CALLGLOBAL; @@ -373,6 +351,7 @@ pub fn convert_call_globals(instructions: &mut [Instruction]) { Some(Instruction { op_code: OpCode::PUSH, payload_size: index, + contents: Some(ident), .. }), Some(Instruction { @@ -384,6 +363,24 @@ pub fn convert_call_globals(instructions: &mut [Instruction]) { let arity = *arity; let index = *index; + if let TokenType::Identifier(ident) = ident.ty { + match ident { + _ if ident == *CONS_SYMBOL || ident == *PRIM_CONS_SYMBOL => { + if let Some(x) = instructions.get_mut(i) { + x.op_code = OpCode::CONS; + x.payload_size = 2; + continue; + } + } + + // Specialize lists, cons, hashmap, etc. - anything that we expect to be used often in + // real code. + _ if ident == *LIST_SYMBOL || ident == *PRIM_LIST_SYMBOL => {} + + _ => {} + } + } + if let Some(x) = instructions.get_mut(i) { x.op_code = OpCode::CALLGLOBALTAIL; x.payload_size = arity; @@ -409,11 +406,17 @@ macro_rules! define_symbols { define_symbols! { PLUS => "+", + PRIM_PLUS => "#%prim.+", MINUS => "-", + PRIM_MINUS => "#%prim.-", DIV => "/", + PRIM_DIV => "#%prim./", STAR => "*", + PRIM_STAR => "#%prim.*", EQUAL => "equal?", + PRIM_EQUAL => "#%prim.equal?", LTE => "<=", + PRIM_LTE => "#%prim.<=", UNREADABLE_MODULE_GET => "##__module-get", STANDARD_MODULE_GET => "%module-get%", CONTRACT_OUT => "contract/out", @@ -437,6 +440,7 @@ define_symbols! { BEGIN => "begin", DOC_MACRO => "@doc", REQUIRE_BUILTIN => "require-builtin", + REQUIRE_DYLIB => "#%require-dylib", STRUCT_KEYWORD => "struct", BETTER_LAMBDA => "#%better-lambda", DEFINE_VALUES => "define-values", @@ -454,6 +458,10 @@ define_symbols! { UNSYNTAX_SPLICING => "unsyntax-splicing", RAW_UNSYNTAX_SPLICING => "#%unsyntax-splicing", SYNTAX_QUOTE => "syntax", + CONS_SYMBOL => "cons", + PRIM_CONS_SYMBOL => "#%prim.cons", + LIST_SYMBOL => "list", + PRIM_LIST_SYMBOL => "#%prim.list", } pub fn inline_num_operations(instructions: &mut [Instruction]) { @@ -479,13 +487,15 @@ pub fn inline_num_operations(instructions: &mut [Instruction]) { ) = (push, func) { let replaced = match *ident { - x if x == *PLUS && *payload_size == 2 => Some(OpCode::BINOPADD), - x if x == *PLUS => Some(OpCode::ADD), - x if x == *MINUS => Some(OpCode::SUB), - x if x == *DIV => Some(OpCode::DIV), - x if x == *STAR => Some(OpCode::MUL), - x if x == *EQUAL => Some(OpCode::EQUAL), - x if x == *LTE => Some(OpCode::LTE), + x if (x == *PLUS || x == *PRIM_PLUS) && *payload_size == 2 => { + Some(OpCode::BINOPADD) + } + x if x == *PLUS || x == *PRIM_PLUS => Some(OpCode::ADD), + x if x == *MINUS || x == *PRIM_MINUS => Some(OpCode::SUB), + x if x == *DIV || x == *PRIM_DIV => Some(OpCode::DIV), + x if x == *STAR || x == *PRIM_STAR => Some(OpCode::MUL), + x if x == *EQUAL || x == *PRIM_EQUAL => Some(OpCode::EQUAL), + x if x == *LTE || x == *PRIM_LTE => Some(OpCode::LTE), _ => None, }; @@ -504,6 +514,72 @@ pub fn inline_num_operations(instructions: &mut [Instruction]) { } } +pub const fn sequence_to_opcode(pattern: &[(OpCode, usize)]) -> &'static [steel_gen::Pattern] { + match pattern { + &[(OpCode::MOVEREADLOCAL, _)] => &[steel_gen::Pattern::Single(OpCode::MOVEREADLOCAL)], + _ => todo!(), + } +} + +pub fn tile_super_instructions(_instructions: &mut [Instruction]) { + #[cfg(feature = "dynamic")] + { + pub fn tile(instructions: &mut [Instruction]) { + // let mut list: List<(usize, OpCode)> = List::new(); + + let mut buffer = [(OpCode::VOID, 0); N]; + + let mut pattern_buffer = Vec::with_capacity(N); + + // Cell::from_mut() + + if N > instructions.len() { + return; + } + + for i in 0..instructions.len() - N { + for j in 0..N { + buffer[j] = ( + instructions[i + j].op_code, + instructions[i + j].payload_size, + ); + } + + // If this is a candidate to match the pattern, let's try to apply it! + if let Some(op_code) = steel_gen::opcode::sequence_to_opcode(&buffer) { + // Check if this pattern genuinely matches one of the code gen'd ones + steel_gen::Pattern::from_opcodes_with_buffer(&buffer, &mut pattern_buffer); + + if crate::steel_vm::vm::pattern_exists(&pattern_buffer) { + log::debug!(target: "super-instructions", "Applying tiling for: {:?}", op_code); + + instructions[i].op_code = op_code; + + continue; + } + } + } + + // for (index, op) in list { + // instructions[index].op_code = op; + // } + } + + // Super instruction tiling here! + + if _TILE_SUPER_INSTRUCTIONS { + tile::<9>(instructions); + tile::<8>(instructions); + tile::<7>(instructions); + tile::<6>(instructions); + tile::<5>(instructions); + tile::<4>(instructions); + tile::<3>(instructions); + tile::<2>(instructions); + } + } +} + pub fn merge_conditions_with_if(instructions: &mut [Instruction]) { for i in 0..instructions.len() - 1 { let condition = instructions.get(i); @@ -895,6 +971,11 @@ impl RawProgramWithSymbols { merge_conditions_with_if(instructions); + specialize_constants(instructions).unwrap(); + + // Apply the super instruction tiling! + tile_super_instructions(instructions); + // specialize_exit_jmp(instructions); // loop_condition_local_const_arity_two(instructions); diff --git a/crates/steel-core/src/conversions.rs b/crates/steel-core/src/conversions.rs index 8b9c52ecd..06cb7b5e3 100644 --- a/crates/steel-core/src/conversions.rs +++ b/crates/steel-core/src/conversions.rs @@ -1,4 +1,4 @@ -use im_lists::list::List; +use crate::values::lists::List; use crate::{ gc::Gc, @@ -34,7 +34,9 @@ impl IntoSteelVal for SteelVal { // } // } -impl FromSteelVal for List { +impl> FromSteelVal + for im_lists::list::GenericList +{ fn from_steelval(val: &SteelVal) -> Result { if let SteelVal::ListV(l) = val { l.iter().map(T::from_steelval).collect() @@ -44,7 +46,9 @@ impl FromSteelVal for List { } } -impl IntoSteelVal for List { +impl> IntoSteelVal + for im_lists::list::GenericList +{ fn into_steelval(self) -> Result { self.into_iter() .map(|x| x.into_steelval()) @@ -56,7 +60,7 @@ impl IntoSteelVal for List { impl FromSteelVal for Gc> { fn from_steelval(val: &SteelVal) -> Result { if let SteelVal::HashMapV(hm) = val { - Ok(hm.clone()) + Ok(hm.0.clone()) } else { stop!(TypeMismatch => "Unable to convert Steelval to HashMap, found: {}", val); } @@ -124,10 +128,9 @@ impl AsRefSteelValFromUnsized for T { impl IntoSteelVal for (A, B) { fn into_steelval(self) -> Result { - Ok(SteelVal::ListV(im_lists::list![ - self.0.into_steelval()?, - self.1.into_steelval()? - ])) + Ok(SteelVal::ListV( + vec![self.0.into_steelval()?, self.1.into_steelval()?].into(), + )) } } @@ -249,7 +252,7 @@ impl IntoSteelVal for HashMap { for (key, val) in self.drain() { hm.insert(key.into_steelval()?, val.into_steelval()?); } - Ok(SteelVal::HashMapV(Gc::new(hm))) + Ok(SteelVal::HashMapV(Gc::new(hm).into())) } } @@ -258,7 +261,7 @@ impl FromSteelVal for H // todo!() if let SteelVal::HashMapV(hm) = val { let mut h = HashMap::new(); - for (key, value) in hm.unwrap().into_iter() { + for (key, value) in hm.0.unwrap().into_iter() { h.insert(K::from_steelval(&key)?, V::from_steelval(&value)?); } Ok(h) @@ -315,7 +318,7 @@ impl IntoSteelVal for HashSet { for value in self.drain() { hs.insert(value.into_steelval()?); } - Ok(SteelVal::HashSetV(Gc::new(hs))) + Ok(SteelVal::HashSetV(Gc::new(hs).into())) } } @@ -323,7 +326,7 @@ impl FromSteelVal for HashSet { fn from_steelval(val: &SteelVal) -> Result { if let SteelVal::HashSetV(hs) = val { let mut h = HashSet::new(); - for k in hs.unwrap().into_iter() { + for k in hs.0.unwrap().into_iter() { h.insert(K::from_steelval(&k)?); } Ok(h) @@ -353,7 +356,7 @@ impl FromSteelVal for HashSet { mod conversion_tests { use super::*; - use im_lists::list; + use im_rc::vector; #[test] @@ -364,14 +367,14 @@ mod conversion_tests { // Some(Gc::new(ConsCell::new(SteelVal::IntV(2), None))), // ))); - let expected = list![SteelVal::IntV(1), SteelVal::IntV(2)].into(); + let expected = SteelVal::ListV(vec![SteelVal::IntV(1), SteelVal::IntV(2)].into()); assert_eq!(input_vec.into_steelval().unwrap(), expected) } #[test] fn vec_from_list() { - let input_list = SteelVal::ListV(list![SteelVal::IntV(1), SteelVal::IntV(2)]); + let input_list = SteelVal::ListV(vec![SteelVal::IntV(1), SteelVal::IntV(2)].into()); let expected = vec![1, 2]; let result = >::from_steelval(&input_list).unwrap(); @@ -381,8 +384,7 @@ mod conversion_tests { #[test] fn vec_from_vector() { - let input_vector = - SteelVal::VectorV(Gc::new(vector![SteelVal::IntV(1), SteelVal::IntV(2)])); + let input_vector = vector![SteelVal::IntV(1), SteelVal::IntV(2)].into(); let expected = vec![1, 2]; let result = >::from_steelval(&input_vector).unwrap(); @@ -401,20 +403,26 @@ mod conversion_tests { input.insert("foo".to_string(), "bar".to_string()); input.insert("foo2".to_string(), "bar2".to_string()); - let expected = SteelVal::HashMapV(Gc::new(im_rc::hashmap! { - SteelVal::StringV("foo".into()) => SteelVal::StringV("bar".into()), - SteelVal::StringV("foo2".into()) => SteelVal::StringV("bar2".into()) - })); + let expected = SteelVal::HashMapV( + Gc::new(im_rc::hashmap! { + SteelVal::StringV("foo".into()) => SteelVal::StringV("bar".into()), + SteelVal::StringV("foo2".into()) => SteelVal::StringV("bar2".into()) + }) + .into(), + ); assert_eq!(input.into_steelval().unwrap(), expected); } #[test] fn hashmap_from_steelval_hashmap() { - let input = SteelVal::HashMapV(Gc::new(im_rc::hashmap! { - SteelVal::StringV("foo".into()) => SteelVal::StringV("bar".into()), - SteelVal::StringV("foo2".into()) => SteelVal::StringV("bar2".into()) - })); + let input = SteelVal::HashMapV( + Gc::new(im_rc::hashmap! { + SteelVal::StringV("foo".into()) => SteelVal::StringV("bar".into()), + SteelVal::StringV("foo2".into()) => SteelVal::StringV("bar2".into()) + }) + .into(), + ); let mut expected = HashMap::new(); expected.insert("foo".to_string(), "bar".to_string()); @@ -432,20 +440,26 @@ mod conversion_tests { input.insert("foo".to_string()); input.insert("bar".to_string()); - let expected = SteelVal::HashSetV(Gc::new(im_rc::hashset! { - SteelVal::StringV("foo".into()), - SteelVal::StringV("bar".into()) - })); + let expected = SteelVal::HashSetV( + Gc::new(im_rc::hashset! { + SteelVal::StringV("foo".into()), + SteelVal::StringV("bar".into()) + }) + .into(), + ); assert_eq!(input.into_steelval().unwrap(), expected); } #[test] fn hashset_from_steelval_hashset() { - let input = SteelVal::HashSetV(Gc::new(im_rc::hashset! { - SteelVal::StringV("foo".into()), - SteelVal::StringV("bar".into()) - })); + let input = SteelVal::HashSetV( + Gc::new(im_rc::hashset! { + SteelVal::StringV("foo".into()), + SteelVal::StringV("bar".into()) + }) + .into(), + ); let mut expected = HashSet::new(); expected.insert("foo".to_string()); diff --git a/crates/steel-core/src/gc.rs b/crates/steel-core/src/gc.rs index bd33928f3..763bbe361 100644 --- a/crates/steel-core/src/gc.rs +++ b/crates/steel-core/src/gc.rs @@ -98,7 +98,7 @@ impl Gc { Rc::as_ptr(&self.0) } - pub fn try_unwrap_(self) -> Result> { + pub fn try_unwrap(self) -> Result> { Rc::try_unwrap(self.0).map_err(|x| Gc(x)) } @@ -284,6 +284,7 @@ pub mod unsafe_erased_pointers { use std::rc::{Rc, Weak}; use std::{any::Any, cell::RefCell, marker::PhantomData}; + use crate::rvals::cycles::IterativeDropHandler; use crate::rvals::AsRefSteelValFromRef; use crate::{rerrs::ErrorKind, rvals::AsRefMutSteelValFromRef, SteelErr, SteelVal}; @@ -390,7 +391,9 @@ pub mod unsafe_erased_pointers { // TODO: Re-evaluate the necessity of this trait. Is it possible to overload it all into one? That could // help disambiguate the function call sites. - pub trait CustomReference {} + pub trait CustomReference { + fn walk(&self) {} + } /// Warning - you should not implement this trait yourself. Use the `custom_reference` macro instead. /// Implementing this incorrectly could lead to undefined behavior. @@ -433,6 +436,8 @@ pub mod unsafe_erased_pointers { fn display(&self) -> std::result::Result { Ok(format!("#<{}>", self.name().to_string())) } + fn visit(&self) {} + fn drop_mut(&mut self, drop_handler: &mut IterativeDropHandler) {} } impl<'a, T: CustomReference + 'static> ReferenceCustomType for T { @@ -449,6 +454,9 @@ pub mod unsafe_erased_pointers { Ok(format!("#<{}>", self.name().to_string())) // } } + fn visit(&self) { + self.walk() + } } // impl IntoSteelVal for T { @@ -836,6 +844,12 @@ pub mod unsafe_erased_pointers { pub fn format(&self) -> std::result::Result { self.display() } + + pub fn drop_mut(&mut self, drop_handler: &mut IterativeDropHandler) { + if let Some(inner) = Rc::get_mut(&mut self.inner) { + inner.drop_mut(drop_handler); + } + } } impl CustomReference for OpaqueReference<'static> {} diff --git a/crates/steel-core/src/lib.rs b/crates/steel-core/src/lib.rs index 13cd55f7e..630c1dde2 100644 --- a/crates/steel-core/src/lib.rs +++ b/crates/steel-core/src/lib.rs @@ -26,3 +26,6 @@ pub(crate) mod values; pub use self::{rerrs::SteelErr, rvals::SteelVal, stdlib::PRELUDE}; pub use im_lists::list::List; pub use im_rc::HashMap; +pub use primitives::UnRecoverableResult; +pub use values::RootToken; +pub use values::RootedSteelVal; diff --git a/crates/steel-core/src/parser/ast.rs b/crates/steel-core/src/parser/ast.rs index 8941b7e5a..98eaa8264 100644 --- a/crates/steel-core/src/parser/ast.rs +++ b/crates/steel-core/src/parser/ast.rs @@ -8,6 +8,7 @@ use crate::{ tokens::TokenType::{self, *}, tryfrom_visitor::TryFromExprKindForSteelVal, }, + steel_vm::primitives::MODULE_IDENTIFIERS, }; use std::{convert::TryFrom, fmt::Write, sync::atomic::Ordering}; @@ -46,6 +47,12 @@ impl AstTools for Vec<&ExprKind> { } } +impl AstTools for &mut Vec { + fn pretty_print(&self) { + println!("{}", self.iter().map(|x| x.to_pretty(60)).join("\n\n")) + } +} + pub trait IteratorExtensions: Iterator { fn join(&mut self, sep: &str) -> String where @@ -103,6 +110,14 @@ macro_rules! expr_list { } impl ExprKind { + pub fn into_lambda_function(self) -> Option> { + if let ExprKind::LambdaFunction(func) = self { + Some(func) + } else { + None + } + } + pub fn quoted_list() -> ExprKind { ExprKind::Quote(Box::new(Quote::new( Self::empty(), @@ -429,78 +444,90 @@ impl TryFromSteelValVisitorForExprKind { impl TryFrom<&SteelVal> for ExprKind { type Error = &'static str; fn try_from(r: &SteelVal) -> std::result::Result { - match r { - BoolV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( - BooleanLiteral(*x), - )))), - NumV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( - NumberLiteral(*x), - )))), - IntV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( - IntegerLiteral(MaybeBigInt::Small(*x)), - )))), - - BigNum(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( - IntegerLiteral(MaybeBigInt::Big(x.unwrap())), - )))), - - VectorV(lst) => { - let items: std::result::Result, Self::Error> = - lst.iter().map(Self::try_from).collect(); - Ok(ExprKind::List(List::new(items?))) - } - Void => Err("Can't convert from Void to expression!"), - StringV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( - StringLiteral(x.to_string()), - )))), - FuncV(_) => Err("Can't convert from Function to expression!"), - // LambdaV(_) => Err("Can't convert from Lambda to expression!"), - // MacroV(_) => Err("Can't convert from Macro to expression!"), - SymbolV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( - Identifier(x.as_str().into()), - )))), - SyntaxObject(s) => s - .to_exprkind() - .map_err(|_| "Unable to convert syntax object back to exprkind"), - Custom(_) => { - // TODO: if the returned object is a custom type, check - // to see if its a Syntax struct to replace the span with - Err("Can't convert from Custom Type to expression!") + fn inner_try_from( + r: &SteelVal, + depth: usize, + ) -> std::result::Result { + if depth > 64 { + return Err("Unable to convert steel val to exprkind - depth was too large!"); } - ListV(l) => { - let items: std::result::Result, Self::Error> = - l.iter().map(Self::try_from).collect(); - Ok(ExprKind::List(List::new(items?))) + match r { + BoolV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( + BooleanLiteral(*x), + )))), + NumV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( + NumberLiteral(*x), + )))), + IntV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( + IntegerLiteral(MaybeBigInt::Small(*x)), + )))), + + BigNum(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( + IntegerLiteral(MaybeBigInt::Big(x.unwrap())), + )))), + + VectorV(lst) => { + let items: std::result::Result, &'static str> = + lst.iter().map(|x| inner_try_from(x, depth + 1)).collect(); + Ok(ExprKind::List(List::new(items?))) + } + Void => Err("Can't convert from Void to expression!"), + StringV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( + StringLiteral(x.to_string()), + )))), + FuncV(_) => Err("Can't convert from Function to expression!"), + // LambdaV(_) => Err("Can't convert from Lambda to expression!"), + // MacroV(_) => Err("Can't convert from Macro to expression!"), + SymbolV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( + Identifier(x.as_str().into()), + )))), + SyntaxObject(s) => s + .to_exprkind() + .map_err(|_| "Unable to convert syntax object back to exprkind"), + Custom(_) => { + // TODO: if the returned object is a custom type, check + // to see if its a Syntax struct to replace the span with + Err("Can't convert from Custom Type to expression!") + } + ListV(l) => { + let items: std::result::Result, &'static str> = + l.iter().map(|x| inner_try_from(x, depth + 1)).collect(); + + Ok(ExprKind::List(List::new(items?))) + } + CharV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( + CharacterLiteral(*x), + )))), + // StructClosureV(_) => Err("Can't convert from struct-function to expression!"), + PortV(_) => Err("Can't convert from port to expression!"), + Closure(_) => Err("Can't convert from bytecode closure to expression"), + HashMapV(_) => Err("Can't convert from hashmap to expression!"), + HashSetV(_) => Err("Can't convert from hashset to expression!"), + IterV(_) => Err("Can't convert from iterator to expression!"), + FutureFunc(_) => Err("Can't convert from future function to expression!"), + FutureV(_) => Err("Can't convert future to expression!"), + // Promise(_) => Err("Can't convert from promise to expression!"), + StreamV(_) => Err("Can't convert from stream to expression!"), + // Contract(_) => Err("Can't convert from contract to expression!"), + // ContractedFunction(_) => Err("Can't convert from contracted function to expression!"), + BoxedFunction(_) => Err("Can't convert from boxed function to expression!"), + ContinuationFunction(_) => Err("Can't convert from continuation to expression!"), + // #[cfg(feature = "jit")] + // CompiledFunction(_) => Err("Can't convert from function to expression!"), + MutFunc(_) => Err("Can't convert from function to expression!"), + BuiltIn(_) => Err("Can't convert from function to expression!"), + ReducerV(_) => Err("Can't convert from reducer to expression!"), + MutableVector(_) => Err("Can't convert from vector to expression!"), + CustomStruct(_) => Err("Can't convert from struct to expression!"), + BoxedIterator(_) => Err("Can't convert from boxed iterator to expression!"), + Boxed(_) => Err("Can't convert from boxed steel val to expression!"), + Reference(_) => Err("Can't convert from opaque reference type to expression!"), + HeapAllocated(_) => Err("Can't convert from heap allocated value to expression!"), } - CharV(x) => Ok(ExprKind::Atom(Atom::new(SyntaxObject::default( - CharacterLiteral(*x), - )))), - // StructClosureV(_) => Err("Can't convert from struct-function to expression!"), - PortV(_) => Err("Can't convert from port to expression!"), - Closure(_) => Err("Can't convert from bytecode closure to expression"), - HashMapV(_) => Err("Can't convert from hashmap to expression!"), - HashSetV(_) => Err("Can't convert from hashset to expression!"), - IterV(_) => Err("Can't convert from iterator to expression!"), - FutureFunc(_) => Err("Can't convert from future function to expression!"), - FutureV(_) => Err("Can't convert future to expression!"), - // Promise(_) => Err("Can't convert from promise to expression!"), - StreamV(_) => Err("Can't convert from stream to expression!"), - Contract(_) => Err("Can't convert from contract to expression!"), - ContractedFunction(_) => Err("Can't convert from contracted function to expression!"), - BoxedFunction(_) => Err("Can't convert from boxed function to expression!"), - ContinuationFunction(_) => Err("Can't convert from continuation to expression!"), - // #[cfg(feature = "jit")] - // CompiledFunction(_) => Err("Can't convert from function to expression!"), - MutFunc(_) => Err("Can't convert from function to expression!"), - BuiltIn(_) => Err("Can't convert from function to expression!"), - ReducerV(_) => Err("Can't convert from reducer to expression!"), - MutableVector(_) => Err("Can't convert from vector to expression!"), - CustomStruct(_) => Err("Can't convert from struct to expression!"), - BoxedIterator(_) => Err("Can't convert from boxed iterator to expression!"), - Boxed(_) => Err("Can't convert from boxed steel val to expression!"), - Reference(_) => Err("Can't convert from opaque reference type to expression!"), } + + inner_try_from(r, 0) } } @@ -826,8 +853,13 @@ impl Define { pub(crate) fn is_a_builtin_definition(&self) -> bool { if let ExprKind::List(l) = &self.body { match l.first_ident() { - Some(func) if *func == *UNREADABLE_MODULE_GET => return true, - Some(func) if *func == *STANDARD_MODULE_GET => return true, + Some(func) if *func == *UNREADABLE_MODULE_GET || *func == *STANDARD_MODULE_GET => { + // return true + + if let Some(module) = l.second_ident() { + return MODULE_IDENTIFIERS.contains(module); + } + } _ => {} } } @@ -1121,6 +1153,21 @@ impl List { } } + pub fn second_ident(&self) -> Option<&InternedString> { + if let Some(ExprKind::Atom(Atom { + syn: + SyntaxObject { + ty: TokenType::Identifier(s), + .. + }, + })) = self.args.get(1) + { + Some(s) + } else { + None + } + } + pub fn is_anonymous_function_call(&self) -> bool { matches!(self.args.get(0), Some(ExprKind::LambdaFunction(_))) } diff --git a/crates/steel-core/src/parser/expand_visitor.rs b/crates/steel-core/src/parser/expand_visitor.rs index d9ae2a12c..8f77ff328 100644 --- a/crates/steel-core/src/parser/expand_visitor.rs +++ b/crates/steel-core/src/parser/expand_visitor.rs @@ -1,6 +1,12 @@ // use itertools::Itertools; +use quickscope::ScopeSet; + +use crate::compiler::passes::reader::MultipleArityFunctions; +use crate::compiler::passes::Folder; +use crate::compiler::program::REQUIRE_DYLIB; use crate::parser::ast::ExprKind; +use crate::steel_vm::builtin::BuiltInModule; use crate::steel_vm::engine::ModuleContainer; use crate::{compiler::program::REQUIRE_BUILTIN, rvals::Result}; use crate::{compiler::program::STRUCT_KEYWORD, parser::visitors::ConsumingVisitor}; @@ -44,6 +50,7 @@ pub fn expand(expr: ExprKind, map: &HashMap) -> Resu Expander { map, changed: false, + in_scope_values: ScopeSet::new(), } .visit(expr) } @@ -51,6 +58,8 @@ pub fn expand(expr: ExprKind, map: &HashMap) -> Resu pub struct Expander<'a> { map: &'a HashMap, pub(crate) changed: bool, + // We're going to actually check if the macro is in scope + in_scope_values: ScopeSet, } impl<'a> Expander<'a> { @@ -58,6 +67,7 @@ impl<'a> Expander<'a> { Self { map, changed: false, + in_scope_values: ScopeSet::new(), } } @@ -66,6 +76,7 @@ impl<'a> Expander<'a> { } } +// TODO: See if we can do this without blowing the stack impl<'a> ConsumingVisitor for Expander<'a> { type Output = Result; @@ -85,7 +96,18 @@ impl<'a> ConsumingVisitor for Expander<'a> { &mut self, mut lambda_function: Box, ) -> Self::Output { + self.in_scope_values.push_layer(); + + for value in &lambda_function.args { + if let Some(ident) = value.atom_identifier() { + self.in_scope_values.define(*ident); + } + } + lambda_function.body = self.visit(lambda_function.body)?; + + self.in_scope_values.pop_layer(); + Ok(ExprKind::LambdaFunction(lambda_function)) } @@ -129,9 +151,17 @@ impl<'a> ConsumingVisitor for Expander<'a> { })) = l.first() { if let Some(m) = self.map.get(s) { - let expanded = m.expand(l.clone(), *sp)?; - self.changed = true; - return self.visit(expanded); + // If this macro has been overwritten by any local value, respect + // the local binding and do not expand the macro + if !self.in_scope_values.contains(s) { + let expanded = m.expand(l.clone(), *sp)?; + self.changed = true; + return self.visit(expanded); + } + + // let expanded = m.expand(l.clone(), *sp)?; + // self.changed = true; + // return self.visit(expanded); } } @@ -266,6 +296,27 @@ fn expand_keyword_arguments( ) -> Result> { // todo!() + // TODO: Check if this already has a rest argument - if so, the generated code will need to be changed. + // The naive generated code will not handle rest arguments with keyword arguments, which can be a concern. + // In addition, this naively assumes that keyword arguments cannot be applied before positional arguments - which + // on its own is not the worst restriction, and perhaps we can leave that in place. + // + // If there are rest arguments though, we'll need to split the rest argument list into two - the first half will then get + // applied to the hashmap list, while the rest of the arguments will get applied to the correct place. + + // We don't want to do this! This is going to allocate extra! + let lambda_function = MultipleArityFunctions::new() + .visit_lambda_function(lambda_function) + .into_lambda_function() + .unwrap(); + + // If this already has a rest arguments, we need to slice out the + // remaining function values from the keywords, and then bind those to whatever variable in the original + // list before we create the hash. Making the hash itself is also not exactly my favorite pattern - we need + // to allocate extra stuff - what we should probably do is create a special keyword allocation that we + // can consistently reuse inside the VM. If we can reuse that allocation repeatedly, we should be able + // to avoid much of the overhead of the allocation. + // TODO: Can partition these directly into the two groups let keyword_args: Vec<&ExprKind> = lambda_function .args @@ -283,12 +334,23 @@ fn expand_keyword_arguments( }) .collect(); + // If there is a rest argument, we'll want to grab it for later use in the expansion + // TODO: @Matt - Come back to this one + // let mut rest_arg_expr = None; + // Bail out if theres no keyword args if keyword_args.is_empty() { return Ok(lambda_function); } - if keyword_args.len() % 2 != 0 { + if (keyword_args.len() % 2 != 0 && !lambda_function.rest) + || (lambda_function.rest && keyword_args.len() - 1 % 2 != 0) + { + // The last argument is going to be the rest argument + // if lambda_function.rest { + // rest_arg_expr = keyword_args.pop(); + // } + stop!(Generic => "keyword arguments malformed - each option requires a value"; lambda_function.location.span) } @@ -327,6 +389,8 @@ fn expand_keyword_arguments( }) ) }) { + dbg!(&keyword_map); + stop!(Generic => "Non keyword arguments found after the first keyword argument"; lambda_function.location.span) } @@ -411,6 +475,7 @@ fn expand_keyword_arguments( expr_list![ ExprKind::ident("apply"), ExprKind::ident("%keyword-hash"), // This shouldn't be `hash` directly - something with a specific error + // TODO: do like, `(take x !!dummy-rest-arg!!)` ExprKind::ident("!!dummy-rest-arg!!"), ], ], @@ -534,9 +599,9 @@ impl<'a> ConsumingVisitor for KernelExpander<'a> { SyntaxObject::default(TokenType::Define), ))); - let ast_name = ExprKind::atom( - d.name.atom_identifier().unwrap().to_string() + "__ast__", - ); + // let ast_name = ExprKind::atom( + // d.name.atom_identifier().unwrap().to_string() + "__ast__", + // ); // Include the metadata table let metadata_table_addition = ExprKind::List(List::new(vec![ @@ -550,10 +615,10 @@ impl<'a> ConsumingVisitor for KernelExpander<'a> { let expanded_expr = self.visit(top_level_define)?; - let quoted_ast = define_quoted_ast_node(ast_name, &expanded_expr); + // let quoted_ast = define_quoted_ast_node(ast_name, &expanded_expr); return Ok(ExprKind::Begin(Begin::new( - vec![doc_expr, quoted_ast, expanded_expr, metadata_table_addition], + vec![doc_expr, expanded_expr, metadata_table_addition], SyntaxObject::default(TokenType::Begin), ))); } @@ -573,16 +638,16 @@ impl<'a> ConsumingVisitor for KernelExpander<'a> { SyntaxObject::default(TokenType::Define), ))); - let ast_name = ExprKind::atom( - d.name.atom_identifier().unwrap().to_string() + "__ast__", - ); + // let ast_name = ExprKind::atom( + // d.name.atom_identifier().unwrap().to_string() + "__ast__", + // ); let expanded_expr = self.visit(top_level_define)?; - let quoted_ast = define_quoted_ast_node(ast_name, &expanded_expr); + // let quoted_ast = define_quoted_ast_node(ast_name, &expanded_expr); return Ok(ExprKind::Begin(Begin::new( - vec![doc_expr, quoted_ast, expanded_expr], + vec![doc_expr, expanded_expr], SyntaxObject::default(TokenType::Begin), ))); } @@ -601,13 +666,13 @@ impl<'a> ConsumingVisitor for KernelExpander<'a> { SyntaxObject::default(TokenType::Define), ))); - let ast_name = ExprKind::atom(struct_name.to_string() + "__ast__"); + // let ast_name = ExprKind::atom(struct_name.to_string() + "__ast__"); - let quoted_ast = - define_quoted_ast_node(ast_name, &top_level_define); + // let quoted_ast = + // define_quoted_ast_node(ast_name, &top_level_define); return Ok(ExprKind::Begin(Begin::new( - vec![doc_expr, quoted_ast, self.visit(top_level_define)?], + vec![doc_expr, self.visit(top_level_define)?], SyntaxObject::default(TokenType::Begin), ))); } @@ -628,6 +693,69 @@ impl<'a> ConsumingVisitor for KernelExpander<'a> { } } + // + if s == *REQUIRE_DYLIB { + match &l.args[1..] { + [ExprKind::Atom(Atom { + syn: + SyntaxObject { + ty: TokenType::StringLiteral(dylib_name), + .. + }, + }), ExprKind::List(List { args, .. })] => { + // TODO: if it can't be found, the module needs to be marked as `MaybeDylib` + // and use the binds that are listed in the dylib require spec, something like: + // (require-builtin steel/obviouslydylib/sqlite (only-in ... ... ...)) <- + // Then, we can _attempt_ to load the dylib at runtime. If we can't we move on, and + // otherwise we can error if the identifiers are not lining up. + // (require-dylib ".so" (onlt-in )) + + // if let Some(module) = self.builtin_modules.get(s.as_str()) { + // return Ok(module.to_syntax(None)); + // } else { + // stop!(BadSyntax => "require-builtin: module not found: {}", s); + // } + + match args.as_slice() { + [ExprKind::Atom(Atom { + syn: + SyntaxObject { + ty: TokenType::Identifier(s), + .. + }, + }), rest @ ..] + if s.resolve() == "only-in" => + { + // self.builtin_modules. + + let mut names = Vec::with_capacity(rest.len()); + + for expr in rest { + if let Some(identifier) = expr.atom_identifier() { + names.push(identifier); + } else { + stop!(BadSyntax => "require-dylib `only-in` modifier expects identifiers") + } + } + + return Ok(BuiltInModule::dylib_to_syntax( + dylib_name.as_str(), + names.iter().map(|x| x.resolve()), + None, + )); + } + _ => { + stop!(BadSyntax => "require-dylib expects on `only-in` modifier") + } + } + } + + _ => { + stop!(BadSyntax => "require-dylib malformed") + } + } + } + if s == *REQUIRE_BUILTIN { match &l.args[1..] { [ExprKind::Atom(Atom { @@ -637,6 +765,11 @@ impl<'a> ConsumingVisitor for KernelExpander<'a> { .. }, })] => { + // TODO: if it can't be found, the module needs to be marked as `MaybeDylib` + // and use the binds that are listed in the dylib require spec, something like: + // (require-builtin steel/obviouslydylib/sqlite (only-in ... ... ...)) <- + // Then, we can _attempt_ to load the dylib at runtime. If we can't we move on, and + // otherwise we can error if the identifiers are not lining up. if let Some(module) = self.builtin_modules.get(s.as_str()) { return Ok(module.to_syntax(None)); } else { @@ -714,29 +847,6 @@ impl<'a> ConsumingVisitor for KernelExpander<'a> { stop!(ArityMismatch => "require-builtin malformed - follows the pattern (require-builtin \"\") or (require-builtin \"\" as ") } } - - // if l.args.len() != 2 { - // stop!(ArityMismatch => "require-builtin expects one argument - the name of the module to include") - // } - - // match &l.args[1] { - // ExprKind::Atom(Atom { - // syn: - // SyntaxObject { - // ty: TokenType::StringLiteral(s), - // .. - // }, - // }) => { - // if let Some(module) = self.builtin_modules.get(s) { - // return Ok(module.to_syntax()); - // } else { - // stop!(BadSyntax => "require-builtin: module not found: {}", s); - // } - // } - // other => { - // stop!(TypeMismatch => format!("require-builtin expects a string referring to the name of the module, found: {}", other)) - // } - // } } } @@ -780,7 +890,7 @@ impl<'a> ConsumingVisitor for KernelExpander<'a> { } } -fn define_quoted_ast_node(ast_name: ExprKind, expanded_expr: &ExprKind) -> ExprKind { +fn _define_quoted_ast_node(ast_name: ExprKind, expanded_expr: &ExprKind) -> ExprKind { ExprKind::Define(Box::new(Define::new( ast_name, ExprKind::Quote(Box::new(Quote::new( diff --git a/crates/steel-core/src/parser/expander.rs b/crates/steel-core/src/parser/expander.rs index 6f9ba74a6..cc0bb24e7 100644 --- a/crates/steel-core/src/parser/expander.rs +++ b/crates/steel-core/src/parser/expander.rs @@ -15,7 +15,7 @@ use std::{ path::{Path, PathBuf}, }; -use log::{debug, error, info}; +use log::{debug, error}; use serde::{Deserialize, Serialize}; use steel_parser::tokens::MaybeBigInt; @@ -149,6 +149,7 @@ pub struct SteelMacro { name: InternedString, special_forms: Vec, cases: Vec, + mangled: bool, } impl SteelMacro { @@ -162,6 +163,7 @@ impl SteelMacro { name, special_forms, cases, + mangled: false, } } @@ -173,6 +175,18 @@ impl SteelMacro { self.cases.iter_mut().map(|x| &mut x.body) } + pub fn exprs(&self) -> impl Iterator { + self.cases.iter().map(|x| &x.body) + } + + pub fn mark_mangled(&mut self) { + self.mangled = true; + } + + pub fn is_mangled(&self) -> bool { + self.mangled + } + pub fn parse_from_ast_macro(ast_macro: Macro) -> Result { let name = *ast_macro .name @@ -205,6 +219,7 @@ impl SteelMacro { name, special_forms, cases, + mangled: false, }) } @@ -245,8 +260,8 @@ impl SteelMacro { let case_to_expand = self.match_case(&expr)?; let expanded_expr = case_to_expand.expand(expr, span)?; - if log::log_enabled!(log::Level::Info) { - info!("Macro Expansion: {}", expanded_expr); + if log::log_enabled!(log::Level::Debug) { + debug!("Macro Expansion: {}", expanded_expr); } Ok(expanded_expr) diff --git a/crates/steel-core/src/parser/interner.rs b/crates/steel-core/src/parser/interner.rs index f1e0df0e3..dfff59433 100644 --- a/crates/steel-core/src/parser/interner.rs +++ b/crates/steel-core/src/parser/interner.rs @@ -4,17 +4,32 @@ use once_cell::sync::OnceCell; use serde::{Deserialize, Serialize}; use std::{fmt, sync::Arc}; -// #[derive(Clone, PartialEq, Eq, Ord, PartialOrd, Hash)] -// pub enum MaybeInternedString { -// Interned(InternedString), -// Uninterned(String), -// } - -/// An interned string -#[derive(Copy, Clone, PartialEq, Eq, Ord, PartialOrd, Hash, Serialize, Deserialize)] +// TODO: Serialize and Deserialize should resolve() -> Otherwise we're in for deep trouble +// trying to serialize and deserialize this +#[derive(Copy, Clone, PartialEq, Eq, Ord, PartialOrd, Hash)] #[repr(transparent)] pub struct InternedString(Spur); +impl Serialize for InternedString { + fn serialize(&self, serializer: S) -> Result + where + S: serde::Serializer, + { + self.resolve().serialize(serializer) + } +} + +impl<'de> Deserialize<'de> for InternedString { + fn deserialize(deserializer: D) -> Result + where + D: serde::Deserializer<'de>, + { + let key = <&str>::deserialize(deserializer)?; + + Ok(InternedString::from(key)) + } +} + impl InternedString { pub fn from_static(ident: &'static str) -> Self { Self( @@ -119,7 +134,6 @@ use crate::{rvals::SteelString, SteelVal}; static INTERNER: OnceCell> = OnceCell::new(); pub fn take_interner() -> Arc { - // INTERNER.take().unwrap() Arc::clone(INTERNER.get().unwrap()) } @@ -131,6 +145,14 @@ pub fn get_interner() -> Option<&'static Arc> { INTERNER.get() } +pub fn add_interner(interner: Arc) { + let guard = INTERNER.get().unwrap(); + + for key in interner.strings() { + guard.get_or_intern(key); + } +} + #[test] fn test_initialization() { INTERNER.get_or_init(|| Arc::new(ThreadedRodeo::new())); diff --git a/crates/steel-core/src/parser/kernel.rs b/crates/steel-core/src/parser/kernel.rs index 56d6e6e29..52a67941b 100644 --- a/crates/steel-core/src/parser/kernel.rs +++ b/crates/steel-core/src/parser/kernel.rs @@ -6,7 +6,7 @@ use std::{ use steel_parser::tokens::TokenType; use crate::{ - compiler::passes::analysis::SemanticAnalysis, + compiler::{passes::analysis::SemanticAnalysis, program::RawProgramWithSymbols}, expr_list, parser::{ ast::{Atom, Set}, @@ -24,7 +24,6 @@ use super::{ }; thread_local! { - // pub(crate) static KERNEL_IMAGE: Engine = Engine::new_kernel(); pub(crate) static KERNEL_IMAGE: Engine = Engine::new_bootstrap_kernel(); } @@ -49,7 +48,7 @@ pub struct Kernel { // macros: HashSet, transformers: Transformers, constants: HashSet, - engine: Box, + pub(crate) engine: Box, } impl Default for Kernel { @@ -84,7 +83,7 @@ impl Kernel { .iter() .map(|x| x.resolve().to_string()) .map(|x| SteelVal::SymbolV(x.into())) - .collect::>() + .collect::>() .into() }); @@ -104,6 +103,90 @@ impl Kernel { } } + pub(crate) fn bootstrap(mut engine: Engine) -> (Self, RawProgramWithSymbols) { + let transformers = Transformers { + set: Arc::new(RwLock::new(HashSet::default())), + }; + + let embedded_transformer_object = transformers.clone(); + engine.register_fn("register-macro-transformer!", move |name: String| { + embedded_transformer_object + .set + .write() + .unwrap() + .insert(name.as_str().into()) + }); + + let embedded_transformer_object = transformers.clone(); + engine.register_fn("current-macro-transformers!", move || -> SteelVal { + embedded_transformer_object + .set + .read() + .unwrap() + .iter() + .map(|x| x.resolve().to_string()) + .map(|x| SteelVal::SymbolV(x.into())) + .collect::>() + .into() + }); + + // Run the script for building the core interface for structs + // engine.compile_and_run_raw_program(KERNEL).unwrap(); + + let raw_program = engine.emit_raw_program_no_path(KERNEL).unwrap(); + engine.run_raw_program(raw_program.clone()).unwrap(); + + // let mut macros = HashSet::new(); + // macros.insert("%better-lambda%".to_string()); + // macros.insert(*STRUCT_KEYWORD); + // macros.insert(*DEFINE_VALUES); + + ( + Kernel { + // macros, + transformers, + constants: HashSet::new(), + engine: Box::new(engine), + }, + raw_program, + ) + } + + pub(crate) fn initialize_post_bootstrap(mut engine: Engine) -> Self { + let transformers = Transformers { + set: Arc::new(RwLock::new(HashSet::default())), + }; + + let embedded_transformer_object = transformers.clone(); + engine.register_fn("register-macro-transformer!", move |name: String| { + embedded_transformer_object + .set + .write() + .unwrap() + .insert(name.as_str().into()) + }); + + let embedded_transformer_object = transformers.clone(); + engine.register_fn("current-macro-transformers!", move || -> SteelVal { + embedded_transformer_object + .set + .read() + .unwrap() + .iter() + .map(|x| x.resolve().to_string()) + .map(|x| SteelVal::SymbolV(x.into())) + .collect::>() + .into() + }); + + Kernel { + // macros, + transformers, + constants: HashSet::new(), + engine: Box::new(engine), + } + } + pub fn is_constant(&self, ident: &InternedString) -> bool { self.constants.contains(ident) } @@ -122,18 +205,58 @@ impl Kernel { let subset = analysis .exprs .iter() - .filter(|expr| { - if let ExprKind::Define(define) = expr { - if let ExprKind::LambdaFunction(_) = &define.body { - let name = define.name.atom_identifier().unwrap().clone(); - - return result.contains_key(&name); + .filter_map(|expr| { + match expr { + ExprKind::Define(define) => { + if let ExprKind::LambdaFunction(_) = &define.body { + let name = define.name.atom_identifier().unwrap().clone(); + + return if result.contains_key(&name) { + Some(expr.clone()) + } else { + None + }; + } } + ExprKind::Begin(b) => { + let begin = b + .exprs + .iter() + .filter(|expr| { + if let ExprKind::Define(define) = expr { + if let ExprKind::LambdaFunction(_) = &define.body { + let name = define.name.atom_identifier().unwrap().clone(); + + return result.contains_key(&name); + } + } + + false + }) + .cloned() + .collect(); + + return Some(ExprKind::Begin(crate::parser::ast::Begin::new( + begin, + b.location.clone(), + ))); + } + + _ => {} } - false + return None; + + // TODO: Also check begin statements here as well + // if let ExprKind::Define(define) = expr { + // if let ExprKind::LambdaFunction(_) = &define.body { + // let name = define.name.atom_identifier().unwrap().clone(); + + // return result.contains_key(&name); + // } + // } }) - .cloned() + // .cloned() .collect::>(); log::debug!("Loading constant functions"); diff --git a/crates/steel-core/src/parser/rename_idents.rs b/crates/steel-core/src/parser/rename_idents.rs index 0b474133b..6b7b1ead9 100644 --- a/crates/steel-core/src/parser/rename_idents.rs +++ b/crates/steel-core/src/parser/rename_idents.rs @@ -149,8 +149,10 @@ impl<'a> VisitorMutRef for RenameIdentifiersVisitor<'a> { self.visit(&mut s.expr); } - fn visit_require(&mut self, _s: &mut super::ast::Require) -> Self::Output { - todo!() + fn visit_require(&mut self, s: &mut super::ast::Require) -> Self::Output { + for module in &mut s.modules { + self.visit(module); + } } fn visit_let(&mut self, l: &mut super::ast::Let) -> Self::Output { diff --git a/crates/steel-core/src/parser/replace_idents.rs b/crates/steel-core/src/parser/replace_idents.rs index 3269eeebc..0893a06e4 100644 --- a/crates/steel-core/src/parser/replace_idents.rs +++ b/crates/steel-core/src/parser/replace_idents.rs @@ -375,8 +375,16 @@ impl<'a> ConsumingVisitor for ReplaceExpressions<'a> { Ok(ExprKind::Set(s)) } - fn visit_require(&mut self, s: super::ast::Require) -> Self::Output { - stop!(Generic => "unexpected require statement in replace idents"; s.location.span) + fn visit_require(&mut self, mut s: super::ast::Require) -> Self::Output { + s.modules = s + .modules + .into_iter() + .map(|x| self.visit(x)) + .collect::>()?; + + Ok(ExprKind::Require(s)) + + // stop!(Generic => "unexpected require statement in replace idents"; s.location.span) } fn visit_let(&mut self, mut l: Box) -> Self::Output { @@ -500,8 +508,16 @@ impl ConsumingVisitor for RewriteSpan { Ok(ExprKind::Set(s)) } - fn visit_require(&mut self, s: super::ast::Require) -> Self::Output { - stop!(Generic => "unexpected require statement in replace idents"; s.location.span) + fn visit_require(&mut self, mut s: super::ast::Require) -> Self::Output { + s.modules = s + .modules + .into_iter() + .map(|x| self.visit(x)) + .collect::>()?; + + Ok(ExprKind::Require(s)) + + // stop!(Generic => "unexpected require statement in replace idents"; s.location.span) } fn visit_let(&mut self, mut l: Box) -> Self::Output { diff --git a/crates/steel-core/src/parser/tryfrom_visitor.rs b/crates/steel-core/src/parser/tryfrom_visitor.rs index 11ece345f..9ca731f46 100644 --- a/crates/steel-core/src/parser/tryfrom_visitor.rs +++ b/crates/steel-core/src/parser/tryfrom_visitor.rs @@ -1,4 +1,4 @@ -use im_lists::list::List; +use crate::values::lists::List; use crate::{parser::ast::ExprKind, rvals::Syntax}; @@ -84,10 +84,9 @@ impl ConsumingVisitor for TryFromExprKindForSteelVal { if self.inside_quote { // self.visit(quote.expr) - Ok(SteelVal::ListV(im_lists::list![ - SteelVal::SymbolV("quote".into()), - self.visit(quote.expr)? - ])) + Ok(SteelVal::ListV( + vec![SteelVal::SymbolV("quote".into()), self.visit(quote.expr)?].into(), + )) } else { self.inside_quote = true; let res = self.visit(quote.expr); @@ -96,9 +95,19 @@ impl ConsumingVisitor for TryFromExprKindForSteelVal { } } - fn visit_macro(&mut self, _m: super::ast::Macro) -> Self::Output { + fn visit_macro(&mut self, m: super::ast::Macro) -> Self::Output { // TODO - stop!(Generic => "internal compiler error - could not translate macro to steel value") + + Ok(SteelVal::ListV( + vec![ + SteelVal::SymbolV("define-syntax".into()), + self.visit(*m.name)?, + self.visit_syntax_rules(m.syntax_rules)?, + ] + .into(), + )) + + // stop!(Generic => "internal compiler error - could not translate macro to steel value") } fn visit_atom(&mut self, a: Atom) -> Self::Output { @@ -112,9 +121,31 @@ impl ConsumingVisitor for TryFromExprKindForSteelVal { Ok(items?.into()) } - fn visit_syntax_rules(&mut self, _l: super::ast::SyntaxRules) -> Self::Output { + fn visit_syntax_rules(&mut self, s: super::ast::SyntaxRules) -> Self::Output { + Ok(SteelVal::ListV( + vec![ + SteelVal::SymbolV("syntax-rules".into()), + SteelVal::ListV( + s.syntax + .into_iter() + .map(|x| self.visit(x)) + .collect::>()?, + ), + SteelVal::ListV( + s.patterns + .into_iter() + .map(|x| { + Ok(SteelVal::ListV( + vec![self.visit(x.pattern)?, self.visit(x.body)?].into(), + )) + }) + .collect::>()?, + ), + ] + .into(), + )) // TODO - stop!(Generic => "internal compiler error - could not translate syntax-rules to steel value") + // stop!(Generic => "internal compiler error - could not translate syntax-rules to steel value") } fn visit_set(&mut self, s: Box) -> Self::Output { @@ -122,8 +153,19 @@ impl ConsumingVisitor for TryFromExprKindForSteelVal { Ok(SteelVal::ListV(expr.into_iter().collect())) } - fn visit_require(&mut self, _s: super::ast::Require) -> Self::Output { - stop!(Generic => "internal compiler error - could not translate require to steel value") + fn visit_require(&mut self, r: super::ast::Require) -> Self::Output { + // Just convert it into a list + + // r.modules + Ok(SteelVal::ListV(List::cons( + SteelVal::SymbolV("require".into()), + r.modules + .into_iter() + .map(|x| self.visit(x)) + .collect::>()?, + ))) + + // stop!(Generic => "internal compiler error - could not translate require to steel value") } fn visit_let(&mut self, l: Box) -> Self::Output { @@ -248,10 +290,9 @@ impl ConsumingVisitor for SyntaxObjectFromExprKind { let raw = SteelVal::try_from(ExprKind::Quote(quote.clone()))?; Ok(Syntax::proto( raw, - SteelVal::ListV(im_lists::list![ - SteelVal::SymbolV("quote".into()), - self.visit(quote.expr)? - ]), + SteelVal::ListV( + vec![SteelVal::SymbolV("quote".into()), self.visit(quote.expr)?].into(), + ), span, ) .into()) @@ -299,11 +340,34 @@ impl ConsumingVisitor for SyntaxObjectFromExprKind { // TODO: we're currently erasing the source here... This isn't what we want to do but we don't have // a great model to access the source otherwise - log::warn!("Erasing the source information during kernel level expansion"); + log::trace!("Erasing the source information during kernel level expansion"); Ok(Syntax::proto(raw, items.into(), span).into()) } - fn visit_syntax_rules(&mut self, _l: super::ast::SyntaxRules) -> Self::Output { + fn visit_syntax_rules(&mut self, _s: super::ast::SyntaxRules) -> Self::Output { + // Ok(SteelVal::ListV( + // vec![ + // SteelVal::SymbolV("syntax-rules".into()), + // SteelVal::ListV( + // s.syntax + // .into_iter() + // .map(|x| self.visit(x)) + // .collect::>()?, + // ), + // SteelVal::ListV( + // s.patterns + // .into_iter() + // .map(|x| { + // Ok(SteelVal::ListV( + // vec![self.visit(x.pattern)?, self.visit(x.body)?].into(), + // )) + // }) + // .collect::>()?, + // ), + // ] + // .into(), + // )) + // TODO stop!(Generic => "internal compiler error - could not translate syntax-rules to steel value") } diff --git a/crates/steel-core/src/primitives.rs b/crates/steel-core/src/primitives.rs index e653d4050..f33f6e343 100644 --- a/crates/steel-core/src/primitives.rs +++ b/crates/steel-core/src/primitives.rs @@ -30,9 +30,12 @@ pub mod blocking_requests; #[cfg(feature = "colors")] pub mod colors; +pub use lists::UnRecoverableResult; + +use crate::values::closed::HeapRef; +use crate::values::lists::List; pub use control::ControlOperations; -pub use fs::FsFunctions; -use im_lists::list::List; +pub use fs::fs_module; pub use io::IoFunctions; pub use meta_ops::MetaOperations; pub use nums::NumOperations; @@ -45,7 +48,9 @@ pub use strings::string_module; pub use nums::{add_primitive, divide_primitive, multiply_primitive, subtract_primitive}; -use crate::rvals::{FunctionSignature, PrimitiveAsRef, SteelVal}; +use crate::rvals::{ + FunctionSignature, PrimitiveAsRef, SteelHashMap, SteelHashSet, SteelVal, SteelVector, +}; use crate::values::port::SteelPort; use crate::{ rerrs::{ErrorKind, SteelErr}, @@ -366,6 +371,17 @@ impl<'a> PrimitiveAsRef<'a> for &'a Gc> { } } +impl<'a> PrimitiveAsRef<'a> for &'a HeapRef { + #[inline(always)] + fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { + if let SteelVal::HeapAllocated(b) = val { + Ok(b) + } else { + crate::stop!(ConversionError => format!("Cannot convert steel value: {} to steel box", val)) + } + } +} + impl<'a> PrimitiveAsRef<'a> for &'a char { #[inline(always)] fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { @@ -394,12 +410,23 @@ impl<'a> PrimitiveAsRef<'a> for isize { if let SteelVal::IntV(i) = val { Ok(*i) } else { - crate::stop!(ConversionError => format!("Cannot convert steel value: {} to steel character", val)) + crate::stop!(ConversionError => format!("Cannot convert steel value: {} to steel int", val)) } } } impl<'a> PrimitiveAsRef<'a> for &'a Gc> { + #[inline(always)] + fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { + if let SteelVal::VectorV(p) = val { + Ok(&p.0) + } else { + crate::stop!(ConversionError => format!("Cannot convert steel value: {} to steel vector", val)) + } + } +} + +impl<'a> PrimitiveAsRef<'a> for &'a SteelVector { #[inline(always)] fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { if let SteelVal::VectorV(p) = val { @@ -411,6 +438,17 @@ impl<'a> PrimitiveAsRef<'a> for &'a Gc> { } impl<'a> PrimitiveAsRef<'a> for &'a Gc> { + #[inline(always)] + fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { + if let SteelVal::HashSetV(p) = val { + Ok(&p.0) + } else { + crate::stop!(ConversionError => format!("Cannot convert steel value: {} to steel hashset", val)) + } + } +} + +impl<'a> PrimitiveAsRef<'a> for &'a SteelHashSet { #[inline(always)] fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { if let SteelVal::HashSetV(p) = val { @@ -421,7 +459,7 @@ impl<'a> PrimitiveAsRef<'a> for &'a Gc> { } } -impl<'a> PrimitiveAsRef<'a> for &'a Gc>> { +impl<'a> PrimitiveAsRef<'a> for &'a HeapRef> { #[inline(always)] fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { if let SteelVal::MutableVector(p) = val { @@ -473,6 +511,17 @@ impl<'a> PrimitiveAsRef<'a> for &'a SteelString { } impl<'a> PrimitiveAsRef<'a> for &'a Gc> { + #[inline(always)] + fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { + if let SteelVal::HashMapV(hm) = val { + Ok(&hm.0) + } else { + crate::stop!(ConversionError => format!("Canto convert steel value: {} to hashmap", val)) + } + } +} + +impl<'a> PrimitiveAsRef<'a> for &'a SteelHashMap { #[inline(always)] fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result { if let SteelVal::HashMapV(hm) = val { @@ -525,7 +574,7 @@ impl IntoSteelVal for bool { impl From> for SteelVal { fn from(val: Vector) -> SteelVal { - SteelVal::VectorV(Gc::new(val)) + SteelVal::VectorV(Gc::new(val).into()) } } diff --git a/crates/steel-core/src/primitives/contracts.rs b/crates/steel-core/src/primitives/contracts.rs index 18074e986..3bc1dcdd7 100644 --- a/crates/steel-core/src/primitives/contracts.rs +++ b/crates/steel-core/src/primitives/contracts.rs @@ -1,91 +1,91 @@ -use crate::values::contracts::*; -use crate::{builtin_stop, stop}; -use crate::{ - rvals::{Result, SteelVal}, - steel_vm::vm::VmCore, -}; - -pub const MAKE_C: SteelVal = SteelVal::FuncV(make_c); -pub const MAKE_DEPENDENT_CONTRACT: SteelVal = SteelVal::FuncV(make_dependent_contract); -pub const MAKE_FLAT_CONTRACT: SteelVal = SteelVal::FuncV(make_flat_contract); -pub const MAKE_FUNCTION_CONTRACT: SteelVal = SteelVal::FuncV(make_function_contract); -pub const BIND_CONTRACT_TO_FUNCTION: SteelVal = SteelVal::BuiltIn(bind_contract_to_function); - -pub fn make_c(args: &[SteelVal]) -> Result { - if args.is_empty() { - stop!(ArityMismatch => "make/c given no arguments"); - } - - let contract = args[0].clone(); - if contract.is_contract() { - return Ok(contract); - } - - if args.len() == 2 { - let function = args[0].clone(); - let name = args[1].clone(); - - if function.is_function() { - return FlatContract::new_from_steelval(function, name.to_string()); - } - } - - if let Some((last, elements)) = args.split_last() { - let last = last.clone(); - FunctionContract::new_from_steelval(elements, last) - } else { - stop!(ArityMismatch => "function contract missing range position") - } -} - -pub fn make_dependent_contract(args: &[SteelVal]) -> Result { - if let Some((last, elements)) = args.split_last() { - let last = last.clone(); - DependentContract::new_from_steelvals(elements, last) - } else { - stop!(ArityMismatch => "function contract missing range position") - } -} - -pub fn make_flat_contract(args: &[SteelVal]) -> Result { - if args.len() != 2 { - stop!(ArityMismatch => "make/c requires 2 argments, the contract and the name") - } - - let function = args[0].clone(); - let name = args[1].clone(); - - if let SteelVal::SymbolV(s) = name { - FlatContract::new_from_steelval(function, s.to_string()) - } else { - stop!(TypeMismatch => "make-flat/c requires a symbol for the name in the second position") - } -} - -pub fn make_function_contract(args: &[SteelVal]) -> Result { - if let Some((last, elements)) = args.split_last() { - let last = last.clone(); - FunctionContract::new_from_steelval(elements, last) - } else { - stop!(ArityMismatch => "function contract missing range position") - } -} - -pub fn bind_contract_to_function(ctx: &mut VmCore, args: &[SteelVal]) -> Option> { - if args.len() < 2 || args.len() > 4 { - builtin_stop!(ArityMismatch => "bind/c requires 2 arguments, a contract and a function") - } - - let contract = args[0].clone(); - let function = args[1].clone(); - - if !ctx.thread.runtime_options.contracts_on { - return Some(Ok(function)); - } - - let name = args.get(2).cloned(); - - Some(ContractedFunction::new_from_steelvals( - contract, function, name, - )) -} +// use crate::values::contracts::*; +// use crate::{builtin_stop, stop}; +// use crate::{ +// rvals::{Result, SteelVal}, +// steel_vm::vm::VmCore, +// }; + +// pub const MAKE_C: SteelVal = SteelVal::FuncV(make_c); +// pub const MAKE_DEPENDENT_CONTRACT: SteelVal = SteelVal::FuncV(make_dependent_contract); +// pub const MAKE_FLAT_CONTRACT: SteelVal = SteelVal::FuncV(make_flat_contract); +// pub const MAKE_FUNCTION_CONTRACT: SteelVal = SteelVal::FuncV(make_function_contract); +// pub const BIND_CONTRACT_TO_FUNCTION: SteelVal = SteelVal::BuiltIn(bind_contract_to_function); + +// pub fn make_c(args: &[SteelVal]) -> Result { +// if args.is_empty() { +// stop!(ArityMismatch => "make/c given no arguments"); +// } + +// let contract = args[0].clone(); +// if contract.is_contract() { +// return Ok(contract); +// } + +// if args.len() == 2 { +// let function = args[0].clone(); +// let name = args[1].clone(); + +// if function.is_function() { +// return FlatContract::new_from_steelval(function, name.to_string()); +// } +// } + +// if let Some((last, elements)) = args.split_last() { +// let last = last.clone(); +// FunctionContract::new_from_steelval(elements, last) +// } else { +// stop!(ArityMismatch => "function contract missing range position") +// } +// } + +// pub fn make_dependent_contract(args: &[SteelVal]) -> Result { +// if let Some((last, elements)) = args.split_last() { +// let last = last.clone(); +// DependentContract::new_from_steelvals(elements, last) +// } else { +// stop!(ArityMismatch => "function contract missing range position") +// } +// } + +// pub fn make_flat_contract(args: &[SteelVal]) -> Result { +// if args.len() != 2 { +// stop!(ArityMismatch => "make/c requires 2 argments, the contract and the name") +// } + +// let function = args[0].clone(); +// let name = args[1].clone(); + +// if let SteelVal::SymbolV(s) = name { +// FlatContract::new_from_steelval(function, s.to_string()) +// } else { +// stop!(TypeMismatch => "make-flat/c requires a symbol for the name in the second position") +// } +// } + +// pub fn make_function_contract(args: &[SteelVal]) -> Result { +// if let Some((last, elements)) = args.split_last() { +// let last = last.clone(); +// FunctionContract::new_from_steelval(elements, last) +// } else { +// stop!(ArityMismatch => "function contract missing range position") +// } +// } + +// pub fn bind_contract_to_function(ctx: &mut VmCore, args: &[SteelVal]) -> Option> { +// if args.len() < 2 || args.len() > 4 { +// builtin_stop!(ArityMismatch => "bind/c requires 2 arguments, a contract and a function") +// } + +// let contract = args[0].clone(); +// let function = args[1].clone(); + +// if !ctx.thread.runtime_options.contracts_on { +// return Some(Ok(function)); +// } + +// let name = args.get(2).cloned(); + +// Some(ContractedFunction::new_from_steelvals( +// contract, function, name, +// )) +// } diff --git a/crates/steel-core/src/primitives/fs.rs b/crates/steel-core/src/primitives/fs.rs index 54f5a616c..bb5f7840e 100644 --- a/crates/steel-core/src/primitives/fs.rs +++ b/crates/steel-core/src/primitives/fs.rs @@ -1,7 +1,8 @@ -use crate::rvals::{Result, SteelVal}; +use crate::rvals::{Custom, Result, SteelString, SteelVal}; +use crate::steel_vm::builtin::BuiltInModule; use crate::stop; use std::env::current_dir; -use std::path::Path; +use std::path::{Path, PathBuf}; use std::fs; use std::io; @@ -28,194 +29,124 @@ pub fn copy_recursively(source: impl AsRef, destination: impl AsRef) Ok(()) } -pub struct FsFunctions {} -impl FsFunctions { - pub fn delete_directory() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.len() == 1 { - let source = if let SteelVal::StringV(s) = &args[0] { - s - } else { - stop!(TypeMismatch => format!("delete-directory! expects a string, found: {}", &args[0])) - }; - - std::fs::remove_dir_all(source.as_str())?; - - Ok(SteelVal::Void) - } else { - stop!(ArityMismatch => format!("delete-directory! takes two arguments, found: {}", args.len())) - } - }) +impl Custom for PathBuf { + fn fmt(&self) -> Option> { + Some(Ok(format!("#", self))) } +} - pub fn create_dir_all() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.len() == 1 { - let source = if let SteelVal::StringV(s) = &args[0] { - s - } else { - stop!(TypeMismatch => format!("create-directory! expects a string, found: {}", &args[0])) - }; - - std::fs::create_dir_all(source.as_str())?; - - Ok(SteelVal::Void) - } else { - stop!(ArityMismatch => format!("create-directory! takes two arguments, found: {}", args.len())) - } - }) - } +/// # steel/filesystem +/// +/// Filesystem functions, mostly just thin wrappers around the `std::fs` functions in +/// the Rust std library. +#[steel_derive::define_module(name = "steel/filesystem")] +pub fn fs_module() -> BuiltInModule { + let mut module = BuiltInModule::new("steel/filesystem"); + module + .register_native_fn_definition(DELETE_DIRECTORY_DEFINITION) + .register_native_fn_definition(CREATE_DIRECTORY_DEFINITION) + .register_native_fn_definition(COPY_DIRECTORY_RECURSIVELY_DEFINITION) + .register_native_fn_definition(IS_DIR_DEFINITION) + .register_native_fn_definition(IS_FILE_DEFINITION) + .register_native_fn_definition(READ_DIR_DEFINITION) + .register_native_fn_definition(PATH_EXISTS_DEFINITION) + .register_native_fn_definition(FILE_NAME_DEFINITION) + .register_native_fn_definition(CURRENT_DIRECTORY_DEFINITION) + .register_native_fn_definition(GET_EXTENSION_DEFINITION); + module +} - pub fn copy_directory_recursively() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.len() == 2 { - let source = if let SteelVal::StringV(s) = &args[0] { - s - } else { - stop!(TypeMismatch => format!("copy-directory-recursively! expects a string, found: {}", &args[0])) - }; - - let destination = if let SteelVal::StringV(s) = &args[1] { - s - } else { - stop!(TypeMismatch => format!("copy-directory-recursively! expects a string, found: {}", &args[0])) - }; - - copy_recursively(source.as_str(), destination.as_str())?; - - Ok(SteelVal::Void) - } else { - stop!(ArityMismatch => format!("copy-directory-recursively! takes two arguments, found: {}", args.len())) - } - }) - } +/// Deletes the directory +#[steel_derive::function(name = "delete-directory!")] +pub fn delete_directory(directory: &SteelString) -> Result { + std::fs::remove_dir_all(directory.as_str())?; + Ok(SteelVal::Void) +} - pub fn path_exists() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.len() == 1 { - if let SteelVal::StringV(s) = &args[0] { - Ok(SteelVal::BoolV(Path::new(s.as_ref()).exists())) - } else { - stop!(TypeMismatch => "path-exists? expects a string") - } - } else { - stop!(ArityMismatch => "path-exists? takes one argument") - } - }) - } +/// Creates the directory +#[steel_derive::function(name = "create-directory!")] +pub fn create_directory(directory: &SteelString) -> Result { + std::fs::create_dir_all(directory.as_str())?; - pub fn is_file() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.len() == 1 { - // let path = - - if let SteelVal::StringV(s) = &args[0] { - Ok(SteelVal::BoolV(Path::new(s.as_ref()).is_file())) - } else { - stop!(TypeMismatch => format!("is-file? expects a string, found: {}", &args[0])) - } - } else { - stop!(ArityMismatch => "is-file? takes one argument") - } - }) - } + Ok(SteelVal::Void) +} - pub fn get_extension(args: &[SteelVal]) -> Result { - if args.len() == 1 { - if let SteelVal::StringV(s) = &args[0] { - if let Some(ext) = get_extension_from_filename(s) { - Ok(SteelVal::StringV(ext.into())) - } else { - Ok(SteelVal::Void) - - // stop!(Generic => format!("path->extension expects a path that exists, found: {s}")) - } - } else { - stop!(TypeMismatch => format!("path->extension expects a string, found: {}", &args[0])) - } - } else { - stop!(ArityMismatch => format!("path->extension takes one argument, found: {}", args.len())) - } - } +/// Recursively copies the directory from source to destination +#[steel_derive::function(name = "copy-directory-recursively!")] +pub fn copy_directory_recursively( + source: &SteelString, + destination: &SteelString, +) -> Result { + copy_recursively(source.as_str(), destination.as_str())?; - pub fn is_dir() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.len() == 1 { - // let path = - - if let SteelVal::StringV(s) = &args[0] { - Ok(SteelVal::BoolV(Path::new(&s.to_string()).is_dir())) - } else { - stop!(TypeMismatch => "is-dir? expects a string") - } - } else { - stop!(ArityMismatch => "is-dir? takes one argument") - } - }) - } + Ok(SteelVal::Void) +} - pub fn file_name() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.len() == 1 { - if let SteelVal::StringV(s) = &args[0] { - Ok(SteelVal::StringV( - Path::new(s.as_str()) - .file_name() - .and_then(|x| x.to_str()) - .unwrap_or("") - .into(), - )) - } else { - stop!(TypeMismatch => "file-name expects a string") - } - } else { - stop!(ArityMismatch => "file-name takes one argument") - } - }) - } +/// Checks if a path exists +#[steel_derive::function(name = "path-exists?")] +pub fn path_exists(path: &SteelString) -> Result { + Ok(SteelVal::BoolV(Path::new(path.as_ref()).exists())) +} + +/// Checks if a path is a file +#[steel_derive::function(name = "is-file?")] +pub fn is_file(path: &SteelString) -> Result { + Ok(SteelVal::BoolV(Path::new(path.as_ref()).is_file())) +} + +/// Checks if a path is a directory +#[steel_derive::function(name = "is-dir?")] +pub fn is_dir(path: &SteelString) -> Result { + Ok(SteelVal::BoolV(Path::new(path.as_ref()).is_dir())) +} - pub fn read_dir() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.len() == 1 { - // let path = - - if let SteelVal::StringV(s) = &args[0] { - let p = Path::new(s.as_ref()); - if p.is_dir() { - let iter = p.read_dir(); - match iter { - Ok(i) => Ok(SteelVal::ListV( - i.into_iter() - .map(|x| match x?.path().to_str() { - Some(s) => Ok(SteelVal::StringV(s.into())), - None => Ok(SteelVal::BoolV(false)), - }) - .collect::>()?, - )), - Err(e) => stop!(Generic => e.to_string()), - } - } else { - stop!(TypeMismatch => "read-dir expected a dir, found a file") - } - } else { - stop!(TypeMismatch => "read-dir expects a string") - } - } else { - stop!(ArityMismatch => "read-dir takes one argument") - } - }) +/// Gets the extension from a path +#[steel_derive::function(name = "path->extension")] +pub fn get_extension(path: &SteelString) -> Result { + if let Some(ext) = get_extension_from_filename(path) { + Ok(SteelVal::StringV(ext.into())) + } else { + Ok(SteelVal::Void) } +} + +/// Gets the filename for a given path +#[steel_derive::function(name = "file-name")] +pub fn file_name(path: &SteelString) -> Result { + Ok(SteelVal::StringV( + Path::new(path.as_str()) + .file_name() + .and_then(|x| x.to_str()) + .unwrap_or("") + .into(), + )) +} - pub fn current_dir() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - if args.is_empty() { - let path = current_dir()?; - Ok(SteelVal::StringV(path.to_str().unwrap_or("").into())) - // println!("The current directory is {}", path.display()); - // Ok(()) - } else { - stop!(ArityMismatch => "current-directory takes no arguments") - } - }) +/// Returns the contents of the directory as a list +#[steel_derive::function(name = "read-dir")] +pub fn read_dir(path: &SteelString) -> Result { + let p = Path::new(path.as_ref()); + if p.is_dir() { + let iter = p.read_dir(); + match iter { + Ok(i) => Ok(SteelVal::ListV( + i.into_iter() + .map(|x| match x?.path().to_str() { + Some(s) => Ok(SteelVal::StringV(s.into())), + None => Ok(SteelVal::BoolV(false)), + }) + .collect::>()?, + )), + Err(e) => stop!(Generic => e.to_string()), + } + } else { + stop!(TypeMismatch => "read-dir expected a dir, found a file: {}", path) } } + +/// Check the current working directory +#[steel_derive::function(name = "current-directory")] +pub fn current_directory() -> Result { + let path = current_dir()?; + Ok(SteelVal::StringV(path.to_str().unwrap_or("").into())) +} diff --git a/crates/steel-core/src/primitives/hashmaps.rs b/crates/steel-core/src/primitives/hashmaps.rs index b735c0c94..260afa20c 100644 --- a/crates/steel-core/src/primitives/hashmaps.rs +++ b/crates/steel-core/src/primitives/hashmaps.rs @@ -87,7 +87,7 @@ pub fn hm_construct(args: &[SteelVal]) -> Result { } } - Ok(SteelVal::HashMapV(Gc::new(hm))) + Ok(SteelVal::HashMapV(Gc::new(hm).into())) } pub fn hm_construct_keywords(args: &[SteelVal]) -> Result { @@ -111,7 +111,7 @@ pub fn hm_construct_keywords(args: &[SteelVal]) -> Result { } } - Ok(SteelVal::HashMapV(Gc::new(hm))) + Ok(SteelVal::HashMapV(Gc::new(hm).into())) } /// Returns a new hashmap with the additional key value pair added. Performs a functional update, @@ -140,7 +140,7 @@ pub fn hash_insert( value: SteelVal, ) -> Result { if key.is_hashable() { - Ok(SteelVal::HashMapV(Gc::new(map.update(key, value)))) + Ok(SteelVal::HashMapV(Gc::new(map.update(key, value)).into())) } else { stop!(TypeMismatch => "hash key not hashable: {:?}", key) } @@ -309,9 +309,9 @@ pub fn clear(args: &[SteelVal]) -> Result { let hashmap = &args[0]; if let SteelVal::HashMapV(hm) = hashmap { - let mut hm = hm.unwrap(); + let mut hm = hm.0.unwrap(); hm.clear(); - Ok(SteelVal::HashMapV(Gc::new(hm))) + Ok(SteelVal::HashMapV(Gc::new(hm).into())) } else { stop!(TypeMismatch => "hm-clear takes a hashmap") } @@ -341,9 +341,9 @@ pub fn hm_union(args: &[SteelVal]) -> Result { if let SteelVal::HashMapV(hml) = left { if let SteelVal::HashMapV(hmr) = right { - let hml = hml.unwrap(); - let hmr = hmr.unwrap(); - Ok(SteelVal::HashMapV(Gc::new(hml.union(hmr)))) + let hml = hml.0.unwrap(); + let hmr = hmr.0.unwrap(); + Ok(SteelVal::HashMapV(Gc::new(hml.union(hmr)).into())) } else { stop!(TypeMismatch => "hash-union takes a hashmap, found {}", right) } @@ -368,10 +368,13 @@ mod hashmap_tests { StringV("bar2".into()), ]; let res = hm_construct(&args); - let expected = SteelVal::HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()), - StringV("foo2".into()) => StringV("bar2".into()) - })); + let expected = SteelVal::HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()), + StringV("foo2".into()) => StringV("bar2".into()) + }) + .into(), + ); assert_eq!(res.unwrap(), expected); } @@ -388,33 +391,42 @@ mod hashmap_tests { StringV("bar2".into()), ]; let res = hm_construct(&args); - let expected = SteelVal::HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()), - StringV("foo2".into()) => StringV("bar2".into()) - })); + let expected = SteelVal::HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()), + StringV("foo2".into()) => StringV("bar2".into()) + }) + .into(), + ); assert_eq!(res.unwrap(), expected); } #[test] fn hm_insert_from_empty() { let args = [ - HashMapV(Gc::new(hashmap![])), + HashMapV(Gc::new(hashmap![]).into()), StringV("foo".into()), StringV("bar".into()), ]; let res = steel_hash_insert(&args); - let expected = SteelVal::HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()) - })); + let expected = SteelVal::HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()) + }) + .into(), + ); assert_eq!(res.unwrap(), expected); } #[test] fn hm_get_found() { let args = [ - HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()) - })), + HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()) + }) + .into(), + ), StringV("foo".into()), ]; let res = steel_hash_ref(&args); @@ -425,9 +437,12 @@ mod hashmap_tests { #[test] fn hm_get_error() { let args = [ - HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()) - })), + HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()) + }) + .into(), + ), StringV("garbage".into()), ]; let res = steel_hash_ref(&args); @@ -437,9 +452,12 @@ mod hashmap_tests { #[test] fn hm_try_get_found() { let args = [ - HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()) - })), + HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()) + }) + .into(), + ), StringV("foo".into()), ]; let res = steel_hash_try_get(&args); @@ -450,9 +468,12 @@ mod hashmap_tests { #[test] fn hm_try_get_error() { let args = [ - HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()) - })), + HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()) + }) + .into(), + ), StringV("garbage".into()), ]; let res = steel_hash_contains(&args); @@ -463,9 +484,12 @@ mod hashmap_tests { #[test] fn hm_contains_true() { let args = [ - HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()) - })), + HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()) + }) + .into(), + ), StringV("foo".into()), ]; let res = steel_hash_contains(&args); @@ -476,9 +500,12 @@ mod hashmap_tests { #[test] fn hm_contains_false() { let args = [ - HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()) - })), + HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()) + }) + .into(), + ), StringV("bar".into()), ]; let res = steel_hash_contains(&args); @@ -488,21 +515,21 @@ mod hashmap_tests { #[test] fn hm_keys_to_vector_normal() { - let args = vec![HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()), - StringV("bar".into()) => StringV("baz".into()), - StringV("baz".into()) => StringV("quux".into()) - }))]; + let args = vec![HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()), + StringV("bar".into()) => StringV("baz".into()), + StringV("baz".into()) => StringV("quux".into()) + }) + .into(), + )]; let res = keys_to_vector(&args); - let expected = SteelVal::VectorV(Gc::new( - vec![ - SteelVal::StringV("foo".into()), - SteelVal::StringV("bar".into()), - SteelVal::StringV("baz".into()), - ] - .into_iter() - .collect(), - )); + let expected = im_rc::vector![ + SteelVal::StringV("foo".into()), + SteelVal::StringV("bar".into()), + SteelVal::StringV("baz".into()), + ] + .into(); // pull out the vectors and sort them // let unwrapped_res: SteelVal = (*res.unwrap()).clone(); @@ -544,21 +571,21 @@ mod hashmap_tests { #[test] fn hm_values_to_vector_normal() { - let args = vec![HashMapV(Gc::new(hashmap! { - StringV("foo".into()) => StringV("bar".into()), - StringV("bar".into()) => StringV("baz".into()), - StringV("baz".into()) => StringV("quux".into()) - }))]; + let args = vec![HashMapV( + Gc::new(hashmap! { + StringV("foo".into()) => StringV("bar".into()), + StringV("bar".into()) => StringV("baz".into()), + StringV("baz".into()) => StringV("quux".into()) + }) + .into(), + )]; let res = values_to_vector(&args); - let expected = SteelVal::VectorV(Gc::new( - vec![ - SteelVal::StringV("bar".into()), - SteelVal::StringV("baz".into()), - SteelVal::StringV("quux".into()), - ] - .into_iter() - .collect(), - )); + let expected = im_rc::vector![ + SteelVal::StringV("bar".into()), + SteelVal::StringV("baz".into()), + SteelVal::StringV("quux".into()), + ] + .into(); // pull out the vectors and sort them diff --git a/crates/steel-core/src/primitives/hashsets.rs b/crates/steel-core/src/primitives/hashsets.rs index 1cfd75f30..56aff7a44 100644 --- a/crates/steel-core/src/primitives/hashsets.rs +++ b/crates/steel-core/src/primitives/hashsets.rs @@ -1,10 +1,10 @@ use crate::stop; +use crate::values::lists::List; use crate::{ core::utils::declare_const_ref_functions, rvals::{Result, SteelVal}, }; use crate::{gc::Gc, steel_vm::builtin::BuiltInModule}; -use im_lists::list::List; use im_rc::HashSet; use crate::primitives::VectorOperations; @@ -47,7 +47,7 @@ pub fn hs_construct(args: &[SteelVal]) -> Result { } } - Ok(SteelVal::HashSetV(Gc::new(hs))) + Ok(SteelVal::HashSetV(Gc::new(hs).into())) } pub fn hs_length(args: &[SteelVal]) -> Result { @@ -73,13 +73,13 @@ pub fn hs_insert(args: &[SteelVal]) -> Result { let key = &args[1]; if let SteelVal::HashSetV(hs) = hashset { - let mut hs = hs.unwrap(); + let mut hs = hs.0.unwrap(); if key.is_hashable() { hs.insert(key.clone()); } else { stop!(TypeMismatch => "hash key not hashable!"); } - Ok(SteelVal::HashSetV(Gc::new(hs))) + Ok(SteelVal::HashSetV(Gc::new(hs).into())) } else { stop!(TypeMismatch => "set insert takes a set") } @@ -114,7 +114,7 @@ pub fn is_subset(args: &[SteelVal]) -> Result { if let SteelVal::HashSetV(left) = left { if let SteelVal::HashSetV(right) = right { - Ok(SteelVal::BoolV(left.is_subset(right.as_ref()))) + Ok(SteelVal::BoolV(left.is_subset(right.0.as_ref()))) } else { stop!(TypeMismatch => "hash-subset? takes a hashset") } @@ -163,9 +163,9 @@ pub fn clear(args: &[SteelVal]) -> Result { let hashset = &args[0]; if let SteelVal::HashSetV(hs) = hashset { - let mut hs = hs.unwrap(); + let mut hs = hs.0.unwrap(); hs.clear(); - Ok(SteelVal::HashSetV(Gc::new(hs))) + Ok(SteelVal::HashSetV(Gc::new(hs).into())) } else { stop!(TypeMismatch => "hs-clear takes a hashmap") } @@ -176,7 +176,9 @@ pub fn list_to_hashset(args: &[SteelVal]) -> Result { stop!(ArityMismatch => "list->hashset takes one argument") } if let SteelVal::ListV(l) = &args[0] { - Ok(SteelVal::HashSetV(Gc::new(l.iter().cloned().collect()))) + Ok(SteelVal::HashSetV( + Gc::new(l.iter().cloned().collect::>()).into(), + )) } else { stop!(TypeMismatch => "list->hashset takes a hashset"); } @@ -197,17 +199,20 @@ mod hashset_tests { SteelVal::StringV("bar2".into()), ]; let res = hs_construct(&args); - let expected = SteelVal::HashSetV(Gc::new( - vec![ - SteelVal::StringV("foo".into()), - SteelVal::StringV("bar".into()), - SteelVal::StringV("foo2".into()), - SteelVal::StringV("bar2".into()), - ] - .into_iter() - .map(Gc::new) - .collect(), - )); + let expected = SteelVal::HashSetV( + Gc::new( + vec![ + SteelVal::StringV("foo".into()), + SteelVal::StringV("bar".into()), + SteelVal::StringV("foo2".into()), + SteelVal::StringV("bar2".into()), + ] + .into_iter() + .map(Gc::new) + .collect::>(), + ) + .into(), + ); assert_eq!(res.unwrap(), expected); } @@ -224,45 +229,54 @@ mod hashset_tests { SteelVal::StringV("bar2".into()), ]; let res = hs_construct(&args); - let expected = SteelVal::HashSetV(Gc::new( - vec![ - SteelVal::StringV("foo".into()), - SteelVal::StringV("bar".into()), - SteelVal::StringV("foo2".into()), - SteelVal::StringV("bar2".into()), - ] - .into_iter() - .map(Gc::new) - .collect(), - )); + let expected = SteelVal::HashSetV( + Gc::new( + vec![ + SteelVal::StringV("foo".into()), + SteelVal::StringV("bar".into()), + SteelVal::StringV("foo2".into()), + SteelVal::StringV("bar2".into()), + ] + .into_iter() + .map(Gc::new) + .collect::>(), + ) + .into(), + ); assert_eq!(res.unwrap(), expected); } #[test] fn hs_insert_from_empty() { let args = [ - SteelVal::HashSetV(Gc::new(vec![].into())), + SteelVal::HashSetV(Gc::new(im_rc::HashSet::new()).into()), SteelVal::StringV("foo".into()), ]; let res = hs_insert(&args); - let expected = SteelVal::HashSetV(Gc::new( - vec![SteelVal::StringV("foo".into())] - .into_iter() - .map(Gc::new) - .collect(), - )); + let expected = SteelVal::HashSetV( + Gc::new( + vec![SteelVal::StringV("foo".into())] + .into_iter() + .map(Gc::new) + .collect::>(), + ) + .into(), + ); assert_eq!(res.unwrap(), expected); } #[test] fn hs_contains_true() { let args = [ - SteelVal::HashSetV(Gc::new( - vec![SteelVal::StringV("foo".into())] - .into_iter() - .map(Gc::new) - .collect(), - )), + SteelVal::HashSetV( + Gc::new( + vec![SteelVal::StringV("foo".into())] + .into_iter() + .map(Gc::new) + .collect::>(), + ) + .into(), + ), SteelVal::StringV("foo".into()), ]; let res = hs_contains(&args); @@ -273,12 +287,15 @@ mod hashset_tests { #[test] fn hs_contains_false() { let args = [ - SteelVal::HashSetV(Gc::new( - vec![SteelVal::StringV("foo".into())] - .into_iter() - .map(Gc::new) - .collect(), - )), + SteelVal::HashSetV( + Gc::new( + vec![SteelVal::StringV("foo".into())] + .into_iter() + .map(Gc::new) + .collect::>(), + ) + .into(), + ), SteelVal::StringV("bar".into()), ]; let res = hs_contains(&args); @@ -288,25 +305,25 @@ mod hashset_tests { #[test] fn hs_keys_to_vector_normal() { - let args = [SteelVal::HashSetV(Gc::new( - vec![ - SteelVal::StringV("foo".into()), - SteelVal::StringV("bar".into()), - SteelVal::StringV("baz".into()), - ] - .into_iter() - .collect(), - ))]; + let args = [SteelVal::HashSetV( + Gc::new( + vec![ + SteelVal::StringV("foo".into()), + SteelVal::StringV("bar".into()), + SteelVal::StringV("baz".into()), + ] + .into_iter() + .collect::>(), + ) + .into(), + )]; let res = keys_to_vector(&args); - let expected = SteelVal::VectorV(Gc::new( - vec![ - SteelVal::StringV("foo".into()), - SteelVal::StringV("bar".into()), - SteelVal::StringV("baz".into()), - ] - .into_iter() - .collect(), - )); + let expected = im_rc::vector![ + SteelVal::StringV("foo".into()), + SteelVal::StringV("bar".into()), + SteelVal::StringV("baz".into()), + ] + .into(); // pull out the vectors and sort them // let unwrapped_expected: SteelVal = (*expected).clone(); diff --git a/crates/steel-core/src/primitives/lists.rs b/crates/steel-core/src/primitives/lists.rs index 8a52aae1b..caa92bc25 100644 --- a/crates/steel-core/src/primitives/lists.rs +++ b/crates/steel-core/src/primitives/lists.rs @@ -7,7 +7,8 @@ use crate::{ steel_vm::vm::VmCore, }; use crate::{stop, throw}; -use im_lists::{list, list::List}; + +use crate::values::lists::List; use crate::core::utils::{ arity_check, declare_const_mut_ref_functions, declare_const_ref_functions, @@ -34,7 +35,7 @@ declare_const_mut_ref_functions! { // const LENGTH: SteelVal = SteelVal::FuncV(length); // const NEW: SteelVal = SteelVal::FuncV(new); -pub(crate) struct UnRecoverableResult(Result); +pub struct UnRecoverableResult(Result); impl IntoSteelVal for UnRecoverableResult { #[inline(always)] @@ -234,7 +235,7 @@ Note: In steel, there are only proper lists. Pairs do not exist directly. "#, }; // Do away with improper lists? -fn cons(args: &mut [SteelVal]) -> Result { +pub fn cons(args: &mut [SteelVal]) -> Result { if args.len() != 2 { stop!(ArityMismatch => "cons takes only two arguments") } @@ -245,7 +246,7 @@ fn cons(args: &mut [SteelVal]) -> Result { // Consider moving in a default value instead of cloning? Ok(SteelVal::ListV(right.clone())) } - (left, right) => Ok(SteelVal::ListV(list![left, right.clone()])), + (left, right) => Ok(SteelVal::ListV(vec![left, right.clone()].into())), } } @@ -582,7 +583,7 @@ mod list_operation_tests { fn cons_test_normal_input() { let mut args = [SteelVal::IntV(1), SteelVal::IntV(2)]; let res = cons(&mut args); - let expected = SteelVal::ListV(list![SteelVal::IntV(1), SteelVal::IntV(2)]); + let expected = SteelVal::ListV(vec![SteelVal::IntV(1), SteelVal::IntV(2)].into()); assert_eq!(res.unwrap(), expected); } @@ -614,7 +615,10 @@ mod list_operation_tests { #[test] fn cons_with_non_empty_vector() { - let mut args = [SteelVal::IntV(1), SteelVal::ListV(list![SteelVal::IntV(2)])]; + let mut args = [ + SteelVal::IntV(1), + SteelVal::ListV(vec![SteelVal::IntV(2)].into()), + ]; let res = cons(&mut args); let expected = crate::list![1i32, 2i32]; assert_eq!(res.unwrap(), expected); @@ -678,7 +682,7 @@ mod list_operation_tests { #[test] fn cdr_single_element_list() { - let mut args = [SteelVal::ListV(list![SteelVal::NumV(1.0)])]; + let mut args = [SteelVal::ListV(vec![SteelVal::NumV(1.0)].into())]; let res = cdr(&mut args); let expected = SteelVal::ListV(List::new()); assert_eq!(res.unwrap(), expected); @@ -708,11 +712,8 @@ mod list_operation_tests { fn range_test_normal_input() { let args = [SteelVal::IntV(0), SteelVal::IntV(3)]; let res = steel_range(&args); - let expected = SteelVal::ListV(list![ - SteelVal::IntV(0), - SteelVal::IntV(1), - SteelVal::IntV(2) - ]); + let expected = + SteelVal::ListV(vec![SteelVal::IntV(0), SteelVal::IntV(1), SteelVal::IntV(2)].into()); assert_eq!(res.unwrap(), expected); } } diff --git a/crates/steel-core/src/primitives/meta_ops.rs b/crates/steel-core/src/primitives/meta_ops.rs index bf59dc3e7..76c585022 100644 --- a/crates/steel-core/src/primitives/meta_ops.rs +++ b/crates/steel-core/src/primitives/meta_ops.rs @@ -25,16 +25,16 @@ impl MetaOperations { ); Ok(SteelVal::Void) } - SteelVal::ContractedFunction(c) => { - if let SteelVal::Closure(bytecode_lambda) = &c.function { - crate::core::instructions::pretty_print_dense_instructions( - &bytecode_lambda.body_exp(), - ); - Ok(SteelVal::Void) - } else { - stop!(TypeMismatch => "inspect-bytecode expects a closure object"); - } - } + // SteelVal::ContractedFunction(c) => { + // if let SteelVal::Closure(bytecode_lambda) = &c.function { + // crate::core::instructions::pretty_print_dense_instructions( + // &bytecode_lambda.body_exp(), + // ); + // Ok(SteelVal::Void) + // } else { + // stop!(TypeMismatch => "inspect-bytecode expects a closure object"); + // } + // } _ => { stop!(TypeMismatch => "inspect-bytecode expects a closure object"); } @@ -171,7 +171,7 @@ impl MetaOperations { let futures = join_all(joined_futures).map(|x| { x.into_iter() .collect::>>() - .map(|x| SteelVal::VectorV(Gc::new(x))) + .map(|x| SteelVal::VectorV(Gc::new(x).into())) }); Ok(SteelVal::FutureV(Gc::new(FutureResult::new(Box::pin( diff --git a/crates/steel-core/src/primitives/strings.rs b/crates/steel-core/src/primitives/strings.rs index ab1213b96..b679f89f7 100644 --- a/crates/steel-core/src/primitives/strings.rs +++ b/crates/steel-core/src/primitives/strings.rs @@ -1,4 +1,4 @@ -use im_lists::list::List; +use crate::values::lists::List; use crate::rvals::{RestArgsIter, Result, SteelString, SteelVal}; use crate::steel_vm::builtin::BuiltInModule; @@ -504,7 +504,6 @@ pub fn string_append(mut rest: RestArgsIter<'_, &SteelString>) -> Result Result { Closure(_) | FuncV(_) | BoxedFunction(_) - | ContractedFunction(_) + // | ContractedFunction(_) | BuiltIn(_) | MutFunc(_) => { let mut transducer = Transducer::new(); @@ -123,7 +123,7 @@ pub fn flat_map(args: &[SteelVal]) -> Result { Closure(_) | FuncV(_) | BoxedFunction(_) - | ContractedFunction(_) + // | ContractedFunction(_) | BuiltIn(_) | MutFunc(_) => { let mut transducer = Transducer::new(); @@ -155,7 +155,7 @@ pub fn filter(args: &[SteelVal]) -> Result { Closure(_) | FuncV(_) | BoxedFunction(_) - | ContractedFunction(_) + // | ContractedFunction(_) | BuiltIn(_) | MutFunc(_) => { let mut transducer = Transducer::new(); diff --git a/crates/steel-core/src/primitives/vectors.rs b/crates/steel-core/src/primitives/vectors.rs index 5329d830a..09abeb93c 100644 --- a/crates/steel-core/src/primitives/vectors.rs +++ b/crates/steel-core/src/primitives/vectors.rs @@ -1,8 +1,7 @@ -use std::{cell::RefCell, ops::DerefMut}; - use crate::gc::Gc; use crate::rvals::SteelVal::*; use crate::rvals::{Result, SteelVal}; +use crate::steel_vm::vm::VmCore; use crate::stop; use im_rc::Vector; @@ -10,17 +9,19 @@ pub struct VectorOperations {} impl VectorOperations { pub fn vec_construct() -> SteelVal { SteelVal::FuncV(|args: &[SteelVal]| -> Result { - Ok(SteelVal::VectorV(Gc::new(args.iter().cloned().collect()))) + Ok(SteelVal::VectorV( + Gc::new(args.iter().cloned().collect::>()).into(), + )) }) } // TODO pub fn mut_vec_construct() -> SteelVal { - SteelVal::FuncV(|args: &[SteelVal]| -> Result { - Ok(SteelVal::MutableVector(Gc::new(RefCell::new( - args.to_vec(), - )))) - }) + SteelVal::BuiltIn( + |ctx: &mut VmCore, args: &[SteelVal]| -> Option> { + Some(Ok(ctx.make_mutable_vector(args.to_vec()))) + }, + ) } pub fn mut_vec_to_list() -> SteelVal { @@ -32,9 +33,10 @@ impl VectorOperations { let vec = &args[0]; if let SteelVal::MutableVector(v) = vec { - let mut guard = v.borrow_mut(); + let ptr = v.strong_ptr(); + let guard = &mut ptr.borrow_mut().value; - let new = std::mem::replace(guard.deref_mut(), Vec::new()); + let new = std::mem::replace(guard, Vec::new()); Ok(SteelVal::ListV(new.into())) @@ -72,7 +74,7 @@ impl VectorOperations { let vec = args[0].clone(); if let SteelVal::MutableVector(v) = vec { - Ok(SteelVal::IntV(v.borrow().len() as isize)) + Ok(SteelVal::IntV(v.get().len() as isize)) } else { stop!(TypeMismatch => "mut-vec-length expects a mutable vector, found: {:?}", vec); } @@ -95,14 +97,18 @@ impl VectorOperations { stop!(Generic => "vector-set! expects a positive integer, found: {:?}", vec); } - if i as usize > v.borrow().len() { - stop!(Generic => "index out of bounds, index given: {:?}, length of vector: {:?}", i, v.borrow().len()); + let ptr = v.strong_ptr(); + + let guard = &mut ptr.borrow_mut().value; + + if i as usize > guard.len() { + stop!(Generic => "index out of bounds, index given: {:?}, length of vector: {:?}", i, guard.len()); } // TODO: disallow cyclical references on construction // Update the vector position - v.borrow_mut()[i as usize] = args[2].clone(); + guard[i as usize] = args[2].clone(); Ok(SteelVal::Void) } else { @@ -129,12 +135,16 @@ impl VectorOperations { stop!(Generic => "mut-vector-ref expects a positive integer, found: {:?}", vec); } - if i as usize >= v.borrow().len() { - stop!(Generic => "index out of bounds, index given: {:?}, length of vector: {:?}", i, v.borrow().len()); + let ptr = v.strong_ptr(); + + let guard = &mut ptr.borrow_mut().value; + + if i as usize >= guard.len() { + stop!(Generic => "index out of bounds, index given: {:?}, length of vector: {:?}", i, guard.len()); } // Grab the value out of the vector - Ok(v.borrow()[i as usize].clone()) + Ok(guard[i as usize].clone()) } else { stop!(TypeMismatch => "mut-vector-ref expects an integer, found: {:?}", pos); } @@ -159,7 +169,7 @@ impl VectorOperations { // } // TODO: disallow cyclical references on construction - v.borrow_mut().push(args[1].clone()); + v.strong_ptr().borrow_mut().value.push(args[1].clone()); Ok(SteelVal::Void) } else { stop!(TypeMismatch => "vector-push! expects a vector, found: {:?}", vec); @@ -178,7 +188,10 @@ impl VectorOperations { if let SteelVal::MutableVector(left) = vec { if let SteelVal::MutableVector(right) = other_vec { - left.borrow_mut().append(&mut right.borrow_mut()); + left.strong_ptr() + .borrow_mut() + .value + .append(&mut right.strong_ptr().borrow_mut().value); Ok(SteelVal::Void) } else { stop!(TypeMismatch => "vetor-append! expects a vector in the second position, found: {:?}", other_vec); @@ -191,52 +204,22 @@ impl VectorOperations { pub fn vec_construct_iter>>(arg: I) -> Result { let res: Result> = arg.collect(); - Ok(SteelVal::VectorV(Gc::new(res?))) + Ok(SteelVal::VectorV(Gc::new(res?).into())) } pub fn vec_construct_iter_normal>(arg: I) -> Result { - Ok(SteelVal::VectorV(Gc::new( - arg.collect::>(), - ))) + Ok(SteelVal::VectorV( + Gc::new(arg.collect::>()).into(), + )) } - // TODO - // mutation semantics are much more difficult than functional ones? - // maybe for vectors use Rc> insides? - // this would ensure that the insides can get mutated safely - // COW would be cool though, because then I can ensure that if more than one - // variable points to a location, then it changes only the reference that I want - // to be changed - // - // Mutation functions have to have a different signature and run time - // behavior, otherwise things don't work properly - // pub fn vec_set_bang() -> SteelVal { - // SteelVal::FuncV(|args: &[Gc]| -> Result> { - // if args.len() != 3 { - // stop!(ArityMismatch => "vector-set! takes 3 arguments"); - // } else { - // // unimplemented!(); - // // let vec_to_be_mut = Gc::clone(&args[0]); - - // // let vec_to_be_mut = Gc::make_mut(&args[0]); - - // let _idx = Gc::clone(&args[1]); - // let _new_value = Gc::clone(&args[2]); - - // panic!("Internal Compiler Error - vector-set! not implemented") - - // // unimplemented!() - // } - // }) - // } - pub fn vec_append() -> SteelVal { SteelVal::FuncV(|args: &[SteelVal]| -> Result { let lsts: Vector = unwrap_list_of_lists(args.to_vec())? .into_iter() .flatten() .collect(); - Ok(SteelVal::VectorV(Gc::new(lsts))) + Ok(SteelVal::VectorV(Gc::new(lsts).into())) }) } @@ -279,12 +262,15 @@ impl VectorOperations { match (args.next(), args.next()) { (Some(elem), Some(lst)) => { if let (IntV(lower), IntV(upper)) = (elem, lst) { - Ok(SteelVal::VectorV(Gc::new( - (*lower as usize..*upper as usize) - .into_iter() - .map(|x| SteelVal::IntV(x as isize)) - .collect(), - ))) + Ok(SteelVal::VectorV( + Gc::new( + (*lower as usize..*upper as usize) + .into_iter() + .map(|x| SteelVal::IntV(x as isize)) + .collect::>(), + ) + .into(), + )) } else { stop!(TypeMismatch => "range expected number") } @@ -303,14 +289,14 @@ impl VectorOperations { match (args.next(), args.next()) { (Some(elem), Some(lst)) => { if let SteelVal::VectorV(l) = lst { - let mut l = l.unwrap(); + let mut l = l.0.unwrap(); l.push_back(elem.clone()); - Ok(SteelVal::VectorV(Gc::new(l))) + Ok(SteelVal::VectorV(Gc::new(l).into())) } else { let mut new = Vector::new(); new.push_front(elem.clone()); new.push_front(lst.clone()); - Ok(SteelVal::VectorV(Gc::new(new))) + Ok(SteelVal::VectorV(Gc::new(new).into())) } } _ => stop!(ArityMismatch => "push takes two arguments"), @@ -327,14 +313,14 @@ impl VectorOperations { match (args.next(), args.next()) { (Some(elem), Some(lst)) => { if let SteelVal::VectorV(l) = lst { - let mut l = l.unwrap(); + let mut l = l.0.unwrap(); l.push_front(elem.clone()); - Ok(SteelVal::VectorV(Gc::new(l))) + Ok(SteelVal::VectorV(Gc::new(l).into())) } else { let mut new = Vector::new(); new.push_front(lst.clone()); new.push_front(elem.clone()); - Ok(SteelVal::VectorV(Gc::new(new))) + Ok(SteelVal::VectorV(Gc::new(new).into())) } } _ => stop!(ArityMismatch => "cons takes two arguments"), @@ -350,7 +336,7 @@ impl VectorOperations { if let Some(first) = args.iter().next() { match first { SteelVal::VectorV(e) => { - let mut e = e.unwrap(); + let mut e = e.0.unwrap(); match e.pop_front() { Some(e) => Ok(e), None => stop!(ContractViolation => "car expects a non empty list"), @@ -374,10 +360,10 @@ impl VectorOperations { if let Some(first) = args.iter().next() { match first { SteelVal::VectorV(e) => { - let mut e = e.unwrap(); + let mut e = e.0.unwrap(); if !e.is_empty() { e.pop_front(); - Ok(SteelVal::VectorV(Gc::new(e))) + Ok(SteelVal::VectorV(Gc::new(e).into())) } else { stop!(ContractViolation => "cdr expects a non empty list") } @@ -413,7 +399,7 @@ fn unwrap_list_of_lists(args: Vec) -> Result>> { fn unwrap_single_list(exp: &SteelVal) -> Result> { match exp { - SteelVal::VectorV(lst) => Ok(lst.unwrap()), + SteelVal::VectorV(lst) => Ok(lst.0.unwrap()), _ => stop!(TypeMismatch => "expected a list"), } } @@ -433,36 +419,20 @@ mod vector_prim_tests { fn vec_construct_test() { let args = vec![SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3)]; let res = apply_function(VectorOperations::vec_construct(), args); - let expected = SteelVal::VectorV(Gc::new(vector![ - SteelVal::IntV(1), - SteelVal::IntV(2), - SteelVal::IntV(3) - ])); + let expected = vector![SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3)].into(); assert_eq!(res.unwrap(), expected); } #[test] fn vec_append_test_good_inputs() { let args = vec![ - SteelVal::VectorV(Gc::new(vector![ - SteelVal::IntV(1), - SteelVal::IntV(2), - SteelVal::IntV(3) - ])), - SteelVal::VectorV(Gc::new(vector![ - SteelVal::IntV(1), - SteelVal::IntV(2), - SteelVal::IntV(3) - ])), - SteelVal::VectorV(Gc::new(vector![ - SteelVal::IntV(1), - SteelVal::IntV(2), - SteelVal::IntV(3) - ])), + vector![SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3)].into(), + vector![SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3)].into(), + vector![SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3)].into(), ]; let res = apply_function(VectorOperations::vec_append(), args); - let expected = SteelVal::VectorV(Gc::new(vector![ + let expected = vector![ SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3), @@ -472,24 +442,17 @@ mod vector_prim_tests { SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3) - ])); + ] + .into(); assert_eq!(res.unwrap(), expected); } #[test] fn vec_append_test_bad_inputs() { let args = vec![ - SteelVal::VectorV(Gc::new(vector![ - SteelVal::IntV(1), - SteelVal::IntV(2), - SteelVal::IntV(3) - ])), + vector![SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3)].into(), SteelVal::StringV("foo".into()), - SteelVal::VectorV(Gc::new(vector![ - SteelVal::IntV(1), - SteelVal::IntV(2), - SteelVal::IntV(3) - ])), + vector![SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3)].into(), ]; let res = apply_function(VectorOperations::vec_append(), args); assert!(res.is_err()); @@ -524,12 +487,13 @@ mod vector_prim_tests { let args = vec![SteelVal::IntV(0), SteelVal::IntV(4)]; let res = apply_function(VectorOperations::vec_range(), args); - let expected = SteelVal::VectorV(Gc::new(vector![ + let expected = vector![ SteelVal::IntV(0), SteelVal::IntV(1), SteelVal::IntV(2), SteelVal::IntV(3) - ])); + ] + .into(); assert_eq!(res.unwrap(), expected); } @@ -558,10 +522,11 @@ mod vector_prim_tests { SteelVal::StringV("bar".into()), ]; let res = apply_function(VectorOperations::vec_push(), args); - let expected = SteelVal::VectorV(Gc::new(vector![ + let expected = vector![ SteelVal::StringV("bar".into()), SteelVal::StringV("baz".into()), - ])); + ] + .into(); assert_eq!(res.unwrap(), expected); } @@ -569,17 +534,19 @@ mod vector_prim_tests { fn vec_push_test_good_input() { let args = vec![ SteelVal::StringV("baz".into()), - SteelVal::VectorV(Gc::new(vector![ + vector![ SteelVal::StringV("foo".into()), SteelVal::StringV("bar".into()) - ])), + ] + .into(), ]; let res = apply_function(VectorOperations::vec_push(), args); - let expected = SteelVal::VectorV(Gc::new(vector![ + let expected = vector![ SteelVal::StringV("foo".into()), SteelVal::StringV("bar".into()), SteelVal::StringV("baz".into()) - ])); + ] + .into(); assert_eq!(res.unwrap(), expected); } @@ -608,10 +575,11 @@ mod vector_prim_tests { SteelVal::StringV("bar".into()), ]; let res = apply_function(VectorOperations::vec_cons(), args); - let expected = SteelVal::VectorV(Gc::new(vector![ + let expected = vector![ SteelVal::StringV("foo".into()), SteelVal::StringV("bar".into()) - ])); + ] + .into(); assert_eq!(res.unwrap(), expected); } @@ -619,17 +587,19 @@ mod vector_prim_tests { fn vec_cons_elem_vector() { let args = vec![ SteelVal::StringV("foo".into()), - SteelVal::VectorV(Gc::new(vector![ + vector![ SteelVal::StringV("bar".into()), SteelVal::StringV("baz".into()) - ])), + ] + .into(), ]; let res = apply_function(VectorOperations::vec_cons(), args); - let expected = SteelVal::VectorV(Gc::new(vector![ + let expected = vector![ SteelVal::StringV("foo".into()), SteelVal::StringV("bar".into()), SteelVal::StringV("baz".into()) - ])); + ] + .into(); assert_eq!(res.unwrap(), expected); } @@ -659,10 +629,11 @@ mod vector_prim_tests { #[test] fn vec_car_normal_input() { - let args = vec![SteelVal::VectorV(Gc::new(vector![ + let args = vec![vector![ SteelVal::StringV("foo".into()), SteelVal::StringV("bar".into()) - ]))]; + ] + .into()]; let res = apply_function(VectorOperations::vec_car(), args); let expected = SteelVal::StringV("foo".into()); assert_eq!(res.unwrap(), expected); @@ -694,18 +665,19 @@ mod vector_prim_tests { #[test] fn vec_cdr_normal_input() { - let args = vec![SteelVal::VectorV(Gc::new(vector![ + let args = vec![vector![ SteelVal::StringV("foo".into()), SteelVal::StringV("bar".into()) - ]))]; + ] + .into()]; let res = apply_function(VectorOperations::vec_cdr(), args); - let expected = SteelVal::VectorV(Gc::new(vector![SteelVal::StringV("bar".into())])); + let expected = vector![SteelVal::StringV("bar".into())].into(); assert_eq!(res.unwrap(), expected); } #[test] fn vec_cdr_empty_list() { - let args = vec![SteelVal::VectorV(Gc::new(Vector::new()))]; + let args = vec![Vector::new().into()]; let res = apply_function(VectorOperations::vec_cdr(), args); assert!(res.is_err()); } @@ -727,10 +699,11 @@ mod vector_prim_tests { #[test] fn list_vec_non_empty_vec() { - let args = vec![SteelVal::VectorV(Gc::new(vector![ + let args = vec![vector![ SteelVal::StringV("foo".into()), SteelVal::StringV("bar".into()) - ]))]; + ] + .into()]; let res = apply_function(VectorOperations::list_vec_null(), args); let expected = SteelVal::BoolV(false); assert_eq!(res.unwrap(), expected); @@ -738,7 +711,7 @@ mod vector_prim_tests { #[test] fn list_vec_empty_vec() { - let args = vec![SteelVal::VectorV(Gc::new(Vector::new()))]; + let args = vec![Vector::new().into()]; let res = apply_function(VectorOperations::list_vec_null(), args); let expected = SteelVal::BoolV(true); assert_eq!(res.unwrap(), expected); diff --git a/crates/steel-core/src/rvals.rs b/crates/steel-core/src/rvals.rs index 37a3ddc79..685d0b63a 100644 --- a/crates/steel-core/src/rvals.rs +++ b/crates/steel-core/src/rvals.rs @@ -12,9 +12,11 @@ use crate::{ steel_vm::vm::{BuiltInSignature, Continuation}, values::port::SteelPort, values::{ - contracts::{ContractType, ContractedFunction}, + closed::{HeapRef, MarkAndSweepContext}, + // contracts::{ContractType, ContractedFunction}, functions::ByteCodeLambda, lazy_stream::LazyStream, + // lists::ListDropHandler, transducers::{Reducer, Transducer}, }, values::{functions::BoxedDynFunction, structs::UserDefinedStruct}, @@ -24,7 +26,7 @@ use crate::{ // use crate::jit::sig::JitFunctionPointer; use std::{ - any::Any, + any::{Any, TypeId}, cell::{Ref, RefCell, RefMut}, cmp::Ordering, convert::TryInto, @@ -48,9 +50,9 @@ macro_rules! list { ) }; ( $($x:expr),* ) => {{ - $crate::rvals::SteelVal::ListV(im_lists::list![$( + $crate::rvals::SteelVal::ListV(vec![$( $crate::rvals::IntoSteelVal::into_steelval($x).unwrap() - ), *]) + ), *].into()) }}; ( $($x:expr ,)* ) => {{ @@ -68,11 +70,11 @@ use futures_task::noop_waker_ref; use futures_util::future::Shared; use futures_util::FutureExt; -use im_lists::list::List; +use crate::values::lists::List; use num::ToPrimitive; use steel_parser::tokens::MaybeBigInt; -use self::cycles::CycleDetector; +use self::cycles::{CycleDetector, IterativeDropHandler}; pub type RcRefSteelVal = Rc>; pub fn new_rc_ref_cell(x: SteelVal) -> RcRefSteelVal { @@ -157,6 +159,20 @@ pub trait Custom: private::Sealed { fn into_serializable_steelval(&mut self) -> Option { None } + + fn as_iterator(&self) -> Option>> { + None + } + + fn gc_drop_mut(&mut self, _drop_handler: &mut IterativeDropHandler) {} + + fn gc_visit_children(&self, _context: &mut MarkAndSweepContext) {} + + fn visit_equality(&self, _visitor: &mut cycles::EqualityVisitor) {} + + fn equality_hint(&self, _other: &dyn CustomType) -> bool { + true + } } pub trait CustomType { @@ -167,6 +183,7 @@ pub trait CustomType { fn name(&self) -> &str { std::any::type_name::() } + fn inner_type_id(&self) -> TypeId; // fn new_steel_val(&self) -> SteelVal; fn display(&self) -> std::result::Result { Ok(format!("#<{}>", self.name().to_string())) @@ -175,7 +192,17 @@ pub trait CustomType { fn as_serializable_steelval(&mut self) -> Option { None } - // fn as_underlying_type<'a>(&'a self) -> Option<&'a Self>; + + // Implement visit for anything that holds steel values + fn drop_mut(&mut self, _drop_handler: &mut IterativeDropHandler) {} + + fn visit_children(&self, _context: &mut MarkAndSweepContext) {} + + fn visit_children_for_equality(&self, _visitor: &mut cycles::EqualityVisitor) {} + + fn check_equality_hint(&self, _other: &dyn CustomType) -> bool { + true + } } impl CustomType for T { @@ -185,6 +212,9 @@ impl CustomType for T { fn as_any_ref_mut(&mut self) -> &mut dyn Any { self as &mut dyn Any } + fn inner_type_id(&self) -> TypeId { + std::any::TypeId::of::() + } fn display(&self) -> std::result::Result { if let Some(formatted) = self.fmt() { formatted @@ -196,6 +226,23 @@ impl CustomType for T { fn as_serializable_steelval(&mut self) -> Option { self.into_serializable_steelval() } + + fn drop_mut(&mut self, drop_handler: &mut IterativeDropHandler) { + self.gc_drop_mut(drop_handler) + } + + fn visit_children(&self, context: &mut MarkAndSweepContext) { + self.gc_visit_children(context) + } + + // TODO: Equality visitor + fn visit_children_for_equality(&self, visitor: &mut cycles::EqualityVisitor) { + self.visit_equality(visitor) + } + + fn check_equality_hint(&self, other: &dyn CustomType) -> bool { + self.equality_hint(other) + } } impl IntoSteelVal for T { @@ -474,6 +521,18 @@ impl AsRefSteelVal for List { } } +impl AsRefSteelVal for UserDefinedStruct { + type Nursery = (); + + fn as_ref<'b, 'a: 'b>(val: &'a SteelVal, _nursery: &mut ()) -> Result> { + if let SteelVal::CustomStruct(l) = val { + Ok(SRef::Temporary(l)) + } else { + stop!(TypeMismatch => "Value cannot be referenced as a list") + } + } +} + // impl AsRefSteelVal for FunctionSignature { // fn as_ref<'b, 'a: 'b>(val: &'a SteelVal) -> Result> { // if let SteelVal::FuncV(f) = val { @@ -693,7 +752,7 @@ impl ast::TryFromSteelValVisitorForExprKind { #[derive(Debug, Clone)] pub struct Syntax { - raw: Option, + pub(crate) raw: Option, pub(crate) syntax: SteelVal, span: Span, } @@ -887,11 +946,14 @@ pub fn from_serializable_value(val: SerializableSteelVal) -> SteelVal { SerializableSteelVal::Void => SteelVal::Void, SerializableSteelVal::StringV(s) => SteelVal::StringV(s.into()), SerializableSteelVal::FuncV(f) => SteelVal::FuncV(f), - SerializableSteelVal::HashMapV(h) => SteelVal::HashMapV(Gc::new( - h.into_iter() - .map(|(k, v)| (from_serializable_value(k), from_serializable_value(v))) - .collect(), - )), + SerializableSteelVal::HashMapV(h) => SteelVal::HashMapV( + Gc::new( + h.into_iter() + .map(|(k, v)| (from_serializable_value(k), from_serializable_value(v))) + .collect::>(), + ) + .into(), + ), SerializableSteelVal::VectorV(v) => { SteelVal::ListV(v.into_iter().map(from_serializable_value).collect()) } @@ -922,7 +984,7 @@ pub fn into_serializable_value(val: SteelVal) -> Result { SteelVal::SymbolV(s) => Ok(SerializableSteelVal::SymbolV(s.to_string())), SteelVal::HashMapV(v) => Ok(SerializableSteelVal::HashMapV( - v.unwrap() + v.0.unwrap() .into_iter() .map(|(k, v)| { let kprime = into_serializable_value(k)?; @@ -944,6 +1006,60 @@ pub fn into_serializable_value(val: SteelVal) -> Result { } } +#[derive(Clone, PartialEq, Eq)] +pub struct SteelMutableVector(pub(crate) Gc>>); + +#[derive(Clone, PartialEq, Eq)] +pub struct SteelVector(pub(crate) Gc>); + +impl Deref for SteelVector { + type Target = im_rc::Vector; + + fn deref(&self) -> &Self::Target { + &self.0 + } +} + +impl From>> for SteelVector { + fn from(value: Gc>) -> Self { + SteelVector(value) + } +} + +#[derive(Clone, PartialEq)] +pub struct SteelHashMap(pub(crate) Gc>); + +impl Deref for SteelHashMap { + type Target = HashMap; + + fn deref(&self) -> &Self::Target { + &self.0 + } +} + +impl From>> for SteelHashMap { + fn from(value: Gc>) -> Self { + SteelHashMap(value) + } +} + +#[derive(Clone, PartialEq)] +pub struct SteelHashSet(pub(crate) Gc>); + +impl Deref for SteelHashSet { + type Target = im_rc::HashSet; + + fn deref(&self) -> &Self::Target { + &self.0 + } +} + +impl From>> for SteelHashSet { + fn from(value: Gc>) -> Self { + SteelHashSet(value) + } +} + /// A value as represented in the runtime. #[derive(Clone)] pub enum SteelVal { @@ -959,7 +1075,7 @@ pub enum SteelVal { CharV(char), /// Vectors are represented as `im_rc::Vector`'s, which are immutable /// data structures - VectorV(Gc>), + VectorV(SteelVector), /// Void return value Void, /// Represents strings @@ -971,25 +1087,17 @@ pub enum SteelVal { /// Container for a type that implements the `Custom Type` trait. (trait object) Custom(Gc>>), // Embedded HashMap - HashMapV(Gc>), + HashMapV(SteelHashMap), // Embedded HashSet - HashSetV(Gc>), + HashSetV(SteelHashSet), /// Represents a scheme-only struct - // StructV(Gc), - /// Alternative implementation of a scheme-only struct - CustomStruct(Gc>), - // Represents a special rust closure - // StructClosureV(Box, StructClosureSignature), - // StructClosureV(Box), + CustomStruct(Gc), /// Represents a port object PortV(Gc), /// Generic iterator wrapper IterV(Gc), /// Reducers ReducerV(Gc), - // Reducer(Reducer) - // Generic IntoIter wrapper - // Promise(Gc), /// Async Function wrapper FutureFunc(BoxedAsyncFunctionSignature), // Boxed Future Result @@ -997,10 +1105,6 @@ pub enum SteelVal { StreamV(Gc), - /// Contract - Contract(Gc), - /// Contracted Function - ContractedFunction(Gc), /// Custom closure BoxedFunction(Rc), // Continuation @@ -1009,16 +1113,16 @@ pub enum SteelVal { // #[cfg(feature = "jit")] // CompiledFunction(Box), // List - ListV(List), + ListV(crate::values::lists::List), // Mutable functions MutFunc(MutFunctionSignature), // Built in functions BuiltIn(BuiltInSignature), // Mutable vector - MutableVector(Gc>>), + MutableVector(HeapRef>), // This should delegate to the underlying iterator - can allow for faster raw iteration if possible // Should allow for polling just a raw "next" on underlying elements - BoxedIterator(Gc>), + BoxedIterator(Gc>), SyntaxObject(Gc), @@ -1026,12 +1130,79 @@ pub enum SteelVal { // Boxed(HeapRef), Boxed(Gc>), + HeapAllocated(HeapRef), + // TODO: This itself, needs to be boxed unfortunately. Reference(Rc>), BigNum(Gc), } +impl SteelVal { + pub fn as_box(&self) -> Option> { + if let SteelVal::HeapAllocated(heap_ref) = self { + Some(heap_ref.clone()) + } else { + None + } + } + + pub fn as_box_to_inner(&self) -> Option { + self.as_box().map(|x| x.get()) + } + + pub fn as_ptr_usize(&self) -> Option { + match self { + // Closure(_) => todo!(), + // BoolV(_) => todo!(), + // NumV(_) => todo!(), + // IntV(_) => todo!(), + // CharV(_) => todo!(), + // VectorV(_) => todo!(), + // Void => todo!(), + // StringV(_) => todo!(), + // FuncV(_) => todo!(), + // SymbolV(_) => todo!(), + // SteelVal::Custom(_) => todo!(), + // HashMapV(_) => todo!(), + // HashSetV(_) => todo!(), + CustomStruct(c) => Some(c.as_ptr() as usize), + // PortV(_) => todo!(), + // IterV(_) => todo!(), + // ReducerV(_) => todo!(), + // FutureFunc(_) => todo!(), + // FutureV(_) => todo!(), + // StreamV(_) => todo!(), + // BoxedFunction(_) => todo!(), + // ContinuationFunction(_) => todo!(), + ListV(l) => Some(l.as_ptr_usize()), + // MutFunc(_) => todo!(), + // BuiltIn(_) => todo!(), + // MutableVector(_) => todo!(), + // BoxedIterator(_) => todo!(), + // SteelVal::SyntaxObject(_) => todo!(), + // Boxed(_) => todo!(), + HeapAllocated(h) => Some(h.as_ptr_usize()), + // Reference(_) => todo!(), + // BigNum(_) => todo!(), + _ => None, + } + } + + // pub(crate) fn children_mut<'a>(&'a mut self) -> impl IntoIterator { + // match self { + // Self::CustomStruct(inner) => { + // if let Some(inner) = inner.get_mut() { + // std::mem::take(&mut inner.borrow_mut().fields) + // } else { + // std::iter::empty() + // } + // } + // _ => todo!(), + // } + // } +} + // TODO: Consider unboxed value types, for optimized usages when compiling segments of code. // If we can infer the types from the concrete functions used, we don't need to have unboxed values -> We also // can use concrete forms of the underlying functions as well. @@ -1185,8 +1356,21 @@ impl Chunks { } } +pub struct OpaqueIterator { + pub(crate) root: SteelVal, + iterator: BuiltInDataStructureIterator, +} + +impl Custom for OpaqueIterator { + fn fmt(&self) -> Option> { + Some(Ok(format!("#"))) + } +} + +// TODO: Convert this to just a generic custom type. This does not have to be +// a special enum variant. pub enum BuiltInDataStructureIterator { - List(im_lists::list::ConsumingIter), + List(crate::values::lists::ConsumingIterator), Vector(im_rc::vector::ConsumingIter), Set(im_rc::hashset::ConsumingIter), Map(im_rc::hashmap::ConsumingIter<(SteelVal, SteelVal)>), @@ -1195,8 +1379,11 @@ pub enum BuiltInDataStructureIterator { } impl BuiltInDataStructureIterator { - pub fn into_boxed_iterator(self) -> SteelVal { - SteelVal::BoxedIterator(Gc::new(RefCell::new(self))) + pub fn into_boxed_iterator(self, value: SteelVal) -> SteelVal { + SteelVal::BoxedIterator(Gc::new(RefCell::new(OpaqueIterator { + root: value, + iterator: self, + }))) } } @@ -1219,29 +1406,36 @@ impl Iterator for BuiltInDataStructureIterator { Self::Vector(v) => v.next(), Self::String(s) => s.remaining.next().map(SteelVal::CharV), Self::Set(s) => s.next(), - Self::Map(s) => s.next().map(|x| SteelVal::ListV(im_lists::list![x.0, x.1])), + Self::Map(s) => s.next().map(|x| SteelVal::ListV(vec![x.0, x.1].into())), Self::Opaque(s) => s.next(), } } } -pub fn value_into_iterator(val: SteelVal) -> SteelVal { +pub fn value_into_iterator(val: SteelVal) -> Option { + let root = val.clone(); match val { - SteelVal::ListV(l) => BuiltInDataStructureIterator::List(l.into_iter()), - SteelVal::VectorV(v) => BuiltInDataStructureIterator::Vector((*v).clone().into_iter()), - SteelVal::StringV(s) => BuiltInDataStructureIterator::String(Chunks::new(s)), - SteelVal::HashSetV(s) => BuiltInDataStructureIterator::Set((*s).clone().into_iter()), - SteelVal::HashMapV(m) => BuiltInDataStructureIterator::Map((*m).clone().into_iter()), - _ => panic!("Haven't handled this case yet"), + SteelVal::ListV(l) => Some(BuiltInDataStructureIterator::List(l.into_iter())), + SteelVal::VectorV(v) => Some(BuiltInDataStructureIterator::Vector( + (*v).clone().into_iter(), + )), + SteelVal::StringV(s) => Some(BuiltInDataStructureIterator::String(Chunks::new(s))), + SteelVal::HashSetV(s) => Some(BuiltInDataStructureIterator::Set((*s).clone().into_iter())), + SteelVal::HashMapV(m) => Some(BuiltInDataStructureIterator::Map((*m).clone().into_iter())), + _ => None, } - .into_boxed_iterator() + .map(|iterator| BuiltInDataStructureIterator::into_boxed_iterator(iterator, root)) +} + +thread_local! { + pub static ITERATOR_FINISHED: SteelVal = SteelVal::SymbolV("done".into()); } pub fn iterator_next(args: &[SteelVal]) -> Result { match &args[0] { - SteelVal::BoxedIterator(b) => match b.borrow_mut().next() { + SteelVal::BoxedIterator(b) => match b.borrow_mut().iterator.next() { Some(v) => Ok(v), - None => Ok(SteelVal::Void), + None => Ok(ITERATOR_FINISHED.with(|x| x.clone())), }, _ => stop!(TypeMismatch => "Unexpected argument"), } @@ -1258,14 +1452,14 @@ impl SteelVal { (IntV(l), IntV(r)) => l == r, (NumV(l), NumV(r)) => l == r, (BoolV(l), BoolV(r)) => l == r, - (VectorV(l), VectorV(r)) => Gc::ptr_eq(l, r), + (VectorV(l), VectorV(r)) => Gc::ptr_eq(&l.0, &r.0), (Void, Void) => true, (StringV(l), StringV(r)) => Rc::ptr_eq(l, r), (FuncV(l), FuncV(r)) => *l as usize == *r as usize, (SymbolV(l), SymbolV(r)) => Rc::ptr_eq(l, r), (SteelVal::Custom(l), SteelVal::Custom(r)) => Gc::ptr_eq(l, r), - (HashMapV(l), HashMapV(r)) => Gc::ptr_eq(l, r), - (HashSetV(l), HashSetV(r)) => Gc::ptr_eq(l, r), + (HashMapV(l), HashMapV(r)) => Gc::ptr_eq(&l.0, &r.0), + (HashSetV(l), HashSetV(r)) => Gc::ptr_eq(&l.0, &r.0), (PortV(l), PortV(r)) => Gc::ptr_eq(l, r), (Closure(l), Closure(r)) => Gc::ptr_eq(l, r), (IterV(l), IterV(r)) => Gc::ptr_eq(l, r), @@ -1274,15 +1468,15 @@ impl SteelVal { (FutureFunc(l), FutureFunc(r)) => Rc::ptr_eq(l, r), (FutureV(l), FutureV(r)) => Gc::ptr_eq(l, r), (StreamV(l), StreamV(r)) => Gc::ptr_eq(l, r), - (Contract(l), Contract(r)) => Gc::ptr_eq(l, r), - (SteelVal::ContractedFunction(l), SteelVal::ContractedFunction(r)) => Gc::ptr_eq(l, r), + // (Contract(l), Contract(r)) => Gc::ptr_eq(l, r), + // (SteelVal::ContractedFunction(l), SteelVal::ContractedFunction(r)) => Gc::ptr_eq(l, r), (BoxedFunction(l), BoxedFunction(r)) => Rc::ptr_eq(l, r), (ContinuationFunction(l), ContinuationFunction(r)) => Gc::ptr_eq(l, r), // (CompiledFunction(_), CompiledFunction(_)) => todo!(), (ListV(l), ListV(r)) => l.ptr_eq(r), (MutFunc(l), MutFunc(r)) => *l as usize == *r as usize, (BuiltIn(l), BuiltIn(r)) => *l as usize == *r as usize, - (MutableVector(l), MutableVector(r)) => Gc::ptr_eq(l, r), + (MutableVector(l), MutableVector(r)) => HeapRef::ptr_eq(l, r), (BigNum(l), BigNum(r)) => Gc::ptr_eq(l, r), (_, _) => false, } @@ -1323,7 +1517,7 @@ impl Hash for SteelVal { IntV(i) => i.hash(state), CharV(c) => c.hash(state), ListV(l) => l.hash(state), - CustomStruct(s) => s.borrow().hash(state), + CustomStruct(s) => s.hash(state), // Pair(cell) => { // cell.hash(state); // } @@ -1403,18 +1597,18 @@ impl SteelVal { BoxedFunction(_) | Closure(_) | FuncV(_) - | ContractedFunction(_) + // | ContractedFunction(_) | BuiltIn(_) | MutFunc(_) ) } - pub fn is_contract(&self) -> bool { - matches!(self, Contract(_)) - } + // pub fn is_contract(&self) -> bool { + // matches!(self, Contract(_)) + // } pub fn empty_hashmap() -> SteelVal { - SteelVal::HashMapV(Gc::new(HashMap::new())) + SteelVal::HashMapV(Gc::new(HashMap::new()).into()) } } @@ -1472,7 +1666,7 @@ impl SteelVal { err: F, ) -> std::result::Result, E> { match self { - Self::VectorV(v) => Ok(v.unwrap()), + Self::VectorV(v) => Ok(v.0.unwrap()), _ => Err(err()), } } @@ -1511,15 +1705,15 @@ impl SteelVal { } } - pub fn contract_or_else E>( - &self, - err: F, - ) -> std::result::Result, E> { - match self { - Self::Contract(c) => Ok(c.clone()), - _ => Err(err()), - } - } + // pub fn contract_or_else E>( + // &self, + // err: F, + // ) -> std::result::Result, E> { + // match self { + // Self::Contract(c) => Ok(c.clone()), + // _ => Err(err()), + // } + // } pub fn closure_or_else E>( &self, @@ -1673,46 +1867,43 @@ pub fn number_equality(left: &SteelVal, right: &SteelVal) -> Result { } // TODO add tests -impl PartialEq for SteelVal { - fn eq(&self, other: &Self) -> bool { - match (self, other) { - (Void, Void) => true, - (BoolV(l), BoolV(r)) => l == r, - (BigNum(l), BigNum(r)) => l == r, - // (NumV(l), NumV(r)) => l == r, - (IntV(l), IntV(r)) => l == r, - - // Floats shouls also be considered equal - (NumV(l), NumV(r)) => l == r, - - // (NumV(l), IntV(r)) => *l == *r as f64, - // (IntV(l), NumV(r)) => *l as f64 == *r, - (StringV(l), StringV(r)) => l == r, - (VectorV(l), VectorV(r)) => l == r, - (SymbolV(l), SymbolV(r)) => l == r, - (CharV(l), CharV(r)) => l == r, - // (Pair(_), Pair(_)) => collect_pair_into_vector(self) == collect_pair_into_vector(other), - (HashSetV(l), HashSetV(r)) => l == r, - (HashMapV(l), HashMapV(r)) => l == r, - (Closure(l), Closure(r)) => l == r, - (ContractedFunction(l), ContractedFunction(r)) => l == r, - (Contract(l), Contract(r)) => l == r, - (IterV(l), IterV(r)) => l == r, - (ListV(l), ListV(r)) => l == r, - (CustomStruct(l), CustomStruct(r)) => l == r, - (FuncV(l), FuncV(r)) => *l as usize == *r as usize, - //TODO - (_, _) => false, // (l, r) => { - // let left = unwrap!(l, usize); - // let right = unwrap!(r, usize); - // match (left, right) { - // (Ok(l), Ok(r)) => l == r, - // (_, _) => false, - // } - // } - } - } -} +// impl PartialEq for SteelVal { +// fn eq(&self, other: &Self) -> bool { +// match (self, other) { +// (Void, Void) => true, +// (BoolV(l), BoolV(r)) => l == r, +// (BigNum(l), BigNum(r)) => l == r, +// // (NumV(l), NumV(r)) => l == r, +// (IntV(l), IntV(r)) => l == r, + +// // Floats shouls also be considered equal +// (NumV(l), NumV(r)) => l == r, + +// (StringV(l), StringV(r)) => l == r, +// (VectorV(l), VectorV(r)) => l == r, +// (SymbolV(l), SymbolV(r)) => l == r, +// (CharV(l), CharV(r)) => l == r, +// (HashSetV(l), HashSetV(r)) => l == r, +// (HashMapV(l), HashMapV(r)) => l == r, +// (Closure(l), Closure(r)) => l == r, +// (IterV(l), IterV(r)) => l == r, +// (ListV(l), ListV(r)) => l == r, +// (CustomStruct(l), CustomStruct(r)) => l == r, +// (FuncV(l), FuncV(r)) => *l == *r, +// (Custom(l), Custom(r)) => Gc::ptr_eq(l, r), +// (HeapAllocated(l), HeapAllocated(r)) => l.get() == r.get(), +// //TODO +// (_, _) => false, // (l, r) => { +// // let left = unwrap!(l, usize); +// // let right = unwrap!(r, usize); +// // match (left, right) { +// // (Ok(l), Ok(r)) => l == r, +// // (_, _) => false, +// // } +// // } +// } +// } +// } // TODO add tests impl PartialOrd for SteelVal { @@ -1802,7 +1993,7 @@ mod or_else_tests { #[test] fn vector_or_else_test_good() { - let input = SteelVal::VectorV(Gc::new(vector![SteelVal::IntV(1)])); + let input: SteelVal = vector![SteelVal::IntV(1)].into(); assert_eq!( input.vector_or_else(throw!(Generic => "test")).unwrap(), vector![SteelVal::IntV(1)] diff --git a/crates/steel-core/src/rvals/cycles.rs b/crates/steel-core/src/rvals/cycles.rs index 1d1871945..a53f084f8 100644 --- a/crates/steel-core/src/rvals/cycles.rs +++ b/crates/steel-core/src/rvals/cycles.rs @@ -1,43 +1,132 @@ -use crate::steel_vm::builtin::get_function_name; +use std::{cell::Cell, collections::VecDeque}; + +use num::BigInt; + +use crate::{ + steel_vm::{builtin::get_function_name, engine::Engine}, + values::lists::DEPTH, +}; use super::*; +thread_local! { + // Use this to print values, in lieu of a bespoke printer + static PRINTING_KERNEL: RefCell = { + + let mut engine = Engine::new_printer(); + + engine.run(include_str!("../scheme/print.scm")).unwrap(); + + RefCell::new(engine) + }; +} + +pub fn install_printer() { + PRINTING_KERNEL.with(|x| { + x.borrow().globals(); + }); +} + +#[steel_derive::function(name = "print-in-engine")] +pub fn print_in_engine(value: SteelVal) { + PRINTING_KERNEL + .with(|x| { + x.borrow_mut() + .call_function_by_name_with_args("print", vec![value]) + }) + .unwrap(); +} + #[derive(Default)] // Keep track of any reference counted values that are visited, in a pointer pub(super) struct CycleDetector { - // Keep a mapping of the pointer -> gensym - visited: std::collections::HashSet, - // Recording things that have already been seen - cycles: std::collections::HashMap, + cycles: fxhash::FxHashMap, // Values captured in cycles values: Vec, + + depth: usize, } impl CycleDetector { pub(super) fn detect_and_display_cycles(val: &SteelVal, f: &mut fmt::Formatter) -> fmt::Result { - let mut detector = CycleDetector::default(); + // Consider using one shared queue here + let mut queue = VecDeque::new(); + + let mut bfs_detector = CycleCollector { + visited: fxhash::FxHashSet::default(), + cycles: fxhash::FxHashMap::default(), + values: Vec::new(), + queue: &mut queue, + }; + + bfs_detector.push_back(val.clone()); - detector.visit(val); + bfs_detector.visit(); - detector.start_format(val, f) + CycleDetector { + cycles: bfs_detector.cycles, + values: bfs_detector.values, + depth: 0, + } + .start_format(val, f) } - fn start_format(self, val: &SteelVal, f: &mut fmt::Formatter) -> fmt::Result { - for node in &self.values { + fn start_format(mut self, val: &SteelVal, f: &mut fmt::Formatter) -> fmt::Result { + for node in std::mem::take(&mut self.values) { let id = match &node { SteelVal::CustomStruct(c) => { let ptr_addr = c.as_ptr() as usize; self.cycles.get(&ptr_addr).unwrap() } + SteelVal::HeapAllocated(b) => { + // Get the object that THIS points to + let ptr_addr = b.get().as_ptr_usize().unwrap(); + self.cycles.get(&ptr_addr).unwrap() + } + SteelVal::ListV(l) => { + let ptr_addr = l.as_ptr_usize(); + + self.cycles.get(&ptr_addr).unwrap() + } + SteelVal::VectorV(l) => { + let ptr_addr = l.0.as_ptr() as usize; + + self.cycles.get(&ptr_addr).unwrap() + } + SteelVal::HashMapV(l) => { + let ptr_addr = l.0.as_ptr() as usize; + + self.cycles.get(&ptr_addr).unwrap() + } + SteelVal::HashSetV(l) => { + let ptr_addr = l.0.as_ptr() as usize; + + self.cycles.get(&ptr_addr).unwrap() + } + SteelVal::Custom(l) => { + let ptr_addr = l.0.as_ptr() as usize; + + self.cycles.get(&ptr_addr).unwrap() + } + SteelVal::Boxed(b) => { + let ptr_addr = b.as_ptr() as usize; + + self.cycles.get(&ptr_addr).unwrap() + } + SteelVal::SyntaxObject(s) => { + let ptr_addr = s.as_ptr() as usize; + + self.cycles.get(&ptr_addr).unwrap() + } _ => { unreachable!() } }; write!(f, "#{id}=")?; - self.top_level_format_with_cycles(node, f)?; + self.top_level_format_with_cycles(&node, f)?; writeln!(f)?; } @@ -48,8 +137,18 @@ impl CycleDetector { Ok(()) } - fn top_level_format_with_cycles(&self, val: &SteelVal, f: &mut fmt::Formatter) -> fmt::Result { - match val { + fn top_level_format_with_cycles( + &mut self, + val: &SteelVal, + f: &mut fmt::Formatter, + ) -> fmt::Result { + self.depth += 1; + + if self.depth > 128 { + return write!(f, "..."); + } + + let res = match val { BoolV(b) => write!(f, "#{b}"), NumV(x) => write!(f, "{x:?}"), IntV(x) => write!(f, "{x}"), @@ -79,7 +178,7 @@ impl CycleDetector { } Custom(x) => write!(f, "#<{}>", x.borrow().display()?), CustomStruct(s) => { - let guard = s.borrow(); + let guard = s; { if guard @@ -87,16 +186,16 @@ impl CycleDetector { .and_then(|x| x.as_bool()) .unwrap_or_default() { - write!(f, "({}", guard.name)?; + write!(f, "({}", guard.name())?; - for i in &guard.fields { + for i in guard.fields.iter() { write!(f, " ")?; self.format_with_cycles(i, f)?; } write!(f, ")") } else { - write!(f, "({})", guard.name) + write!(f, "({})", guard.name()) } } } @@ -105,12 +204,10 @@ impl CycleDetector { Closure(_) => write!(f, "#"), HashMapV(hm) => write!(f, "#", hm.as_ref()), IterV(_) => write!(f, "#"), - HashSetV(hs) => write!(f, "#"), + HashSetV(hs) => write!(f, "#", hs.0), FutureFunc(_) => write!(f, "#"), FutureV(_) => write!(f, "#"), StreamV(_) => write!(f, "#"), - Contract(c) => write!(f, "{}", **c), - ContractedFunction(_) => write!(f, "#"), BoxedFunction(b) => { if let Some(name) = b.name() { write!(f, "#", name) @@ -138,7 +235,7 @@ impl CycleDetector { MutFunc(_) => write!(f, "#"), BuiltIn(_) => write!(f, "#"), ReducerV(_) => write!(f, "#"), - MutableVector(v) => write!(f, "{:?}", v.as_ref().borrow()), + MutableVector(v) => write!(f, "{:?}", v.get()), SyntaxObject(s) => { if let Some(raw) = &s.raw { write!(f, "#", s.span, raw) @@ -149,11 +246,22 @@ impl CycleDetector { BoxedIterator(_) => write!(f, "#"), Boxed(b) => write!(f, "'#&{}", b.borrow()), Reference(x) => write!(f, "{}", x.format()?), - } + HeapAllocated(b) => write!(f, "'#&{}", b.get()), + }; + + self.depth -= 1; + + res } - fn format_with_cycles(&self, val: &SteelVal, f: &mut fmt::Formatter) -> fmt::Result { - match val { + fn format_with_cycles(&mut self, val: &SteelVal, f: &mut fmt::Formatter) -> fmt::Result { + self.depth += 1; + + if self.depth > 128 { + return write!(f, "..."); + } + + let res = match val { BoolV(b) => write!(f, "#{b}"), NumV(x) => write!(f, "{x:?}"), IntV(x) => write!(f, "{x}"), @@ -185,24 +293,23 @@ impl CycleDetector { if let Some(id) = self.cycles.get(&(s.as_ptr() as usize)) { write!(f, "#{id}#") } else { - let guard = s.borrow(); + let guard = s; { - if s.borrow() - .get(&SteelVal::SymbolV(SteelString::from("#:transparent"))) + if s.get(&SteelVal::SymbolV(SteelString::from("#:transparent"))) .and_then(|x| x.as_bool()) .unwrap_or_default() { - write!(f, "({}", guard.name)?; + write!(f, "({}", guard.name())?; - for i in &guard.fields { + for i in guard.fields.iter() { write!(f, " ")?; self.format_with_cycles(i, f)?; } write!(f, ")") } else { - write!(f, "({})", guard.name) + write!(f, "({})", guard.name()) } } } @@ -212,13 +319,11 @@ impl CycleDetector { Closure(_) => write!(f, "#"), HashMapV(hm) => write!(f, "#", hm.as_ref()), IterV(_) => write!(f, "#"), - HashSetV(hs) => write!(f, "#"), + HashSetV(hs) => write!(f, "#", hs.0), FutureFunc(_) => write!(f, "#"), FutureV(_) => write!(f, "#"), // Promise(_) => write!(f, "#"), StreamV(_) => write!(f, "#"), - Contract(c) => write!(f, "{}", **c), - ContractedFunction(_) => write!(f, "#"), BoxedFunction(b) => { if let Some(name) = b.name() { write!(f, "#", name) @@ -253,7 +358,7 @@ impl CycleDetector { MutFunc(_) => write!(f, "#"), BuiltIn(_) => write!(f, "#"), ReducerV(_) => write!(f, "#"), - MutableVector(v) => write!(f, "{:?}", v.as_ref().borrow()), + MutableVector(v) => write!(f, "{:?}", v.get()), SyntaxObject(s) => { if let Some(raw) = &s.raw { write!(f, "#", s.span, raw) @@ -265,9 +370,131 @@ impl CycleDetector { Boxed(b) => write!(f, "'#&{}", b.borrow()), Reference(x) => write!(f, "{}", x.format()?), BigNum(b) => write!(f, "{}", b.as_ref()), + HeapAllocated(b) => { + if let Some(id) = b.get().as_ptr_usize().and_then(|x| self.cycles.get(&x)) { + write!(f, "#{id}#") + } else { + write!(f, "'#&{}", b.get()) + } + } + }; + + self.depth -= 1; + + res + } +} + +fn replace_with_void(value: &mut SteelVal) -> SteelVal { + std::mem::replace(value, SteelVal::Void) +} + +impl SteelVal { + fn make_void(&mut self) -> SteelVal { + std::mem::replace(self, SteelVal::Void) + } +} + +pub(crate) struct SteelCycleCollector { + cycles: fxhash::FxHashMap, + values: List, +} + +impl Custom for SteelCycleCollector {} + +impl SteelCycleCollector { + pub fn from_root(value: SteelVal) -> Self { + let mut queue = VecDeque::new(); + + let mut collector = CycleCollector { + visited: fxhash::FxHashSet::default(), + cycles: fxhash::FxHashMap::default(), + values: Vec::new(), + queue: &mut queue, + }; + + collector.push_back(value); + + collector.visit(); + + SteelCycleCollector { + cycles: collector.cycles, + values: collector.values.into(), } } + // Get the value + pub fn get(&self, node: SteelVal) -> Option { + match node { + SteelVal::CustomStruct(c) => { + let ptr_addr = c.as_ptr() as usize; + self.cycles.get(&ptr_addr) + } + SteelVal::HeapAllocated(b) => { + // Get the object that THIS points to + let ptr_addr = b.get().as_ptr_usize().unwrap(); + self.cycles.get(&ptr_addr) + } + SteelVal::ListV(l) => { + let ptr_addr = l.as_ptr_usize(); + + self.cycles.get(&ptr_addr) + } + SteelVal::VectorV(l) => { + let ptr_addr = l.0.as_ptr() as usize; + + self.cycles.get(&ptr_addr) + } + SteelVal::HashMapV(l) => { + let ptr_addr = l.0.as_ptr() as usize; + + self.cycles.get(&ptr_addr) + } + SteelVal::HashSetV(l) => { + let ptr_addr = l.0.as_ptr() as usize; + + self.cycles.get(&ptr_addr) + } + SteelVal::Custom(l) => { + let ptr_addr = l.0.as_ptr() as usize; + + self.cycles.get(&ptr_addr) + } + SteelVal::Boxed(b) => { + let ptr_addr = b.as_ptr() as usize; + + self.cycles.get(&ptr_addr) + } + SteelVal::SyntaxObject(s) => { + let ptr_addr = s.as_ptr() as usize; + + self.cycles.get(&ptr_addr) + } + _ => None, + } + .copied() + } + + pub fn values(&self) -> List { + self.values.clone() + } +} + +struct CycleCollector<'a> { + // Keep a mapping of the pointer -> gensym + visited: fxhash::FxHashSet, + + // Recording things that have already been seen + cycles: fxhash::FxHashMap, + + // Values captured in cycles + values: Vec, + + // Queue of items to check + queue: &'a mut VecDeque, +} + +impl<'a> CycleCollector<'a> { fn add(&mut self, val: usize, steelval: &SteelVal) -> bool { if self.visited.contains(&val) { let id = self.cycles.len(); @@ -287,32 +514,1210 @@ impl CycleDetector { self.visited.insert(val); false } +} + +impl<'a> BreadthFirstSearchSteelValVisitor for CycleCollector<'a> { + type Output = (); + + fn default_output(&mut self) -> Self::Output {} + + fn pop_front(&mut self) -> Option { + self.queue.pop_front() + } + + fn push_back(&mut self, value: SteelVal) { + self.queue.push_back(value) + } + + fn visit_closure(&mut self, _closure: Gc) -> Self::Output {} + fn visit_bool(&mut self, _boolean: bool) -> Self::Output {} + fn visit_float(&mut self, _float: f64) -> Self::Output {} + fn visit_int(&mut self, _int: isize) -> Self::Output {} + fn visit_char(&mut self, _c: char) -> Self::Output {} + + fn visit_immutable_vector(&mut self, vector: SteelVector) -> Self::Output { + if !self.add( + vector.0.as_ptr() as usize, + &SteelVal::VectorV(vector.clone()), + ) { + for value in vector.0.iter() { + self.push_back(value.clone()); + } + } + } + + fn visit_void(&mut self) -> Self::Output {} + fn visit_string(&mut self, _string: SteelString) -> Self::Output {} + fn visit_function_pointer(&mut self, _ptr: FunctionSignature) -> Self::Output {} + fn visit_symbol(&mut self, _symbol: SteelString) -> Self::Output {} + + // If we have cycles here, it is game over - we probably don't want to be + // able to render to these easily? + fn visit_custom_type( + &mut self, + _custom_type: Gc>>, + ) -> Self::Output { + } + + fn visit_hash_map(&mut self, hashmap: SteelHashMap) -> Self::Output { + if !self.add( + hashmap.0.as_ptr() as usize, + &SteelVal::HashMapV(hashmap.clone()), + ) { + for (key, value) in hashmap.0.iter() { + self.push_back(key.clone()); + self.push_back(value.clone()); + } + } + } + + fn visit_hash_set(&mut self, hashset: SteelHashSet) -> Self::Output { + if !self.add( + hashset.0.as_ptr() as usize, + &SteelVal::HashSetV(hashset.clone()), + ) { + for key in hashset.0.iter() { + self.push_back(key.clone()) + } + } + } - // TODO: Complete the rest of this visitor - fn visit(&mut self, val: &SteelVal) { - match val { - SteelVal::CustomStruct(s) => { - // todo!() + fn visit_steel_struct(&mut self, steel_struct: Gc) -> Self::Output { + if !self.add( + steel_struct.as_ptr() as usize, + &SteelVal::CustomStruct(steel_struct.clone()), + ) { + for value in steel_struct.fields.iter() { + self.push_back(value.clone()) + } + } + } + + fn visit_port(&mut self, _port: Gc) -> Self::Output {} + fn visit_transducer(&mut self, _transducer: Gc) -> Self::Output {} + fn visit_reducer(&mut self, _reducer: Gc) -> Self::Output {} + fn visit_future_function(&mut self, _function: BoxedAsyncFunctionSignature) -> Self::Output {} + fn visit_future(&mut self, _future: Gc) -> Self::Output {} + fn visit_stream(&mut self, _stream: Gc) -> Self::Output {} + fn visit_boxed_function(&mut self, _function: Rc) -> Self::Output {} + fn visit_continuation(&mut self, _continuation: Gc) -> Self::Output {} + + fn visit_list(&mut self, list: List) -> Self::Output { + if !self.add(list.as_ptr_usize(), &SteelVal::ListV(list.clone())) { + for value in list { + self.push_back(value); + } + } + } + + fn visit_mutable_function(&mut self, _function: MutFunctionSignature) -> Self::Output {} + + // TODO: Figure out the mutable vector first + fn visit_mutable_vector(&mut self, vector: HeapRef>) -> Self::Output { + if !self.add( + vector.as_ptr_usize(), + &SteelVal::MutableVector(vector.clone()), + ) { + for value in vector.get().iter() { + self.push_back(value.clone()); + } + } + } + + fn visit_builtin_function(&mut self, _function: BuiltInSignature) -> Self::Output {} + + fn visit_boxed_iterator(&mut self, _iterator: Gc>) -> Self::Output {} + + fn visit_syntax_object(&mut self, syntax_object: Gc) -> Self::Output { + if !self.add( + syntax_object.as_ptr() as usize, + &SteelVal::SyntaxObject(syntax_object.clone()), + ) { + if let Some(raw) = syntax_object.raw.clone() { + self.push_back(raw); + } + + self.push_back(syntax_object.syntax.clone()); + } + } + + fn visit_boxed_value(&mut self, boxed_value: Gc>) -> Self::Output { + if !self.add( + boxed_value.as_ptr() as usize, + &SteelVal::Boxed(boxed_value.clone()), + ) { + self.push_back(boxed_value.borrow().clone()); + } + } + + fn visit_reference_value(&mut self, _reference: Rc>) -> Self::Output {} + fn visit_bignum(&mut self, _bignum: Gc) -> Self::Output {} + + fn visit_heap_allocated(&mut self, heap_ref: HeapRef) -> Self::Output { + if !self.add( + heap_ref.as_ptr_usize(), + &SteelVal::HeapAllocated(heap_ref.clone()), + ) { + self.push_back(heap_ref.get()); + } + } +} + +#[cfg(not(feature = "without-drop-protection"))] +pub(crate) mod drop_impls { + + use super::*; + + thread_local! { + pub static DROP_BUFFER: RefCell> = RefCell::new(VecDeque::with_capacity(128)); + pub static FORMAT_BUFFER: RefCell> = RefCell::new(VecDeque::with_capacity(128)); + } + + impl Drop for SteelVector { + fn drop(&mut self) { + if self.0.is_empty() { + return; + } + + if let Some(inner) = self.0.get_mut() { + DROP_BUFFER + .try_with(|drop_buffer| { + if let Ok(mut drop_buffer) = drop_buffer.try_borrow_mut() { + for value in std::mem::take(inner) { + drop_buffer.push_back(value); + } + + IterativeDropHandler::bfs(&mut drop_buffer); + } + }) + .ok(); + } + } + } + + impl Drop for SteelHashMap { + fn drop(&mut self) { + if self.0.is_empty() { + return; + } + + if let Some(inner) = self.0.get_mut() { + DROP_BUFFER + .try_with(|drop_buffer| { + if let Ok(mut drop_buffer) = drop_buffer.try_borrow_mut() { + for (key, value) in std::mem::take(inner) { + drop_buffer.push_back(key); + drop_buffer.push_back(value); + } + + IterativeDropHandler::bfs(&mut drop_buffer); + } + }) + .ok(); + } + } + } + + impl Drop for UserDefinedStruct { + fn drop(&mut self) { + if self.fields.is_empty() { + return; + } + + if DROP_BUFFER + .try_with(|drop_buffer| { + if let Ok(mut drop_buffer) = drop_buffer.try_borrow_mut() { + // for value in std::mem::take(&mut self.fields) { + // drop_buffer.push_back(value); + // } + + drop_buffer.extend(Vec::from(std::mem::take(&mut self.fields))); + + IterativeDropHandler::bfs(&mut drop_buffer); + } + }) + .is_err() + { + let mut buffer = Vec::from(std::mem::take(&mut self.fields)).into(); + + IterativeDropHandler::bfs(&mut buffer); + } + } + } + + impl Drop for LazyStream { + fn drop(&mut self) { + if self.initial_value == SteelVal::Void && self.stream_thunk == SteelVal::Void { + return; + } + + DROP_BUFFER + .try_with(|drop_buffer| { + if let Ok(mut drop_buffer) = drop_buffer.try_borrow_mut() { + drop_buffer.push_back(self.initial_value.make_void()); + drop_buffer.push_back(self.stream_thunk.make_void()); - // - if !self.add(s.as_ptr() as usize, val) { - for val in &s.borrow().fields { - self.visit(val); + IterativeDropHandler::bfs(&mut drop_buffer); } + }) + .ok(); + } + } + + impl Drop for ByteCodeLambda { + fn drop(&mut self) { + if self.captures.is_empty() { + return; + } + + DROP_BUFFER + .try_with(|drop_buffer| { + if let Ok(mut drop_buffer) = drop_buffer.try_borrow_mut() { + for value in std::mem::take(&mut self.captures) { + drop_buffer.push_back(value); + } + + IterativeDropHandler::bfs(&mut drop_buffer); + } + }) + .ok(); + } + } +} + +pub struct IterativeDropHandler<'a> { + drop_buffer: &'a mut VecDeque, +} + +impl<'a> IterativeDropHandler<'a> { + pub fn bfs(drop_buffer: &'a mut VecDeque) { + // println!("Current depth: {}", DEPTH.with(|x| x.get())); + + // DEPTH.with(|x| x.set(x.get() + 1)); + IterativeDropHandler { drop_buffer }.visit(); + // DEPTH.with(|x| x.set(x.get() - 1)); + } +} + +impl<'a> BreadthFirstSearchSteelValVisitor for IterativeDropHandler<'a> { + type Output = (); + + fn default_output(&mut self) -> Self::Output { + () + } + + fn pop_front(&mut self) -> Option { + self.drop_buffer.pop_front() + } + + fn push_back(&mut self, value: SteelVal) { + self.drop_buffer.push_back(value) + } + + fn visit_bool(&mut self, _boolean: bool) {} + fn visit_float(&mut self, _float: f64) {} + fn visit_int(&mut self, _int: isize) {} + fn visit_char(&mut self, _c: char) {} + fn visit_void(&mut self) {} + fn visit_string(&mut self, _string: SteelString) {} + fn visit_function_pointer(&mut self, _ptr: FunctionSignature) {} + fn visit_symbol(&mut self, _symbol: SteelString) {} + fn visit_port(&mut self, _port: Gc) {} + fn visit_future(&mut self, _future: Gc) {} + fn visit_mutable_function(&mut self, _function: MutFunctionSignature) {} + fn visit_bignum(&mut self, _bignum: Gc) {} + fn visit_future_function(&mut self, _function: BoxedAsyncFunctionSignature) {} + fn visit_builtin_function(&mut self, _function: BuiltInSignature) {} + fn visit_boxed_function(&mut self, _function: Rc) {} + + fn visit_closure(&mut self, closure: Gc) { + if let Ok(mut inner) = closure.try_unwrap() { + for value in std::mem::take(&mut inner.captures) { + self.push_back(value); + } + } + } + + fn visit_immutable_vector(&mut self, mut vector: SteelVector) { + if let Some(inner) = vector.0.get_mut() { + for value in std::mem::take(inner) { + self.push_back(value); + } + } + } + + fn visit_custom_type(&mut self, custom_type: Gc>>) { + if let Ok(inner) = custom_type.try_unwrap() { + let mut inner = inner.into_inner(); + + // let this decide if we're doing anything with this custom type + inner.drop_mut(self); + } + } + + fn visit_hash_map(&mut self, mut hashmap: SteelHashMap) { + if let Some(inner) = hashmap.0.get_mut() { + for (key, value) in std::mem::take(inner) { + self.push_back(key); + self.push_back(value); + } + } + } + + fn visit_hash_set(&mut self, mut hashset: SteelHashSet) { + if let Some(inner) = hashset.0.get_mut() { + for key in std::mem::take(inner) { + self.push_back(key); + } + } + } + + fn visit_steel_struct(&mut self, steel_struct: Gc) { + if let Ok(mut inner) = steel_struct.try_unwrap() { + for value in Vec::from(std::mem::take(&mut inner.fields)) { + self.push_back(value); + } + } + } + + fn visit_transducer(&mut self, transducer: Gc) { + if let Ok(inner) = transducer.try_unwrap() { + for transducer in inner.ops { + match transducer { + crate::values::transducers::Transducers::Map(m) => self.push_back(m), + crate::values::transducers::Transducers::Filter(v) => self.push_back(v), + crate::values::transducers::Transducers::Take(t) => self.push_back(t), + crate::values::transducers::Transducers::Drop(d) => self.push_back(d), + crate::values::transducers::Transducers::FlatMap(fm) => self.push_back(fm), + crate::values::transducers::Transducers::Flatten => {} + crate::values::transducers::Transducers::Window(w) => self.push_back(w), + crate::values::transducers::Transducers::TakeWhile(tw) => self.push_back(tw), + crate::values::transducers::Transducers::DropWhile(dw) => self.push_back(dw), + crate::values::transducers::Transducers::Extend(e) => self.push_back(e), + crate::values::transducers::Transducers::Cycle => {} + crate::values::transducers::Transducers::Enumerating => {} + crate::values::transducers::Transducers::Zipping(z) => self.push_back(z), + crate::values::transducers::Transducers::Interleaving(i) => self.push_back(i), } } - SteelVal::ListV(l) => { - for val in l { - self.visit(val); + } + } + + fn visit_reducer(&mut self, reducer: Gc) { + if let Ok(inner) = reducer.try_unwrap() { + match inner { + Reducer::ForEach(f) => self.push_back(f), + Reducer::Generic(rf) => { + self.push_back(rf.initial_value); + self.push_back(rf.function); + } + _ => {} + } + } + } + + fn visit_stream(&mut self, stream: Gc) { + if let Ok(mut inner) = stream.try_unwrap() { + self.push_back(replace_with_void(&mut inner.initial_value)); + self.push_back(replace_with_void(&mut inner.stream_thunk)); + } + } + + // Walk the whole thing! This includes the stack and all the stack frames + fn visit_continuation(&mut self, continuation: Gc) { + if let Ok(mut inner) = continuation.try_unwrap() { + for value in std::mem::take(&mut inner.stack) { + self.push_back(value); + } + + if let Some(inner) = inner.current_frame.function.get_mut() { + for value in std::mem::take(&mut inner.captures) { + self.push_back(value); + } + } + + for mut frame in std::mem::take(&mut inner.stack_frames) { + if let Some(inner) = frame.function.get_mut() { + for value in std::mem::take(&mut inner.captures) { + self.push_back(value); + } } } - SteelVal::HashMapV(h) => { - for (key, val) in h.iter() { - self.visit(key); - self.visit(val); + } + } + + fn visit_list(&mut self, mut list: List) { + // println!("VISITING LIST: {}", list.strong_count()); + // println!("list: {:?}", list); + + if list.strong_count() == 1 { + for value in list.draining_iterator() { + // println!( + // "PUSHING BACK VALUE - queue size: {}", + // self.drop_buffer.len() + // ); + + // println!("enqueueing: {}", value); + + self.push_back(value); + } + } + + // if list.strong_count() == 1 { + // for value in list { + // self.push_back(value); + // } + // } + } + + // TODO: When this gets replaced with heap storage, then we can do this more + // effectively! + fn visit_mutable_vector(&mut self, _vector: HeapRef>) {} + + // TODO: Once the root is added back to this, bring it back + fn visit_boxed_iterator(&mut self, iterator: Gc>) { + if let Ok(inner) = iterator.try_unwrap() { + self.push_back(inner.into_inner().root) + } + } + + fn visit_syntax_object(&mut self, syntax_object: Gc) { + if let Ok(inner) = syntax_object.try_unwrap() { + if let Some(raw) = inner.raw { + self.push_back(raw); + } + + self.push_back(inner.syntax); + } + } + + fn visit_boxed_value(&mut self, boxed_value: Gc>) { + if let Ok(inner) = boxed_value.try_unwrap() { + self.push_back(inner.into_inner()); + } + } + + fn visit_reference_value(&mut self, reference: Rc>) { + if let Ok(mut inner) = Rc::try_unwrap(reference) { + inner.drop_mut(self); + } + } + + fn visit_heap_allocated(&mut self, _heap_ref: HeapRef) -> Self::Output {} + + fn visit(&mut self) -> Self::Output { + let mut ret = self.default_output(); + + while let Some(value) = self.pop_front() { + ret = match value { + Closure(c) => self.visit_closure(c), + BoolV(b) => self.visit_bool(b), + NumV(n) => self.visit_float(n), + IntV(i) => self.visit_int(i), + CharV(c) => self.visit_char(c), + VectorV(v) => self.visit_immutable_vector(v), + Void => self.visit_void(), + StringV(s) => self.visit_string(s), + FuncV(f) => self.visit_function_pointer(f), + SymbolV(s) => self.visit_symbol(s), + SteelVal::Custom(c) => self.visit_custom_type(c), + HashMapV(h) => self.visit_hash_map(h), + HashSetV(s) => self.visit_hash_set(s), + CustomStruct(c) => self.visit_steel_struct(c), + PortV(p) => self.visit_port(p), + IterV(t) => self.visit_transducer(t), + ReducerV(r) => self.visit_reducer(r), + FutureFunc(f) => self.visit_future_function(f), + FutureV(f) => self.visit_future(f), + StreamV(s) => self.visit_stream(s), + BoxedFunction(b) => self.visit_boxed_function(b), + ContinuationFunction(c) => self.visit_continuation(c), + ListV(l) => self.visit_list(l), + MutFunc(m) => self.visit_mutable_function(m), + BuiltIn(b) => self.visit_builtin_function(b), + MutableVector(b) => self.visit_mutable_vector(b), + BoxedIterator(b) => self.visit_boxed_iterator(b), + SteelVal::SyntaxObject(s) => self.visit_syntax_object(s), + Boxed(b) => self.visit_boxed_value(b), + Reference(r) => self.visit_reference_value(r), + BigNum(b) => self.visit_bignum(b), + HeapAllocated(b) => self.visit_heap_allocated(b), + }; + } + + // println!("--- finished draining drop queue ----"); + + ret + } +} + +pub trait BreadthFirstSearchSteelValVisitor { + type Output; + + fn default_output(&mut self) -> Self::Output; + + fn pop_front(&mut self) -> Option; + + fn push_back(&mut self, value: SteelVal); + + fn visit(&mut self) -> Self::Output { + let mut ret = self.default_output(); + + while let Some(value) = self.pop_front() { + ret = match value { + Closure(c) => self.visit_closure(c), + BoolV(b) => self.visit_bool(b), + NumV(n) => self.visit_float(n), + IntV(i) => self.visit_int(i), + CharV(c) => self.visit_char(c), + VectorV(v) => self.visit_immutable_vector(v), + Void => self.visit_void(), + StringV(s) => self.visit_string(s), + FuncV(f) => self.visit_function_pointer(f), + SymbolV(s) => self.visit_symbol(s), + SteelVal::Custom(c) => self.visit_custom_type(c), + HashMapV(h) => self.visit_hash_map(h), + HashSetV(s) => self.visit_hash_set(s), + CustomStruct(c) => self.visit_steel_struct(c), + PortV(p) => self.visit_port(p), + IterV(t) => self.visit_transducer(t), + ReducerV(r) => self.visit_reducer(r), + FutureFunc(f) => self.visit_future_function(f), + FutureV(f) => self.visit_future(f), + StreamV(s) => self.visit_stream(s), + BoxedFunction(b) => self.visit_boxed_function(b), + ContinuationFunction(c) => self.visit_continuation(c), + ListV(l) => self.visit_list(l), + MutFunc(m) => self.visit_mutable_function(m), + BuiltIn(b) => self.visit_builtin_function(b), + MutableVector(b) => self.visit_mutable_vector(b), + BoxedIterator(b) => self.visit_boxed_iterator(b), + SteelVal::SyntaxObject(s) => self.visit_syntax_object(s), + Boxed(b) => self.visit_boxed_value(b), + Reference(r) => self.visit_reference_value(r), + BigNum(b) => self.visit_bignum(b), + HeapAllocated(b) => self.visit_heap_allocated(b), + }; + } + + ret + } + + fn visit_closure(&mut self, closure: Gc) -> Self::Output; + fn visit_bool(&mut self, boolean: bool) -> Self::Output; + fn visit_float(&mut self, float: f64) -> Self::Output; + fn visit_int(&mut self, int: isize) -> Self::Output; + fn visit_char(&mut self, c: char) -> Self::Output; + fn visit_immutable_vector(&mut self, vector: SteelVector) -> Self::Output; + fn visit_void(&mut self) -> Self::Output; + fn visit_string(&mut self, string: SteelString) -> Self::Output; + fn visit_function_pointer(&mut self, ptr: FunctionSignature) -> Self::Output; + fn visit_symbol(&mut self, symbol: SteelString) -> Self::Output; + fn visit_custom_type(&mut self, custom_type: Gc>>) -> Self::Output; + fn visit_hash_map(&mut self, hashmap: SteelHashMap) -> Self::Output; + fn visit_hash_set(&mut self, hashset: SteelHashSet) -> Self::Output; + fn visit_steel_struct(&mut self, steel_struct: Gc) -> Self::Output; + fn visit_port(&mut self, port: Gc) -> Self::Output; + fn visit_transducer(&mut self, transducer: Gc) -> Self::Output; + fn visit_reducer(&mut self, reducer: Gc) -> Self::Output; + fn visit_future_function(&mut self, function: BoxedAsyncFunctionSignature) -> Self::Output; + fn visit_future(&mut self, future: Gc) -> Self::Output; + fn visit_stream(&mut self, stream: Gc) -> Self::Output; + fn visit_boxed_function(&mut self, function: Rc) -> Self::Output; + fn visit_continuation(&mut self, continuation: Gc) -> Self::Output; + fn visit_list(&mut self, list: List) -> Self::Output; + fn visit_mutable_function(&mut self, function: MutFunctionSignature) -> Self::Output; + fn visit_mutable_vector(&mut self, vector: HeapRef>) -> Self::Output; + fn visit_builtin_function(&mut self, function: BuiltInSignature) -> Self::Output; + fn visit_boxed_iterator(&mut self, iterator: Gc>) -> Self::Output; + fn visit_syntax_object(&mut self, syntax_object: Gc) -> Self::Output; + fn visit_boxed_value(&mut self, boxed_value: Gc>) -> Self::Output; + fn visit_reference_value(&mut self, reference: Rc>) -> Self::Output; + fn visit_bignum(&mut self, bignum: Gc) -> Self::Output; + fn visit_heap_allocated(&mut self, heap_ref: HeapRef) -> Self::Output; +} + +thread_local! { + static LEFT_QUEUE: RefCell> = RefCell::new(VecDeque::with_capacity(128)); + static RIGHT_QUEUE: RefCell> = RefCell::new(VecDeque::with_capacity(128)); + static VISITED_SET: RefCell> = RefCell::new(fxhash::FxHashSet::default()); + static EQ_DEPTH: Cell = Cell::new(0); +} + +fn increment_eq_depth() { + #[cfg(feature = "sandbox")] + EQ_DEPTH.with(|x| x.set(x.get() + 1)); +} + +fn decrement_eq_depth() { + #[cfg(feature = "sandbox")] + EQ_DEPTH.with(|x| x.set(x.get() - 1)); +} + +fn reset_eq_depth() { + #[cfg(feature = "sandbox")] + EQ_DEPTH.with(|x| x.set(0)); +} + +fn eq_depth() -> usize { + #[cfg(feature = "sandbox")] + return EQ_DEPTH.with(|x| x.get()); + + #[cfg(not(feature = "sandbox"))] + 0 +} + +struct RecursiveEqualityHandler<'a> { + left: EqualityVisitor<'a>, + right: EqualityVisitor<'a>, + visited: &'a mut fxhash::FxHashSet, + found_mutable_object: bool, +} + +impl<'a> RecursiveEqualityHandler<'a> { + pub fn compare_equality(&mut self, left: SteelVal, right: SteelVal) -> bool { + self.left.push_back(left); + self.right.push_back(right); + + self.visit() + } + + fn should_visit(&mut self, value: usize) -> bool { + if self.found_mutable_object && self.visited.insert(value) { + return true; + } + + if !self.found_mutable_object { + return true; + } + + return false; + } + + fn visit(&mut self) -> bool { + loop { + let (left, right) = match (self.left.pop_front(), self.right.pop_front()) { + (Some(l), Some(r)) => (l, r), + (None, None) => return true, + _ => return false, + }; + + match (left, right) { + (Closure(l), Closure(r)) => { + if l != r { + return false; + } + + self.left.visit_closure(l); + + continue; + } + (BoolV(l), BoolV(r)) => { + if l != r { + return false; + } + + continue; + } + (NumV(l), NumV(r)) => { + if l != r { + return false; + } + + continue; + } + (IntV(l), IntV(r)) => { + if l != r { + return false; + } + + continue; + } + (CharV(l), CharV(r)) => { + if l != r { + return false; + } + + continue; + } + (VectorV(l), VectorV(r)) => { + if l.len() != r.len() { + return false; + } + + // If these point to the same object, break early + if Gc::ptr_eq(&l.0, &r.0) { + continue; + } + + // Should we visit these? + if self.should_visit(l.0.as_ptr() as usize) + && self.should_visit(r.0.as_ptr() as usize) + { + self.left.visit_immutable_vector(l); + self.right.visit_immutable_vector(r); + } else { + return false; + } + + continue; + } + (Void, Void) => { + continue; + } + (StringV(l), StringV(r)) => { + if l != r { + return false; + } + continue; + } + (FuncV(l), FuncV(r)) => { + if l != r { + return false; + } + continue; + } + (SymbolV(l), SymbolV(r)) => { + if l != r { + return false; + } + continue; + } + (SteelVal::Custom(l), SteelVal::Custom(r)) => { + if l.borrow().inner_type_id() != r.borrow().inner_type_id() { + return false; + } + + if l.borrow().check_equality_hint(r.borrow().as_ref()) { + // Go down to the next level + self.left.visit_custom_type(l); + self.right.visit_custom_type(r); + continue; + } else { + return false; + } + } + (SteelVal::HashMapV(l), SteelVal::HashMapV(r)) => { + if Gc::ptr_eq(&l.0, &r.0) { + println!("Found ptr equality"); + + continue; + } + + if self.should_visit(l.0.as_ptr() as usize) + && self.should_visit(r.0.as_ptr() as usize) + { + if l.len() != r.len() { + return false; + } + + // TODO: Implicitly here we are assuming that this key was even hashable + // to begin with, since it ended up in the right spot, and didn't blow + // the stack on a recursive structure. + // + // This still does not handle the pathological edge case of something like + // (hash (hash (hash ...) value) value) + // + // In this case, we'll get a stack overflow, when trying to compare equality + // with these maps if they're sufficiently deep. + // + // The issue is that if the two maps are equivalent, we need to check the + // existence of each key in the left map with each key in the right map. + // Doing so invokes an equality check, where we'll then invoke this logic + // again. We could solve this by disallowing hashmaps as keys - then + // we would not the same issue where putting a hashmap into the map + // causes the equality checks to go off the rails. + + if eq_depth() > 512 { + log::error!("Aborting eq checks before the stack overflows"); + + return false; + } + + for (key, value) in l.0.iter() { + if let Some(right_value) = r.0.get(key) { + self.left.push_back(value.clone()); + self.right.push_back(right_value.clone()); + } else { + // We know that these are not equal, because the + // key in the left map does not exist in the right + return false; + } + } + } + + continue; + } + (HashSetV(l), HashSetV(r)) => { + if Gc::ptr_eq(&l.0, &r.0) { + continue; + } + + if self.should_visit(l.0.as_ptr() as usize) + && self.should_visit(r.0.as_ptr() as usize) + { + if l.len() != r.len() { + return false; + } + if eq_depth() > 512 { + log::error!("Aborting eq checks before the stack overflows"); + + return false; + } + + for key in l.0.iter() { + if !l.0.contains(key) { + return false; + } + } + } + + continue; + } + (CustomStruct(l), CustomStruct(r)) => { + // If these are the same object, just continue + if Gc::ptr_eq(&l, &r) { + continue; + } + + if self.should_visit(l.as_ptr() as usize) + && self.should_visit(r.as_ptr() as usize) + { + // Check the top level equality indicators to make sure + // that these two types are the same + if !(l.type_descriptor == r.type_descriptor && l.name() == r.name()) { + return false; + } + + self.left.visit_steel_struct(l); + self.right.visit_steel_struct(r); + } + + continue; + } + // (PortV(_), PortV(_)) => { + // return + // } + (IterV(l), IterV(r)) => { + self.left.visit_transducer(l); + self.right.visit_transducer(r); + + continue; + } + (ReducerV(l), ReducerV(r)) => { + self.left.visit_reducer(l); + self.right.visit_reducer(r); + + continue; + } + // FutureV(f) => self.visit_future(f), + (ContinuationFunction(l), ContinuationFunction(r)) => { + if !Gc::ptr_eq(&l, &r) { + return false; + } + + continue; + } + (ListV(l), ListV(r)) => { + // If we've reached the same object, we're good + if l.ptr_eq(&r) { + continue; + } + + if self.should_visit(l.as_ptr_usize()) && self.should_visit(r.as_ptr_usize()) { + if l.len() != r.len() { + return false; + } + + self.left.visit_list(l); + self.right.visit_list(r); + } + + continue; + } + // MutFunc(m) => self.visit_mutable_function(m), + (BuiltIn(l), BuiltIn(r)) => { + if l != r { + return false; + } + continue; + } + // MutableVector(b) => self.visit_mutable_vector(b), + // BoxedIterator(b) => self.visit_boxed_iterator(b), + // SteelVal::SyntaxObject(s) => self.visit_syntax_object(s), + // Boxed(b) => self.visit_boxed_value(b), + // Reference(r) => self.visit_reference_value(r), + (BigNum(l), BigNum(r)) => { + if l != r { + return false; + } + continue; + } + (SyntaxObject(l), SyntaxObject(r)) => { + if Gc::ptr_eq(&l, &r) { + continue; + } + + self.left.visit_syntax_object(l); + self.right.visit_syntax_object(r); + } + (HeapAllocated(l), HeapAllocated(r)) => { + self.left.visit_heap_allocated(l); + self.right.visit_heap_allocated(r); + + continue; + } + (_, _) => { + return false; } } + + // unreachable!(); + } + } +} + +pub struct EqualityVisitor<'a> { + // Mark each node that we've visited, if we encounter any mutable objects + // on the way, then we'll start using the visited set. But we'll optimistically + // assume that there are no mutable objects, and we won't start using this + // until we absolutely have to. + // found_mutable_object: bool, + queue: &'a mut VecDeque, +} + +impl<'a> BreadthFirstSearchSteelValVisitor for EqualityVisitor<'a> { + type Output = (); + + fn default_output(&mut self) -> Self::Output {} + + fn pop_front(&mut self) -> Option { + self.queue.pop_front() + } + + fn push_back(&mut self, value: SteelVal) { + self.queue.push_back(value) + } + + fn visit_closure(&mut self, _closure: Gc) -> Self::Output {} + + // Leaf nodes, we don't need to do anything here + fn visit_bool(&mut self, _boolean: bool) -> Self::Output {} + fn visit_float(&mut self, _float: f64) -> Self::Output {} + fn visit_int(&mut self, _int: isize) -> Self::Output {} + fn visit_char(&mut self, _c: char) -> Self::Output {} + fn visit_void(&mut self) -> Self::Output {} + fn visit_string(&mut self, _string: SteelString) -> Self::Output {} + fn visit_function_pointer(&mut self, _ptr: FunctionSignature) -> Self::Output {} + fn visit_symbol(&mut self, _symbol: SteelString) -> Self::Output {} + fn visit_port(&mut self, _port: Gc) -> Self::Output {} + fn visit_boxed_function(&mut self, _function: Rc) -> Self::Output {} + fn visit_mutable_function(&mut self, _function: MutFunctionSignature) -> Self::Output {} + fn visit_builtin_function(&mut self, _function: BuiltInSignature) -> Self::Output {} + + // + fn visit_immutable_vector(&mut self, vector: SteelVector) -> Self::Output { + // If we've found the mutable object, mark that this has been visited. Only + // if self.should_visit(vector.0.as_ptr() as usize) { + for value in vector.iter() { + self.push_back(value.clone()); + } + // } + } + + // SHOULD SET MUTABLE HERE + fn visit_custom_type(&mut self, custom_type: Gc>>) -> Self::Output { + custom_type.borrow().visit_children_for_equality(self); + } + + fn visit_hash_map(&mut self, _hashmap: SteelHashMap) -> Self::Output { + // TODO: See comment above + } + + fn visit_hash_set(&mut self, _hashset: SteelHashSet) -> Self::Output { + // TODO: See comment above + } + + fn visit_steel_struct(&mut self, steel_struct: Gc) -> Self::Output { + // if self.should_visit(steel_struct.as_ptr() as usize) { + for value in steel_struct.fields.iter() { + self.push_back(value.clone()); + } + // } + } + + fn visit_transducer(&mut self, transducer: Gc) -> Self::Output { + for transducer in transducer.ops.iter() { + match transducer.clone() { + crate::values::transducers::Transducers::Map(m) => self.push_back(m), + crate::values::transducers::Transducers::Filter(v) => self.push_back(v), + crate::values::transducers::Transducers::Take(t) => self.push_back(t), + crate::values::transducers::Transducers::Drop(d) => self.push_back(d), + crate::values::transducers::Transducers::FlatMap(fm) => self.push_back(fm), + crate::values::transducers::Transducers::Flatten => {} + crate::values::transducers::Transducers::Window(w) => self.push_back(w), + crate::values::transducers::Transducers::TakeWhile(tw) => self.push_back(tw), + crate::values::transducers::Transducers::DropWhile(dw) => self.push_back(dw), + crate::values::transducers::Transducers::Extend(e) => self.push_back(e), + crate::values::transducers::Transducers::Cycle => {} + crate::values::transducers::Transducers::Enumerating => {} + crate::values::transducers::Transducers::Zipping(z) => self.push_back(z), + crate::values::transducers::Transducers::Interleaving(i) => self.push_back(i), + } + } + } + + fn visit_reducer(&mut self, reducer: Gc) -> Self::Output { + match reducer.as_ref().clone() { + Reducer::ForEach(f) => self.push_back(f), + Reducer::Generic(rf) => { + self.push_back(rf.initial_value); + self.push_back(rf.function); + } _ => {} } } + + fn visit_future_function(&mut self, _function: BoxedAsyncFunctionSignature) -> Self::Output {} + fn visit_future(&mut self, _future: Gc) -> Self::Output {} + fn visit_bignum(&mut self, _bignum: Gc) -> Self::Output {} + + fn visit_stream(&mut self, _stream: Gc) -> Self::Output {} + + fn visit_continuation(&mut self, _continuation: Gc) -> Self::Output {} + + fn visit_list(&mut self, list: List) -> Self::Output { + for value in list { + self.push_back(value); + } + } + + fn visit_mutable_vector(&mut self, vector: HeapRef>) -> Self::Output { + for value in vector.get().iter() { + self.push_back(value.clone()); + } + } + + fn visit_boxed_iterator(&mut self, _iterator: Gc>) -> Self::Output {} + + fn visit_syntax_object(&mut self, syntax_object: Gc) -> Self::Output { + if let Some(raw) = syntax_object.raw.clone() { + self.push_back(raw); + } + + self.push_back(syntax_object.syntax.clone()); + } + + fn visit_boxed_value(&mut self, boxed_value: Gc>) -> Self::Output { + self.push_back(boxed_value.borrow().clone()); + } + + fn visit_reference_value(&mut self, _reference: Rc>) -> Self::Output {} + + // Should set mutable here + fn visit_heap_allocated(&mut self, heap_ref: HeapRef) -> Self::Output { + // self.found_mutable_object = true; + + // if self.should_visit(heap_ref.as_ptr_usize()) { + self.push_back(heap_ref.get()); + // } + } +} + +impl PartialEq for SteelVal { + fn eq(&self, other: &Self) -> bool { + match (self, other) { + (Void, Void) => true, + (BoolV(l), BoolV(r)) => l == r, + (BigNum(l), BigNum(r)) => l == r, + (IntV(l), IntV(r)) => l == r, + + // Floats shouls also be considered equal + (NumV(l), NumV(r)) => l == r, + + (StringV(l), StringV(r)) => l == r, + // (VectorV(l), VectorV(r)) => l == r, + (SymbolV(l), SymbolV(r)) => l == r, + (CharV(l), CharV(r)) => l == r, + // (HashSetV(l), HashSetV(r)) => l == r, + // (HashMapV(l), HashMapV(r)) => l == r, + // (Closure(l), Closure(r)) => l == r, + // (IterV(l), IterV(r)) => l == r, + // (ListV(l), ListV(r)) => l == r, + // (CustomStruct(l), CustomStruct(r)) => l == r, + (FuncV(l), FuncV(r)) => *l == *r, + // (Custom(l), Custom(r)) => Gc::ptr_eq(l, r), + // (HeapAllocated(l), HeapAllocated(r)) => l.get() == r.get(), + (left, right) => LEFT_QUEUE.with(|left_queue| { + RIGHT_QUEUE.with(|right_queue| { + VISITED_SET.with(|visited_set| { + match ( + left_queue.try_borrow_mut(), + right_queue.try_borrow_mut(), + visited_set.try_borrow_mut(), + ) { + (Ok(mut left_queue), Ok(mut right_queue), Ok(mut visited_set)) => { + let mut equality_handler = RecursiveEqualityHandler { + left: EqualityVisitor { + queue: &mut left_queue, + }, + right: EqualityVisitor { + queue: &mut right_queue, + }, + visited: &mut visited_set, + found_mutable_object: false, + }; + + let res = + equality_handler.compare_equality(left.clone(), right.clone()); + + // EQ_DEPTH.with(|x| x.set(0)); + + reset_eq_depth(); + + // Clean up! + equality_handler.left.queue.clear(); + equality_handler.right.queue.clear(); + equality_handler.visited.clear(); + + res + } + _ => { + let mut left_queue = VecDeque::new(); + let mut right_queue = VecDeque::new(); + + let mut visited_set = fxhash::FxHashSet::default(); + + // EQ_DEPTH.with(|x| x.set(x.get() + 1)); + + increment_eq_depth(); + + // println!("{}", EQ_DEPTH.with(|x| x.get())); + + let mut equality_handler = RecursiveEqualityHandler { + left: EqualityVisitor { + queue: &mut left_queue, + }, + right: EqualityVisitor { + queue: &mut right_queue, + }, + visited: &mut visited_set, + found_mutable_object: false, + }; + + let res = + equality_handler.compare_equality(left.clone(), right.clone()); + + // EQ_DEPTH.with(|x| x.set(x.get() - 1)); + + decrement_eq_depth(); + + res + } + } + }) + }) + }), + } + } } diff --git a/crates/steel-core/src/scheme/contract.rkt b/crates/steel-core/src/scheme/contract.rkt index 670c93baa..4bdcc0fdf 100644 --- a/crates/steel-core/src/scheme/contract.rkt +++ b/crates/steel-core/src/scheme/contract.rkt @@ -1,39 +1,39 @@ -;; Contract combinators -(define (listof pred) - (lambda (lst) - (define (loop lst) - (cond [(null? lst) #t] - [(pred (car lst)) (loop (cdr lst))] - [else #f])) - (cond [(null? lst) #t] - [(list? lst) - (loop lst)] - [else #f]))) +; ;; Contract combinators +; (define (listof pred) +; (lambda (lst) +; (define (loop lst) +; (cond [(null? lst) #t] +; [(pred (car lst)) (loop (cdr lst))] +; [else #f])) +; (cond [(null? lst) #t] +; [(list? lst) +; (loop lst)] +; [else #f]))) -;; Contracts for < -(define ( -(define (>/c n) - (make/c (fn (x) (> x n)) (list '>/c n))) +; ;; Contracts for > +; (define (>/c n) +; (make/c (fn (x) (> x n)) (list '>/c n))) -;; Contracts for <= -(define (<=/c n) - (make/c (fn (x) (<= x n)) (list '<=/c n))) +; ;; Contracts for <= +; (define (<=/c n) +; (make/c (fn (x) (<= x n)) (list '<=/c n))) -;; Contracts for >= -(define (>=/c n) - (make/c (fn (x) (>= x n)) (list '>=/c n))) +; ;; Contracts for >= +; (define (>=/c n) +; (make/c (fn (x) (>= x n)) (list '>=/c n))) -;; Satisfies any single value -(define (any/c x) - (make/c (fn (x) #t) 'any/c)) +; ;; Satisfies any single value +; (define (any/c x) +; (make/c (fn (x) #t) 'any/c)) -;; produces a function compatible with contract definitions -(define (and/c x y) - (lambda (z) (and (x z) (y z)))) +; ;; produces a function compatible with contract definitions +; (define (and/c x y) +; (lambda (z) (and (x z) (y z)))) -;; produces a function compatible with contract definitions -(define (or/c x y) - (lambda (z) (or (x z) (y z)))) \ No newline at end of file +; ;; produces a function compatible with contract definitions +; (define (or/c x y) +; (lambda (z) (or (x z) (y z)))) diff --git a/crates/steel-core/src/scheme/kernel.scm b/crates/steel-core/src/scheme/kernel.scm index eae8915af..26336e224 100644 --- a/crates/steel-core/src/scheme/kernel.scm +++ b/crates/steel-core/src/scheme/kernel.scm @@ -50,7 +50,7 @@ (if (symbol? (car pair)) ;; TODO: @Matt - this causes a parser error ;; (cons `(quote ,(car x)) (cdr x)) - (list (list 'quote (car pair)) (list 'quote (cadr pair))) + (list (list 'quote (car pair)) (cadr pair)) pair))) (flattening) (into-list))) @@ -68,6 +68,7 @@ (let ([raw (cdddr unwrapped)]) ; (displayln raw) (if (empty? raw) raw (map syntax->datum raw)))) + (struct-impl struct-name fields options)) ;; Macro for creating a new struct, in the form of: @@ -106,7 +107,31 @@ (filtering (lambda (x) (not (transparent-keyword? x)))) (into-list))) - (define extra-options (hash '#:mutable mutable? '#:transparent transparent? '#:fields fields)) + (define default-printer-function + (if transparent? + `(lambda (obj printer-function) + (display "(") + (printer-function (symbol->string ,(list 'quote struct-name))) + ,@(map (lambda (field) + `(begin + (display " ") + (printer-function (,(concat-symbols struct-name '- field) obj)))) + fields) + + (display ")")) + + #f)) + + ;; Set up default values to go in the table + (define extra-options + (hash '#:mutable + mutable? + '#:transparent + transparent? + '#:fields + (list 'quote fields) + '#:name + (list 'quote struct-name))) (when (not (list? fields)) (error! "struct expects a list of field names, found " fields)) @@ -120,6 +145,9 @@ ;; Update the options-map to have the fields included (let* ([options-map (apply hash options-without-single-keywords)] [options-map (hash-union options-map extra-options)] + [options-map (if (hash-try-get options-map '#:printer) + options-map + (hash-insert options-map '#:printer default-printer-function))] [maybe-procedure-field (hash-try-get options-map '#:prop:procedure)]) (when (and maybe-procedure-field (> maybe-procedure-field (length fields))) @@ -150,20 +178,25 @@ (let ([struct-type-descriptor (list-ref prototypes 0)] [constructor-proto (list-ref prototypes 1)] [predicate-proto (list-ref prototypes 2)] - [getter-proto (list-ref prototypes 3)] - [setter-proto (list-ref prototypes 4)]) + [getter-proto (list-ref prototypes 3)]) (set! ,(concat-symbols 'struct: struct-name) struct-type-descriptor) (#%vtable-update-entry! struct-type-descriptor ,maybe-procedure-field ,(concat-symbols '___ struct-name '-options___)) - (set! ,struct-name constructor-proto) + ,(if mutable? + `(set! ,struct-name + (lambda ,fields (constructor-proto ,@(map (lambda (x) `(#%box ,x)) fields)))) + + `(set! ,struct-name constructor-proto)) ,(new-make-predicate struct-name fields) - ,@(new-make-getters struct-name fields) + ,@(if mutable? + (mutable-make-getters struct-name fields) + (new-make-getters struct-name fields)) ;; If this is a mutable struct, generate the setters - ,@(if mutable? (new-make-setters struct-name fields) (list)) + ,@(if mutable? (mutable-make-setters struct-name fields) (list)) void))))) (define (new-make-predicate struct-name fields) @@ -175,6 +208,18 @@ ; (lambda ,fields ; (constructor-proto ,(concat-symbols '___ struct-name '-options___) ,procedure-index ,@fields)))) +(define (mutable-make-getters struct-name fields) + (map (lambda (field) + `(set! ,(concat-symbols struct-name '- (car field)) + (lambda (this) (#%unbox (getter-proto this ,(list-ref field 1)))))) + (enumerate 0 '() fields))) + +(define (mutable-make-setters struct-name fields) + (map (lambda (field) + `(set! ,(concat-symbols 'set- struct-name '- (car field) '!) + (lambda (this value) (#%set-box! (getter-proto this ,(list-ref field 1)) value)))) + (enumerate 0 '() fields))) + (define (new-make-getters struct-name fields) (map (lambda (field) `(set! ,(concat-symbols struct-name '- (car field)) diff --git a/crates/steel-core/src/scheme/modules/contracts.scm b/crates/steel-core/src/scheme/modules/contracts.scm new file mode 100644 index 000000000..187161854 --- /dev/null +++ b/crates/steel-core/src/scheme/modules/contracts.scm @@ -0,0 +1,515 @@ +(provide make-function/c + make/c + bind/c + FlatContract + FlatContract? + FlatContract-predicate + FlatContract-name + FunctionContract + FunctionContract? + FunctionContract-pre-conditions + FunctionContract-post-condition + contract->string + (for-syntax ->/c) + (for-syntax define/contract)) + +;; struct definitions +(struct FlatContract (predicate name) + #:prop:procedure 0 + #:printer (lambda (obj printer-function) (printer-function (contract->string obj)))) +;; Contract Attachment - use this for understanding where something happened +(struct ContractAttachmentLocation (type name)) + +;; Function Contract - keep track of preconditions and post conditions, where +;; the contract was attached, and a pointer to the parent contract. Can probably +;; replace parent with just a list of the parents since it can be shared +;; directly +(struct FunctionContract (pre-conditions post-condition contract-attachment-location parents) + #:printer (lambda (obj printer-function) (printer-function (contract->string obj)))) + +(struct DependentPair (argument-name arguments thunk thunk-name)) + +(struct DependentContract + (arg-positions pre-conditions post-condition contract-attachment-location parent)) + +;; TODO: Raise error with contract violation directly attached, if possible +;; +(struct ContractViolation (error-message)) + +(struct ContractedFunction (contract function name)) + +;; Alias the name for clarity +(define make-flat-contract FlatContract) + +;;#| +;; Testing out a multi line comment... +;; |# +(define (new-FunctionContract #:pre-conditions pre-conditions + #:post-condition post-condition + #:contract-attachment-location (contract-attachment-location void) + ;; TODO: so this parents business isn't even practical + ;; -> it can get removed safely, maybe revisited later + #:parents (parents '())) + (FunctionContract pre-conditions post-condition contract-attachment-location parents)) + +;; Formats a contract nicely as a string +(define (contract->string contract) + (cond + [(FlatContract? contract) + => + (symbol->string (FlatContract-name contract))] + [(FunctionContract? contract) + => + (to-string "(->" + (apply to-string + (transduce (FunctionContract-pre-conditions contract) + (mapping contract->string) + (into-list))) + (contract->string (FunctionContract-post-condition contract)) + ")")] + [else + => + (error! "Unexpected value found in contract:" contract)])) + +;; Given a list, splits off the last argument, returns as a pair +(define (split-last lst) + (define (loop accum lst) + (if (empty? (cdr lst)) (list (reverse accum) (car lst)) (loop (cons (car lst) accum) (cdr lst)))) + (loop '() lst)) + +;;@doc +;; Creates a `FunctionContract` from the list of conditions, splitting out the +;; preconditions and the postconditions +(define make-function/c + (lambda conditions + (%plain-let ((split (split-last conditions))) + (FunctionContract (first split) (second split) void '())))) + +;; Applies a flat contract to the given argument +(define (apply-flat-contract flat-contract arg) + ; ((FlatContract-predicate flat-contract) arg) + (if (flat-contract arg) + #true + (ContractViolation + (to-string "Contract violation: found in the application of a flat contract for" + (FlatContract-name flat-contract) + ": the given input:" + arg + "resulted in a contract violation")))) + +;; ; (define (apply-parents parent name function arguments span) +;; ; (if (void? parent) +;; ; #true +;; ; (begin +;; ; (displayln "Applying parent contract") +;; ; (apply-function-contract (ContractedFunction-contract parent) +;; ; name +;; ; function +;; ; arguments +;; ; span) + +;; ; (apply-parents (FunctionContract-parent parent) name function arguments span)))) + +;; Call a contracted function +(define (apply-contracted-function contracted-function arguments span) + ; (displayln "Passed in span: " span) + (define span (if span span '(0 0 0))) + (apply-function-contract (ContractedFunction-contract contracted-function) + (ContractedFunction-name contracted-function) + (ContractedFunction-function contracted-function) + arguments + span)) + +;;@doc +;; Verifies the arguments against the FunctionContract, and then produces +;; a new list of arguments, with any arguments wrapped in function contracts if they happen +;; to be higher order +(define (verify-preconditions self-contract arguments name span) + (unless (equal? (length arguments) (length (FunctionContract-pre-conditions self-contract))) + (error-with-span span + "Arity mismatch, function expected " + (length (FunctionContract-pre-conditions self-contract)) + "Found: " + (length arguments))) + + (transduce + arguments + (zipping (FunctionContract-pre-conditions self-contract)) + (enumerating) + (mapping + (lambda (x) + (let ([i (first x)] [arg (first (second x))] [contract (second (second x))]) + + (cond + [(FlatContract? contract) + => + + (let ([result (apply-flat-contract contract arg)]) + (if (ContractViolation? result) + (error-with-span span + "This function call caused an error" + "- it occured in the domain position:" + i + ", with the contract: " + (contract->string contract) + (ContractViolation-error-message result) + ", blaming " + (ContractAttachmentLocation-name + (FunctionContract-contract-attachment-location self-contract)) + "(callsite)") + arg))] + [(FunctionContract? contract) + => + (if (ContractedFunction? arg) + (let ([pre-parent (ContractedFunction-contract arg)]) + (let ([parent (new-FunctionContract + #:pre-conditions (FunctionContract-pre-conditions pre-parent) + #:post-condition (FunctionContract-post-condition pre-parent) + #:contract-attachment-location + (ContractAttachmentLocation 'DOMAIN (ContractedFunction-name arg)) + #:parents (FunctionContract-parents pre-parent))]) + (let ([fc (new-FunctionContract + #:pre-conditions (FunctionContract-pre-conditions contract) + #:post-condition (FunctionContract-post-condition contract) + #:contract-attachment-location + (ContractAttachmentLocation 'DOMAIN (ContractedFunction-name arg)) + #:parents (cons parent (FunctionContract-parents parent)))]) + + (bind/c fc arg name span)))) + (bind/c contract arg name span))] + [else + => + (error! "Unexpected value in pre conditions: " contract)])))) + (into-list))) + +(define (apply-function-contract contract name function arguments span) + ;; Check that each of the arguments abides by the + (let ([validated-arguments (verify-preconditions contract arguments name span)]) + + (let ([output (with-handler (lambda (err) (raise-error err)) + (apply function validated-arguments))] + + [self-contract contract] + [self-contract-attachment-location (FunctionContract-contract-attachment-location contract)] + [contract (FunctionContract-post-condition contract)]) + + (cond + [(FlatContract? contract) + => + + (let ([result (apply-flat-contract contract output)]) + (if (ContractViolation? result) + (let ([blame-location (if (void? self-contract-attachment-location) + name + self-contract-attachment-location)]) + + (cond + [(void? blame-location) + => + (error-with-span + span + "this function call resulted in an error - occured in the range position of this contract: " + (contract->string self-contract) + (ContractViolation-error-message result) + "blaming: None - broke its own contract")] + + [else + => + (error-with-span + span + "this function call resulted in an error - occurred in the range position of this contract: " + (contract->string self-contract) + (ContractViolation-error-message result) + "blaming: " + blame-location)])) + + output))] + [(FunctionContract? contract) + => + + (define original-function output) + + (if (FunctionContract? (get-contract-struct output)) + + ;; TODO: Come back to this and understand what the heck its doing + ;; Figured it out -> its never actually a contracted function, because we're wrapping + ;; it directly in a normal function type. + (begin + (define output (get-contract-struct output)) + (define pre-parent contract) + (define contract-attachment-location + (ContractAttachmentLocation 'RANGE + (ContractAttachmentLocation-name + self-contract-attachment-location))) + (define parent + (new-FunctionContract #:pre-conditions (FunctionContract-pre-conditions pre-parent) + #:post-condition (FunctionContract-post-condition pre-parent) + #:contract-attachment-location contract-attachment-location + #:parents (FunctionContract-parents pre-parent))) + (define fc + (new-FunctionContract #:pre-conditions (FunctionContract-pre-conditions contract) + #:post-condition (FunctionContract-post-condition contract) + #:contract-attachment-location contract-attachment-location + #:parents (cons parent (FunctionContract-parents pre-parent)))) + + (bind/c fc original-function name span)) + (bind/c contract output name span))] + [else + => + (error! "Unhandled value in post condition: " contract)])))) + +(define (bind/c contract function name . span) + (define post-condition (FunctionContract-post-condition contract)) + + (let ([updated-preconditions + (transduce (FunctionContract-pre-conditions contract) + (mapping (lambda (c) + (cond + [(FlatContract? c) + => + c] + [(FunctionContract? c) + => + (FunctionContract (FunctionContract-pre-conditions c) + (FunctionContract-post-condition c) + (ContractAttachmentLocation 'DOMAIN name) + (FunctionContract-parents c))] + [else + => + (error "Unexpected value found in bind/c preconditions: " c)]))) + (into-list))] + + [updated-postcondition (cond + [(FlatContract? post-condition) + => + post-condition] + [(FunctionContract? post-condition) + => + + (FunctionContract (FunctionContract-pre-conditions post-condition) + (FunctionContract-post-condition post-condition) + (ContractAttachmentLocation 'RANGE name) + (FunctionContract-parents post-condition))] + [else + => + + (error "Unexpected value found in bind/c post condition: " + post-condition)])]) + + (let ([contracted-function + (ContractedFunction (FunctionContract updated-preconditions + updated-postcondition + ; void + ; (ContractAttachmentLocation 'TOPLEVEL name) + ; void + (ContractAttachmentLocation 'TOPLEVEL name) + (if (get-contract-struct function) + (cons (get-contract-struct function) + (FunctionContract-parents contract)) + (FunctionContract-parents contract))) + function + name)]) + + (let ([resulting-lambda-function + (lambda args + + (apply-contracted-function + contracted-function + args + ; span + ; (current-function-span) + (if span (car span) (current-function-span)) + ; (begin (displayln ("Current span: " (current-function-span))) + ; (current-function-span))) + ))]) + (attach-contract-struct! resulting-lambda-function + (ContractedFunction-contract contracted-function)) + resulting-lambda-function)))) + +(define (make/c contract name) + (cond + [(FlatContract? contract) contract] + [(FunctionContract? contract) contract] + [else + => + (FlatContract contract name)])) + +(define-syntax ->/c + (syntax-rules () + [(->/c r) (make-function/c (make/c r 'r))] + [(->/c a b) (make-function/c (make/c a 'a) (make/c b 'b))] + [(->/c a b c) (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c))] + [(->/c a b c d) (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c) (make/c d 'd))] + [(->/c a b c d e) + (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c) (make/c d 'd) (make/c e 'e))] + [(->/c a b c d e f) + (make-function/c (make/c a 'a) + (make/c b 'b) + (make/c c 'c) + (make/c d 'd) + (make/c e 'e) + (make/c f 'f))] + [(->/c a b c d e f g) + (make-function/c (make/c a 'a) + (make/c b 'b) + (make/c c 'c) + (make/c d 'd) + (make/c e 'e) + (make/c f 'f) + (make/c g 'g))] + [(->/c a b c d e f g h) + (make-function/c (make/c a 'a) + (make/c b 'b) + (make/c c 'c) + (make/c d 'd) + (make/c e 'e) + (make/c f 'f) + (make/c g 'g) + (make/c h 'h))] + [(->/c a b c d e f g h i) + (make-function/c (make/c a 'a) + (make/c b 'b) + (make/c c 'c) + (make/c d 'd) + (make/c e 'e) + (make/c f 'f) + (make/c g 'g) + (make/c h 'h) + (make/c i 'i))])) + +;; Macro for basic usage of contracts +(define-syntax define/contract + (syntax-rules () + [(define/contract (name args ...) + contract + body ...) + (begin + (define name + (lambda (args ...) + body ...)) + (set! name (bind/c contract name 'name)) + void) + ; (define name (bind/c contract (lambda (args ...) body ...) 'name)) + ] + [(define/contract name + contract + expr) + (define name ((bind/c (make-function/c (make/c contract 'contract)) (lambda () expr))))])) + +(provide (for-syntax contract/out/test)) + +(define-syntax contract/out/test + (syntax-rules () + [(contract/out/test name contract) (%require-ident-spec name (bind/c contract name 'name))])) + +;;;;;;;;;;;;;;;;;;;;;;;;;; Types ;;;;;;;;;;;;;;;;;;;;;; + +(provide contract? + listof + hashof + non-empty-listof + /c + <=/c + >=/c + any/c + and/c + or/c) + +(define (loop pred lst) + (cond + [(null? lst) #t] + [(pred (car lst)) (loop pred (cdr lst))] + [else #f])) + +;; Contract combinators +(define (listof pred) + (make/c (lambda (lst) + (cond + [(null? lst) #t] + [(list? lst) (loop pred lst)] + [else #f])) + (list 'listof (contract-or-procedure-name pred)))) + +(define (hashof key-pred value-pred) + (make/c + (lambda (hashmap) + ;; For hashof - we want to assert that both all of the keys and all of the values abide by + ;; a specific predicate + (and ((listof key-pred) (hash-keys->list hashmap)) + ((listof value-pred) (hash-values->list hashmap)))) + (list 'hashof (contract-or-procedure-name key-pred) (contract-or-procedure-name value-pred)))) + +(define (contract-or-procedure-name x) + (cond + [(FlatContract? x) (FlatContract-name x)] + [(FunctionContract? x) (string->symbol (contract->string x))] + [else + (let ([lookup (function-name x)]) (if (string? lookup) (string->symbol lookup) '#))])) + +;; Like listof, however requires that the list is non empty as well +(define (non-empty-listof pred) + (make/c (lambda (lst) + (cond + [(null? lst) + (displayln "getting here?") + #f] + [(list? lst) (loop pred lst)] + [else #f])) + (list 'non-empty-listof (contract-or-procedure-name pred)))) + +;; Contracts for < +(define ( +(define (>/c n) + (make/c (fn (x) (> x n)) (list '>/c n))) + +;; Contracts for <= +(define (<=/c n) + (make/c (fn (x) (<= x n)) (list '<=/c n))) + +;; Contracts for >= +(define (>=/c n) + (make/c (fn (x) (>= x n)) (list '>=/c n))) + +;; Satisfies any single value +(define (any/c x) + (make/c (fn (x) #t) 'any/c)) + +;; produces a function compatible with contract definitions +(define (and/c x y) + (make/c (lambda (z) (and (x z) (y z))) (list 'and/c x y))) + +;; produces a function compatible with contract definitions +(define (or/c x y) + (make/c (lambda (z) (or (x z) (y z))) (list 'or/c x y))) + +(define combinators (hashset listof non-empty-listof /c <=/c >=/c any/c and/c or/c)) + +(define (contract? predicate-or-contract) + (cond + [(function? predicate-or-contract) + (or (equal? (arity? predicate-or-contract) 1) + (hashset-contains? combinators predicate-or-contract))] + [else + => + #f])) + +;; TODO: Come back to this - I think I need to be very specific about the then-contract and else-contract +;; and how they get applied +; (define (if/c predicate then-contract else-contract) +; (make/c + +; (lambda (x) (if (predicate x) +; (then-contract predicate) +; (else-contract predicate))) +; (list 'if/c then-contract else-contract))) + +; (define (type/c type contract) +; (and/c + +; ) + +; (define (int/c )) diff --git a/crates/steel-core/src/scheme/modules/iterators.scm b/crates/steel-core/src/scheme/modules/iterators.scm new file mode 100644 index 000000000..c7ce2fa30 --- /dev/null +++ b/crates/steel-core/src/scheme/modules/iterators.scm @@ -0,0 +1,130 @@ +(require-builtin steel/base) + +(provide StreamIterator + IntoIterator + ITERATOR-FINISHED + iter-next + into-iter + iter-for-each + stream-iter-for-each + into-stream-iter + ;; For defining generators out of functions directly + (for-syntax make-generator!) + (for-syntax define/generator)) + +(struct StreamIterator + (iter-instance stream-empty-function stream-first-function stream-next-function)) + +(define (stream-iter-for-each iter func) + + (define obj-stream-empty-function (StreamIterator-stream-empty-function iter)) + (define obj-stream-first-function (StreamIterator-stream-first-function iter)) + (define obj-stream-next-function (StreamIterator-stream-next-function iter)) + + (let loop ([obj (StreamIterator-iter-instance iter)]) + (if (obj-stream-empty-function obj) + void + (begin + (func (obj-stream-first-function obj)) + (loop (obj-stream-next-function obj)))))) + +(define (list-stream-iterator l) + (StreamIterator l empty? car cdr)) + +(define (into-stream-iter obj) + (cond + [(list? obj) (list-stream-iterator obj)] + [(#%private-struct? obj) ((#%struct-property-ref obj '#:prop:into-stream) obj)] + + [else (error "into-stream implementation not found for object" obj)])) + +(struct IntoIterator (iter-object next-function) #:prop:procedure 1) + +;; Use the builtin "iterator finished" symbol +(define ITERATOR-FINISHED (load-from-module! %-builtin-module-steel/meta '#%iterator-finished)) + +(define (iter-finished? value) + (eq? value ITERATOR-FINISHED)) + +(define (iter-next into-iterator) + (into-iterator (IntoIterator-iter-object into-iterator))) + +;; Generically get the iterator +(define (into-iter obj) + ;; Check if this is a builtin type - if so, delegate to the underlying iterator + (define maybe-builtin-iterator (value->iterator obj)) + + (if maybe-builtin-iterator + (IntoIterator maybe-builtin-iterator iter-next!) + ((#%struct-property-ref obj '#:prop:into-iter) obj))) + +;; Call value for each thing +(define (iter-for-each iter func) + + (define next-value (iter-next iter)) + + (if (iter-finished? next-value) + void + (begin + (func next-value) + (iter-for-each iter func)))) + +(define UNEVALUATED 'unevaluated) + +(define-syntax make-generator! + (syntax-rules (yield) + + [(make-generator! (args ...) body ...) + (lambda (args ...) + + (let* ([iterator-object UNEVALUATED] + [temp (#%box (lambda () (make-generator! "INTERNAL" iterator-object body ...)))]) + + (set! iterator-object temp) + + ;; Produce iterator object - the iterator-object itself is not particularly + ;; meaningful. + (IntoIterator iterator-object + (lambda (generator-func) ;; Pass the function down + + ((#%unbox generator-func)) ;; Call it + ))))] + + [(make-generator! (args ...) body) + (lambda (args ...) + + ;; Unevaluated + (define iterator-object (#%box (lambda () (make-generator! "INTERNAL" iterator-object body)))) + + ;; Produce iterator object - the iterator-object itself is not particularly + ;; meaningful. + (IntoIterator iterator-object + (lambda (generator-func) ;; Pass the function down + + ((#%unbox generator-func)) ;; Call it + )))] + + [(make-generator! "INTERNAL" generator-id (yield x)) + (let ([result x]) + (#%set-box! generator-id (lambda () ITERATOR-FINISHED)) + result)] + + [(make-generator! "INTERNAL" generator-id (yield x) body ...) + + ;; Freeze the result, set the next function to be the rest of the body + (let ([result x]) + (#%set-box! generator-id (lambda () (make-generator! "INTERNAL" generator-id body ...))) + result)] + + [(make-generator! "INTERNAL" generator-id x xs ...) + + (begin + x + (make-generator! "INTERNAL" generator-id xs ...))] + + [(make-generator! "INTERNAL" generator-id x) x])) + +(define-syntax define/generator + (syntax-rules () + [(define/generator (name args ...) body ...) + (define name (make-generator! (args ...) body ...))])) diff --git a/crates/steel-core/src/scheme/modules/mvector.scm b/crates/steel-core/src/scheme/modules/mvector.scm new file mode 100644 index 000000000..5891ff90c --- /dev/null +++ b/crates/steel-core/src/scheme/modules/mvector.scm @@ -0,0 +1,115 @@ +(require-builtin steel/base) +(require-builtin #%private/steel/mvector as private.) +(require "steel/iterators") + +;; Clean this up +;; Make the built in API just use immutable-vector +(provide vector? + immutable-vector? + mutable-vector? + make-vector + vector + mutable-vector->list) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(struct MutableVector (inner) + #:mutable + #:prop:into-iter + (lambda (object) (IntoIterator (MutableVectorIterator object 0) MutableVectorIterator-next)) + #:printer (lambda (this printer-function) + (printer-function "'#(") + (cond + [(mutable-vector-empty? this) void] + [else + (printer-function (mutable-vector-ref this 0)) + (mutable-vector-for-each this + (lambda (elem) + (printer-function " ") + (printer-function elem)) + 1) + (printer-function ")")]))) + +;;@doc +;; Check if the value is an immutable vector +(define immutable-vector? (load-from-module! %-builtin-module-steel/identity 'vector?)) + +;;@doc +;; Check whether the value is a mutable vector +(define mutable-vector? MutableVector?) + +;;@doc +;; Checks whether the value is a vector (mutable or immutable) +(define vector? (lambda (x) (or (immutable-vector? x) (MutableVector? x)))) + +;;@doc +;; Create a vector of length k, optionally initialized with each +;; slot filled with value v. +(define make-vector + (case-lambda + [(k) + (when (< k 0) + (error "make-vector requires a positive integer, found " k)) + + (list->mutable-vector (map (lambda (_) void) (range 0 k)))] + [(k v) + (when (< k 0) + (error "make-vector requires a positive integer, found " k)) + + (list->mutable-vector (map (lambda (_) v) (range 0 k)))])) + +(define (make-mutable-vector) + (MutableVector (private.make-mutable-vector))) + +(define (mutable-vector-ref vector index) + (private.mutable-vector-ref (MutableVector-inner vector) index)) + +(define (mutable-vector-set! vector index value) + (private.mutable-vector-set! (MutableVector-inner vector) index value)) + +(define (mutable-vector-push! vector value) + (private.mutable-vector-push! (MutableVector-inner vector) value)) + +(define (mutable-vector->list vector) + (private.mutable-vector->list (MutableVector-inner vector))) + +(define (mutable-vector-empty? vector) + (private.mutable-vector-empty? (MutableVector-inner vector))) + +(define (mutable-vector-len vector) + (private.mutable-vector-len (MutableVector-inner vector))) + +(define (list->mutable-vector list) + (MutableVector (private.mutable-vector-from-list list))) + +(define (mut-vector . args) + (MutableVector (private.mutable-vector-from-list args))) + +(define vector mut-vector) + +(struct MutableVectorIterator (vec idx) #:mutable) + +(define (MutableVectorIterator-next iter) + + (define offset (MutableVectorIterator-idx iter)) + (define vec (MutableVectorIterator-vec iter)) + + (cond + [(mutable-vector-empty? vec) ITERATOR-FINISHED] + [(>= offset (mutable-vector-len vec)) ITERATOR-FINISHED] + [else + (let ([return-value (mutable-vector-ref vec offset)]) + (set-MutableVectorIterator-idx! iter (+ offset 1)) + return-value)])) + +(define (mutable-vector-for-each vec func offset) + + (let loop ([func func] [iterator (MutableVectorIterator vec offset)]) + + (let ([next (MutableVectorIterator-next iterator)]) + (if (eq? next ITERATOR-FINISHED) + void + + (begin + (func next) + (loop func iterator)))))) diff --git a/crates/steel-core/src/scheme/modules/parameters.scm b/crates/steel-core/src/scheme/modules/parameters.scm new file mode 100644 index 000000000..d4a8c44bd --- /dev/null +++ b/crates/steel-core/src/scheme/modules/parameters.scm @@ -0,0 +1,133 @@ +(provide dynamic-wind + (for-syntax parameterize) + call/cc + call-with-current-continuation + make-parameter + continuation?) + +(define winders '()) + +(define list-tail drop) + +(struct Pair (left right)) + +(define common-tail + (lambda (x y) + (let ([lx (length x)] [ly (length y)]) + (let loop ([x (if (> lx ly) (list-tail x (- lx ly)) x)] + [y (if (> ly lx) (list-tail y (- ly lx)) y)]) + + ; (displayln x y) + ; (displayln (equal? x y)) + (if (equal? x y) x (loop (cdr x) (cdr y))))))) + +(define do-wind + (lambda (new) + (let ([tail (common-tail new winders)]) + (let f ([ls winders]) + (when (not (equal? ls tail)) + (begin + ;; TODO: This is probably wrong! + ; (displayln "FIRST" ls) + (set! winders (cdr ls)) + ((Pair-right (car ls))) + (f (cdr ls))))) + (let f ([ls new]) + (when (not (equal? ls tail)) + (begin + ; (displayln "SECOND" ls) + (f (cdr ls)) + ((Pair-left (car ls))) + (set! winders ls))))))) + +(struct Continuation (func) + #:prop:procedure 0 + #:printer (lambda (obj printer) + + (simple-display "#"))) + +(define call/cc + (lambda (f) + (#%prim.call/cc (lambda (k) + (f (let ([save winders]) + (Continuation (lambda (x) + (unless (eq? save winders) + (do-wind save)) + (k x))))))))) + +(define call-with-current-continuation call/cc) + +(define (continuation? x) + (or (Continuation? x) (#%prim.continuation? x))) + +(define dynamic-wind + (lambda (in body out) + (in) + (set! winders (cons (Pair in out) winders)) + + (let ([ans* (call-with-exception-handler (lambda (err) + ;; Catch the exception on the way out + (set! winders (cdr winders)) + (out) + (raise-error err) + + void) + (lambda () (body)))]) + (set! winders (cdr winders)) + (out) + ans*))) + +;; TODO: Move these to the tests +; (let ([path '()] [c #f]) +; (let ([add (lambda (s) (set! path (cons s path)))]) +; (dynamic-wind (lambda () (add 'connect)) +; (lambda () +; (add (call/cc (lambda (c0) +; (set! c c0) +; 'talk1)))) +; (lambda () (add 'disconnect))) +; (if (< (length path) 4) (c 'talk2) (reverse path)))) + +; (let () +; (dynamic-wind (lambda () (displayln "PRE")) +; (lambda () +; (let () + +; (dynamic-wind (lambda () (displayln "PRE")) +; (lambda () (displayln "INNER")) +; (lambda () (displayln "POST"))) + +; (displayln "HELLO WORLD!"))) +; (lambda () (displayln "POST"))) + +; (displayln "HELLO WORLD!")) + +(struct Parameter (getter value) + #:mutable + #:printer (lambda (obj printer-function) (printer-function "")) + #:prop:procedure 0) + +(define (make-parameter value) + (define param (Parameter 'uninitialized value)) + + (set-Parameter-getter! param (lambda () (Parameter-value param))) + + param) + +(define-syntax parameterize + (syntax-rules () + [(parameterize () + body ...) + (begin + body ...)] + + [(parameterize ([var val] rest ...) + body ...) + + (let ([old-value (var)]) + + (dynamic-wind (lambda () (set-Parameter-value! var val)) + (lambda () + (parameterize (rest ...) + body ...)) + (lambda () (set-Parameter-value! var old-value))))])) diff --git a/crates/steel-core/src/scheme/modules/result.scm b/crates/steel-core/src/scheme/modules/result.scm index 8ce6f18d1..0fa2895fa 100644 --- a/crates/steel-core/src/scheme/modules/result.scm +++ b/crates/steel-core/src/scheme/modules/result.scm @@ -1,4 +1,12 @@ +; (steel/base) + (require-builtin "steel/core/result") + +;; This should get preloaded at the top of every require, except the built ins! +(require-builtin steel/base) +; (require "#%private/steel/contract" +; (for-syntax "#%private/steel/contract")) + ; (require "steel/contracts/contract.scm" ; (for-syntax "steel/contracts/contract.scm")) @@ -13,11 +21,15 @@ (contract/out unwrap-err (->/c Err? any/c)) (contract/out map-ok (->/c Result? (->/c any/c any/c) Result?)) (contract/out map-err (->/c Result? (->/c any/c any/c) Result?)) - unwrap-or) + unwrap-or + foo) ; (struct Ok (value) #:transparent) ; (struct Err (value) #:transparent) +(define (foo) + (vector 10 20 30)) + (define (Result? value) (or (Ok? value) (Err? value))) diff --git a/crates/steel-core/src/scheme/print.scm b/crates/steel-core/src/scheme/print.scm new file mode 100644 index 000000000..7e4335bee --- /dev/null +++ b/crates/steel-core/src/scheme/print.scm @@ -0,0 +1,193 @@ +(require-builtin steel/base) + +(provide displayln + display) + +(define (for-each func lst) + (if (null? lst) + void + (begin + (func (car lst)) + (when (null? lst) + (return! void)) + (for-each func (cdr lst))))) + +(define (display obj) + + ;; Collect cycles + (define cycle-collector (#%private-cycle-collector obj)) + + (for-each (λ (obj) + (when (int? (#%private-cycle-collector-get cycle-collector obj)) + (simple-display "#" (#%private-cycle-collector-get cycle-collector obj) "=") + (#%top-level-print obj cycle-collector) + (newline))) + (#%private-cycle-collector-values cycle-collector)) + + ;; Symbols are funny + (when (or (symbol? obj) (list? obj)) + (simple-display "'")) + + (#%top-level-print obj cycle-collector)) + +(define (displayln . objs) + + (cond + [(= (length objs) 1) + + (display (car objs)) + (newline)] + [else + + (for-each display objs) + (newline)])) + +(define (#%top-level-print obj collector) + (cond + [(symbol? obj) (simple-display (symbol->string obj))] + [(atom? obj) (simple-display obj)] + [(function? obj) (simple-display obj)] + ;; There is a cycle! + ; [(int? (#%private-cycle-collector-get collector obj)) + ; (simple-display "#" (#%private-cycle-collector-get collector obj) "#")] + [(list? obj) + (simple-display "(") + (when (not (empty? obj)) + (#%print (car obj) collector) + (for-each (λ (obj) + (simple-display " ") + (#%print obj collector)) + (cdr obj))) + (simple-display ")")] + + [(#%private-struct? obj) + + (let ([printer (#%struct-property-ref obj '#:printer)]) + + (cond + [(function? printer) (printer obj (lambda (x) (#%print x collector)))] + + [else + (simple-display "#<") + (simple-display (symbol->string (#%struct-property-ref obj '#:name))) + (simple-display ">")]))] + + [(set? obj) + (cond + [(= (hashset-length obj) 0) (simple-display "(set)")] + [else + (simple-display "(set ") + + (let ([set-as-list (hashset->list obj)]) + + (#%print (car set-as-list) collector) + (for-each (λ (obj) + (simple-display " ") + (#%print obj collector) + collector) + (cdr set-as-list)) + (simple-display ")"))])] + + [(hash? obj) + (simple-display "'#hash(") + ;; TODO: This should use the private transduce + (let ([hash-as-list-of-pairs (transduce obj (into-list))]) + + (cond + [(empty? hash-as-list-of-pairs) (simple-display ")")] + [else + + (simple-display "(") + (#%print (caar hash-as-list-of-pairs) collector) + (simple-display " . ") + (#%print (cadar hash-as-list-of-pairs) collector) + (simple-display ")") + + (for-each (λ (obj) + (simple-display " (") + (#%print (car obj) collector) + (simple-display " . ") + (#%print (list-ref obj 1) collector) + (simple-display ")")) + (cdr hash-as-list-of-pairs)) + + (simple-display ")")]))] + + [else (simple-displayln obj)])) + +(define (#%print obj collector) + (cond + [(string? obj) + (display "\"") + (simple-display obj) + (display "\"")] + [(symbol? obj) (simple-display (symbol->string obj))] + [(atom? obj) (simple-display obj)] + [(function? obj) (simple-display obj)] + ;; There is a cycle! + [(int? (#%private-cycle-collector-get collector obj)) + (simple-display "#" (#%private-cycle-collector-get collector obj) "#")] + [(list? obj) + (simple-display "(") + (when (not (empty? obj)) + (#%print (car obj) collector) + (for-each (λ (obj) + (simple-display " ") + (#%print obj collector)) + (cdr obj))) + (simple-display ")")] + + [(#%private-struct? obj) + + (let ([printer (#%struct-property-ref obj '#:printer)]) + + (cond + [(function? printer) (printer obj (lambda (x) (#%print x collector)))] + + [else + (simple-display "#<") + (simple-display (symbol->string (#%struct-property-ref obj '#:name))) + (simple-display ">")]))] + + [(set? obj) + (cond + [(= (hashset-length obj) 0) (simple-display "(set)")] + [else + (simple-display "(set ") + + (let ([set-as-list (hashset->list obj)]) + + (#%print (car set-as-list) collector) + (for-each (λ (obj) + (simple-display " ") + (#%print obj collector) + collector) + (cdr set-as-list)) + (simple-display ")"))])] + + [(hash? obj) + (simple-display "'#hash(") + ;; TODO: This should use the private transduce + (let ([hash-as-list-of-pairs (transduce obj (into-list))]) + + (cond + [(empty? hash-as-list-of-pairs) (simple-display ")")] + [else + + (simple-display "(") + (#%print (caar hash-as-list-of-pairs) collector) + (simple-display " . ") + (#%print (cadar hash-as-list-of-pairs) collector) + (simple-display ")") + + (for-each (λ (obj) + (simple-display " (") + (#%print (car obj) collector) + (simple-display " . ") + (#%print (list-ref obj 1) collector) + (simple-display ")")) + (cdr hash-as-list-of-pairs)) + + (simple-display ")")]))] + + [else (simple-displayln obj)])) diff --git a/crates/steel-core/src/scheme/stdlib.rkt b/crates/steel-core/src/scheme/stdlib.rkt deleted file mode 100644 index f1f6704b4..000000000 --- a/crates/steel-core/src/scheme/stdlib.rkt +++ /dev/null @@ -1,673 +0,0 @@ -(define-syntax steel/base - (syntax-rules () - [(steel/base) - (require-builtin steel/base)])) - - -; (define-syntax quasiquote -; (syntax-rules (unquote unquote-splicing) -; ((_ ((unquote x) . xs)) (cons x (quasiquote xs))) -; ((_ ((unquote-splicing x) . xs)) (append x (quasiquote xs))) -; ((_ (unquote x)) x) -; ((_ (x . xs)) (cons (quasiquote x) (quasiquote xs))) -; ((_ x) (quote x)))) - -(define-syntax quasiquote - (syntax-rules (unquote unquote-splicing #%unquote #%unquote-splicing #%quote) - - - ((quasiquote ((quote x) xs ...)) (cons (list 'quote (quasiquote x)) (quasiquote (xs ...)))) - - ((quasiquote (quote x)) (list 'quote (quasiquote x))) - - ((quasiquote ((unquote x) xs ...)) (cons (list 'unquote (quasiquote x)) (quasiquote (xs ...)))) - ((quasiquote (unquote x)) (list 'unquote (quasiquote x))) - - ; ((quasiquote ((#%unquote x) xs ...)) (cons x (quasiquote (xs ...)))) - - ((quasiquote ((#%unquote x) xs ...)) (cons x (quasiquote (xs ...)))) - ((quasiquote (#%unquote x)) x) - - - ((quasiquote ((#%unquote-splicing x))) (append x '())) - ((quasiquote ((#%unquote-splicing x) xs ...)) (append x (quasiquote (xs ...)))) - - ;; TODO: Do unquote-splicing as well, follow the same rules as unquote - ((quasiquote ((unquote-splicing x))) (append (list (list 'unquote-splicing (quasiquote x))) '())) - ((quasiquote ((unquote-splicing x) xs ...)) (append (list (list 'unquote-splicing (quasiquote x))) (quasiquote (xs ...)))) - ((quasiquote (x xs ...)) (cons (quasiquote x) (quasiquote (xs ...)))) - ((quasiquote x) 'x))) - - -(define-syntax #%proto-syntax-object - (syntax-rules () - [(#%proto-syntax-object x) - (#%syntax/raw 'x 'x - (#%syntax-span x))])) - -;; TODO: @Matt -;; Bootstrap this by expanding first, then expanding the resulting -;; TODO: Add syntax->span in the macro expander as a special case function. -;; That just inlines the span object '(left right ) -;; And then also calls the constructor for the -(define-syntax quasisyntax - (syntax-rules (syntax unsyntax unsyntax-splicing #%unsyntax #%unsyntax-splicing #%internal-crunch) - - - - ((quasisyntax ((syntax x) xs ...)) (cons (list 'syntax (quasisyntax x)) (quasisyntax (xs ...)))) - - ((quasisyntax (syntax x)) (list 'quote (quasisyntax x))) - - ((quasisyntax ((unsyntax x) xs ...)) (cons (list 'unsyntax (quasisyntax x)) (quasisyntax (xs ...)))) - ((quasisyntax (unsyntax x)) (list 'unsyntax (quasisyntax x))) - - ; ((quasiquote ((#%unquote x) xs ...)) (cons x (quasiquote (xs ...)))) - - ((quasisyntax ((#%unsyntax x) xs ...)) (cons x (quasisyntax (xs ...)))) - ((quasisyntax (#%unsyntax x)) x) - - - ((quasisyntax ((#%unsyntax-splicing x))) (append x '())) - ((quasisyntax ((#%unsyntax-splicing x) xs ...)) (append x (quasisyntax (xs ...)))) - - ;; TODO: Do unquote-splicing as well, follow the same rules as unquote - ((quasisyntax ((unsyntax-splicing x))) (append (list (list 'unsyntax-splicing (quasisyntax x))) '())) - ((quasisyntax ((unsyntax-splicing x) xs ...)) (append (list (list 'unsyntax-splicing (quasisyntax x))) (quasisyntax (xs ...)))) - - - ((quasisyntax #%internal-crunch ()) (list)) - ; (list - ; (#%syntax/raw - ; (quote x) - - ; (cons (quasisyntax x) (quasisyntax #%internal-crunch (xs ...))) - - ; (#%syntax-span x))) - - ((quasisyntax #%internal-crunch (x xs ...)) - ; (list - ; (#%syntax/raw - ; (quote x) - - (cons (quasisyntax x) (quasisyntax #%internal-crunch (xs ...))) - ) - - ; (#%syntax-span x))) - - ((quasisyntax (x xs ...)) - ; (list - (#%syntax/raw - (quote (x xs ...)) - - (cons (quasisyntax x) (quasisyntax #%internal-crunch (xs ...))) - - (#%syntax-span (x xs ...)))) - ; ) - - - ; ((quasisyntax x) 'x))) - - ; ((quasisyntax (quote ())) '()) - ((quasisyntax x) - (if (empty? 'x) - (list) - (#%syntax/raw 'x 'x (#%syntax-span x))) - - - - - ))) - - -(define-syntax or - (syntax-rules () - [(or) #f] - [(or x) x] - [(or x y) (let ([z x]) - (if z z y))] - [(or x y ...) (or x (or y ...))])) - -(define-syntax and - (syntax-rules () - [(and) #t] - [(and x) x] - [(and x y) (if x y #f)] - [(and x y ...) (and x (and y ...))])) - -(define-syntax when - (syntax-rules () - [(when a b ...) - (if a (begin b ...) void)])) - -(define-syntax unless - (syntax-rules () - [(unless a b ...) - (if a void (begin b ...))])) - -(define-syntax cond - (syntax-rules (else =>) - [(cond [else => e1 ...]) - (begin e1 ...)] - [(cond [else e1 ...]) - (begin e1 ...)] - [(cond [e1 e2 ...]) - (when e1 e2 ...)] - [(cond [e1 => e2 ...] c1 ...) - (if e1 - (begin e2 ...) - (cond c1 ...))] - [(cond [e1 e2 ...] c1 ...) - (if e1 - (begin e2 ...) - (cond c1 ...))])) - -(define-syntax case - (syntax-rules (else) - [(case (key ...) - clauses ...) - (let ((atom-key (key ...))) - (case atom-key clauses ...))] - [(case key - (else result1 result2 ...)) - (begin result1 result2 ...)] - [(case key - ((atoms ...) result1 result2 ...)) - (when (member key '(atoms ...)) - (begin result1 result2 ...))] - -; [(case key -; ((atoms ...) result1 ...) -; clause clauses ...) -; (if (member key '(atoms ...)) -; (begin result1 ...) -; (case key clause clauses ...))] - - [(case key - ((atoms ...) result1 result2 ...) - clause clauses ...) - (if (member key '(atoms ...)) - (begin result1 result2 ...) - (case key clause clauses ...))])) - -(define-syntax while - (syntax-rules (do) - [(while cond do body ...) - (begin - (define (loop) - (when cond - body ... - (loop))) - (loop))] - [(while cond body ...) - (begin (define (loop) - (when cond body ... (loop))) - (loop))])) - -;; TODO add the single argument case -(define-syntax f> - (syntax-rules () - [(f> fun args* ...) - (lambda (x) (fun x args* ...))] - [(f> fun) fun])) - -(define-syntax -> - (syntax-rules () - [(-> a) a] - [(-> a (b c ...)) ((f> b c ...) a)] - [(-> a (b)) ((f> b) a)] - [(-> a b c ...) (-> (-> a b) c ...)])) - -(define-syntax ~> - (syntax-rules () - [(~> a) a] - [(~> a (b c ...)) ((f> b c ...) a)] - [(~> a (b)) ((f> b) a)] - [(~> a b c ...) (~> (~> a b) c ...)])) - -(define-syntax l> - (syntax-rules () - [(l> fun args* ...) - (lambda (x) (fun args* ... x))] - [(l> fun) fun])) - -(define-syntax ~>> - (syntax-rules () - [(~>> a) a] - [(~>> a (b c ...)) ((l> b c ...) a)] - [(~>> a (b)) ((l> b) a)] - [(~>> a b c ...) (~>> (~>> a b) c ...)])) - -(define-syntax ->> - (syntax-rules () - [(->> a) a] - [(->> a (b c ...)) ((l> b c ...) a)] - [(->> a (b)) ((l> b) a)] - [(->> a b c ...) (->> (->> a b) c ...)])) - -(define-syntax swap - (syntax-rules () - [(swap a b) - (let ([tmp b]) - (begin - (set! b a) - (set! a tmp)))])) - -(define-syntax let* - (syntax-rules () - ((let* () body ...) ; base case - ((lambda () body ...))) - ((let* ((var val) rest ...) body ...) ; binding case - ((lambda (var) (let* (rest ...) body ...)) val)))) - -(define-syntax letrec*-helper - (syntax-rules () - ((letrec*-helper () body ...) - (begin body ...)) - ((letrec*-helper ((var val) rest ...) body ...) - (begin - (define var val) - (letrec*-helper (rest ...) body ...))))) - -(define-syntax letrec* - (syntax-rules () - ((letrec* bindings body ...) - ((lambda () - (letrec*-helper bindings body ...)))))) - -(define-syntax ->/c - (syntax-rules () - [(->/c r) - (make-function/c (make/c r 'r))] - [(->/c a b) - (make-function/c (make/c a 'a) (make/c b 'b))] - [(->/c a b c) - (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c))] - [(->/c a b c d) - (make-function/c (make/c a 'a) (make/c b 'b) - (make/c c 'c) (make/c d 'd))] - [(->/c a b c d e) - (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c) - (make/c d 'd) (make/c e 'e))] - [(->/c a b c d e f) - (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c) - (make/c d 'd) (make/c e 'e) (make/c f 'f))] - [(->/c a b c d e f g) - (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c) - (make/c d 'd) (make/c e 'e) (make/c f 'f) - (make/c g 'g))] - [(->/c a b c d e f g h) - (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c) - (make/c d 'd) (make/c e 'e) (make/c f 'f) - (make/c g 'g) (make/c h 'h))] - [(->/c a b c d e f g h i) - (make-function/c (make/c a 'a) (make/c b 'b) (make/c c 'c) - (make/c d 'd) (make/c e 'e) (make/c f 'f) - (make/c g 'g) (make/c h 'h) (make/c i 'i))])) - -;; Macro for basic usage of contracts -(define-syntax define/contract - (syntax-rules () - [(define/contract (name args ...) - contract - body ...) - (begin - (define name (lambda (args ...) body ...)) - (set! name (bind/c contract name 'name))) - ; (define name (bind/c contract (lambda (args ...) body ...) 'name)) - - ] - [(define/contract name contract expr) - (define name ((bind/c - (make-function/c (make/c contract 'contract)) - (lambda () expr))))])) - -(define-syntax module - (syntax-rules (provide gen-defines contract/out) - [(module name (provide ids ...) funcs ...) - (begin - (define (datum->syntax name) - ((lambda () funcs ... - (module provide ids ...)))) - (module gen-defines name ids ...))] - - ;; in the contract case, ignore the contract in the hash - [(module provide (contract/out name contract)) (%proto-hash% 'name name)] - ;; Normal case - [(module provide name) (%proto-hash% 'name name)] - - ;; in the contract case, ignore the contract in the hash - [(module provide (contract/out name contract) rest ...) - (%proto-hash-insert% (module provide rest ...) 'name name)] - - ;; Normal case - [(module provide name rest ...) - (%proto-hash-insert% (module provide rest ...) 'name name)] - - ;; Module contract provides - [(module gen-defines mod (contract/out name contract)) - (define (datum->syntax name) (bind/c contract (%proto-hash-get% mod 'name)))] - [(module gen-defines mod (contract/out name contract) rest ...) - (begin (define (datum->syntax name) (bind/c contract (%proto-hash-get% mod 'name))) - (module gen-defines mod rest ...))] - - ;; Normal provides - [(module gen-defines mod name) (define (datum->syntax name) (%proto-hash-get% mod 'name))] - [(module gen-defines mod name rest ...) - (begin (define (datum->syntax name) (%proto-hash-get% mod 'name)) - (module gen-defines mod rest ...))])) - -;; TODO: Replace some of these with just list ref to abuse the underlying implementation -(define caar (lambda (pair) (car (car pair)))) -(define cadr (lambda (pair) (car (cdr pair)))) -(define cdar (lambda (pair) (cdr (car pair)))) -(define cddr (lambda (pair) (cdr (cdr pair)))) -(define caaar (lambda (pair) (car (car (car pair))))) -(define caadr (lambda (pair) (car (car (cdr pair))))) -(define cadar (lambda (pair) (car (cdr (car pair))))) -(define caddr (lambda (pair) (car (cdr (cdr pair))))) -(define cdaar (lambda (pair) (cdr (car (car pair))))) -(define cdadr (lambda (pair) (cdr (car (cdr pair))))) -(define cddar (lambda (pair) (cdr (cdr (car pair))))) -(define cdddr (lambda (pair) (cdr (cdr (cdr pair))))) -(define caaaar (lambda (pair) (car (car (car (car pair)))))) -(define caaadr (lambda (pair) (car (car (car (cdr pair)))))) -(define caadar (lambda (pair) (car (car (cdr (car pair)))))) -(define caaddr (lambda (pair) (car (car (cdr (cdr pair)))))) -(define cadaar (lambda (pair) (car (cdr (car (car pair)))))) -(define cadadr (lambda (pair) (car (cdr (car (cdr pair)))))) -(define caddar (lambda (pair) (car (cdr (cdr (car pair)))))) -(define cadddr (lambda (pair) (car (cdr (cdr (cdr pair)))))) -(define cdaaar (lambda (pair) (cdr (car (car (car pair)))))) -(define cdaadr (lambda (pair) (cdr (car (car (cdr pair)))))) -(define cdadar (lambda (pair) (cdr (car (cdr (car pair)))))) -(define cdaddr (lambda (pair) (cdr (car (cdr (cdr pair)))))) -(define cddaar (lambda (pair) (cdr (cdr (car (car pair)))))) -(define cddadr (lambda (pair) (cdr (cdr (car (cdr pair)))))) -(define cdddar (lambda (pair) (cdr (cdr (cdr (car pair)))))) -(define cddddr (lambda (pair) (cdr (cdr (cdr (cdr pair)))))) -(define id (lambda (obj) obj)) -(define flip (lambda (func) (lambda (arg1 arg2) (func arg2 arg1)))) -(define curry (lambda (func arg1) (lambda (arg) (func arg1 arg)))) -(define curry2 (lambda (func arg1) (lambda (arg2 arg3) (func arg1 arg2 arg3)))) -; (define compose (lambda (f g) (lambda (arg) (f (g arg))))) - - -(define (not a) - (if a - #f - #t)) - -(define (foldl func accum lst) - (if (null? lst) - accum - (foldl func - (func (car lst) accum) ; here's the change - (cdr lst)))) - - -; (define (map-many func lst . lsts) - -; (define (crunch composer remaining-lists) -; (if (null? lsts) composer (crunch (compose composer (zipping (car remaining-lists))) (cdr remaining-lists)))) - - -; (if (null? lsts) -; (map func lst) -; ;; Handle the case for many lists -; (let ([composed-transducer (crunch (compose) lsts)]) -; (transduce lst composed-transducer (mapping (lambda (x) (apply func x))) (into-list))))) - - -(define (map func lst . lsts) - - (cond [(null? lst) '()] - [(null? lsts) (transduce lst (mapping func) (into-list))] - [else => - (define (crunch composer remaining-lists) - (if (null? remaining-lists) composer (crunch (compose composer (zipping (car remaining-lists))) (cdr remaining-lists)))) - (if (null? lsts) - (map func lst) - ;; Handle the case for many lists - (let ([composed-transducer (crunch (compose) lsts)]) - (transduce lst composed-transducer (mapping (lambda (x) (apply func x))) (into-list))))])) - - - ; (if (null? lst) - ; '() - ; (transduce lst (mapping func) (into-list)))) - - -(define foldr (lambda (func accum lst) - (if (null? lst) - accum - (func (car lst) (foldr func accum (cdr lst)))))) - - - -(define unfold (lambda (func init pred) - (if (pred init) - (cons init '()) - (cons init (unfold func (func init) pred))))) - -(define fold (lambda (f a l) (foldl f a l))) -(define reduce (lambda (f a l) (fold f a l))) -(define max (lambda (x num-list) (fold (lambda (y z) (if (> y z) y z)) x (cons 0 num-list)))) -(define min (lambda (x num-list) (fold (lambda (y z) (if (< y z) y z)) x (cons 536870911 num-list)))) - -(define empty? null?) - -(define mem-helper (lambda (pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))) -;; (define memq (lambda (obj lst) (fold (mem-helper (curry eq? obj) id) #f lst))) -; (define memv (lambda (obj lst) (fold (mem-helper (curry eqv? obj) id) #f lst))) -; (define member (lambda (obj lst) (fold (mem-helper (curry equal? obj) id) #f lst))) - -(define member - (lambda (x los) - (cond - ((null? los) #f) - ((equal? x (car los)) los) - (else (member x (cdr los)))))) - - -(define (contains? pred? lst) - ; (displayln lst) - (cond [(empty? lst) #f] - [(pred? (car lst)) #t] - [else (contains? pred? (cdr lst))])) - -;; TODO come back to this -; (define assq (lambda (obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))) - -;; (define assv (lambda (obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))) -; (define assoc (lambda (obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))) - -; (define assoc ) - -(define (assoc thing alist) - (if (null? alist) - #f - (if (equal? (car (car alist)) thing) - (car alist) - (assoc thing (cdr alist))))) - - -(define (filter pred lst) - (if (empty? lst) - '() - (transduce lst (filtering pred) (into-list)))) - -; (define (fact n) -; (define factorial-tail (lambda (n acc) -; (if (= n 0) -; acc -; (factorial-tail (- n 1) (* acc n ))))) -; (factorial-tail n 1)) - -(define even-rec? (lambda (x) (if (= x 0) #t (odd-rec? (- x 1))))) -(define odd-rec? (lambda (x) (if (= x 0) #f (even-rec? (- x 1))))) - -(define sum (lambda (x) (reduce + 0 x))) -;; (define head car) -;; (define tail cdr) -(define (add1 n) (+ 1 n)) -(define (sub1 n) (- n 1)) -(define (zero? n) (= n 0)) - -;; currently broken, doesn't work properly -; (defn (take lst n) -; (defn (loop x l acc) -; (if (= x 0) -; acc -; (loop (- x 1) (cdr l) (cons (car l) acc)))) -; (loop n lst (list))) - -(define (drop lst n) - (define (loop x l) - (if (zero? x) - l - (loop (sub1 x) (cdr l)))) - (loop n lst)) - -(define (slice l offset n) - (take (drop l offset) n)) - -(define (flatten lst) - (cond ((null? lst) '()) - ((list? lst) - (append (flatten (car lst)) (flatten (cdr lst)))) - (else (list lst)))) - -;;; Macros go here: - - -(define-syntax reset - (syntax-rules () - ((reset ?e) (*reset (lambda () ?e))))) - -(define-syntax shift - (syntax-rules () - ((shift ?k ?e) (*shift (lambda (?k) ?e))))) - -;; TODO: This should be boxed at some point, we don't want it -;; to be globally accessible directly (I think) -(define (*meta-continuation* v) - (error "You forgot the top-level reset...")) - -(define (*abort thunk) - (let ((v (thunk))) - (*meta-continuation* v))) - -(define (*reset thunk) - (let ((mc *meta-continuation*)) - (call/cc (lambda (k) - (begin - (set! *meta-continuation* - (lambda (v) - (set! *meta-continuation* mc) - (k v))) - (*abort thunk)))))) - -(define (*shift f) - (call/cc - (lambda (k) - (*abort (lambda () - (f (lambda (v) - (reset (k v))))))))) - -(define-syntax with-handler - (syntax-rules () - [(with-handler handler expr) - (reset (call-with-exception-handler (lambda (err) (handler err) (shift k (k void))) - (lambda () expr)))] - [(with-handler handler expr ...) - (reset (call-with-exception-handler (lambda (err) (handler err) (shift k (k void))) - (lambda () expr ...)))])) - - -(define-syntax case-lambda - (syntax-rules () - ((case-lambda) - (lambda args - (error "CASE-LAMBDA without any clauses."))) - ((case-lambda - (?a1 ?e1 ...) - ?clause1 ...) - (lambda args - (%plain-let ((l (length args))) - (case-lambda "CLAUSE" args l - (?a1 ?e1 ...) - ?clause1 ...)))) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 ...) ?e1 ...)) - (if (= ?l (length '(?a1 ...))) - (apply (lambda (?a1 ...) ?e1 ...) ?args) - (error! "Arity mismatch") - - )) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 ...) ?e1 ...) - ?clause1 ...) - (if (= ?l (length '(?a1 ...))) - (apply (lambda (?a1 ...) ?e1 ...) ?args) - (case-lambda "CLAUSE" ?args ?l - ?clause1 ...))) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 . ?ar) ?e1 ...) - ?clause1 ...) - (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...) - ?clause1 ...)) - ((case-lambda "CLAUSE" ?args ?l - (?a1 ?e1 ...) - ) - (%plain-let ((?a1 ?args)) - ?e1 ...)) - ((case-lambda "CLAUSE" ?args ?l) - (error "Wrong number of arguments to CASE-LAMBDA.")) - ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...) - ?clause1 ...) - (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...) - ?clause1 ...)) - ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...) - ?clause1 ...) - (if (>= ?l ?k) - (apply (lambda ?al ?e1 ...) ?args) - (case-lambda "CLAUSE" ?args ?l - ?clause1 ...))))) - - -(define-syntax help - (syntax-rules () - [(help) - (displayln "help expects an identifier to lookup documentation for")] - [(help ident) - (%doc? %-builtin-module-steel/base (quote ident))] - [(help module ident) - (%doc? (datum->syntax %-builtin-module- module) (quote ident))])) - -(define-syntax dbg! - (syntax-rules () - [(dbg! expr) - (let ((result expr)) - (displayln (quote expr) " = " result) - result)])) - -(define-syntax contract/out - (syntax-rules () - [(contract/out name contract) - (%require-ident-spec name (bind/c contract name 'name))])) - - -(define (force promise) (promise)) - -;; syntax -(define-syntax delay - (syntax-rules () - ((delay expr) - (lambda () - expr)))) - - -(define values list) -(define (call-with-values producer consumer) - (apply consumer (producer))) diff --git a/crates/steel-core/src/scheme/stdlib.scm b/crates/steel-core/src/scheme/stdlib.scm new file mode 100644 index 000000000..0bb66070f --- /dev/null +++ b/crates/steel-core/src/scheme/stdlib.scm @@ -0,0 +1,715 @@ +(define-syntax steel/base + (syntax-rules () + [(steel/base) (require-builtin steel/base)])) + +; (define-syntax quasiquote +; (syntax-rules (unquote unquote-splicing) +; ((_ ((unquote x) . xs)) (cons x (quasiquote xs))) +; ((_ ((unquote-splicing x) . xs)) (append x (quasiquote xs))) +; ((_ (unquote x)) x) +; ((_ (x . xs)) (cons (quasiquote x) (quasiquote xs))) +; ((_ x) (quote x)))) + +(define-syntax quasiquote + (syntax-rules (unquote unquote-splicing #%unquote #%unquote-splicing #%quote) + + [(quasiquote ((quote x) xs ...)) (cons (list 'quote (quasiquote x)) (quasiquote (xs ...)))] + + [(quasiquote (quote x)) (list 'quote (quasiquote x))] + + [(quasiquote ((unquote x) xs ...)) (cons (list 'unquote (quasiquote x)) (quasiquote (xs ...)))] + [(quasiquote (unquote x)) (list 'unquote (quasiquote x))] + + ; ((quasiquote ((#%unquote x) xs ...)) (cons x (quasiquote (xs ...)))) + + [(quasiquote ((#%unquote x) xs ...)) (cons x (quasiquote (xs ...)))] + [(quasiquote (#%unquote x)) x] + + [(quasiquote ((#%unquote-splicing x))) (append x '())] + [(quasiquote ((#%unquote-splicing x) xs ...)) (append x (quasiquote (xs ...)))] + + ;; TODO: Do unquote-splicing as well, follow the same rules as unquote + [(quasiquote ((unquote-splicing x))) (append (list (list 'unquote-splicing (quasiquote x))) '())] + [(quasiquote ((unquote-splicing x) xs ...)) + (append (list (list 'unquote-splicing (quasiquote x))) (quasiquote (xs ...)))] + [(quasiquote (x xs ...)) (cons (quasiquote x) (quasiquote (xs ...)))] + [(quasiquote x) 'x])) + +(define-syntax #%proto-syntax-object + (syntax-rules () + [(#%proto-syntax-object x) (#%syntax/raw 'x 'x (#%syntax-span x))])) + +;; TODO: @Matt +;; Bootstrap this by expanding first, then expanding the resulting +;; TODO: Add syntax->span in the macro expander as a special case function. +;; That just inlines the span object '(left right ) +;; And then also calls the constructor for the +(define-syntax quasisyntax + (syntax-rules (syntax unsyntax unsyntax-splicing #%unsyntax #%unsyntax-splicing #%internal-crunch) + + [(quasisyntax ((syntax x) xs ...)) (cons (list 'syntax (quasisyntax x)) (quasisyntax (xs ...)))] + + [(quasisyntax (syntax x)) (list 'quote (quasisyntax x))] + + [(quasisyntax ((unsyntax x) xs ...)) + (cons (list 'unsyntax (quasisyntax x)) (quasisyntax (xs ...)))] + [(quasisyntax (unsyntax x)) (list 'unsyntax (quasisyntax x))] + + ; ((quasiquote ((#%unquote x) xs ...)) (cons x (quasiquote (xs ...)))) + + [(quasisyntax ((#%unsyntax x) xs ...)) (cons x (quasisyntax (xs ...)))] + [(quasisyntax (#%unsyntax x)) x] + + [(quasisyntax ((#%unsyntax-splicing x))) (append x '())] + [(quasisyntax ((#%unsyntax-splicing x) xs ...)) (append x (quasisyntax (xs ...)))] + + ;; TODO: Do unquote-splicing as well, follow the same rules as unquote + [(quasisyntax ((unsyntax-splicing x))) + (append (list (list 'unsyntax-splicing (quasisyntax x))) '())] + [(quasisyntax ((unsyntax-splicing x) xs ...)) + (append (list (list 'unsyntax-splicing (quasisyntax x))) (quasisyntax (xs ...)))] + + [(quasisyntax #%internal-crunch ()) (list)] + ; (list + ; (#%syntax/raw + ; (quote x) + + ; (cons (quasisyntax x) (quasisyntax #%internal-crunch (xs ...))) + + ; (#%syntax-span x))) + + [(quasisyntax #%internal-crunch (x xs ...)) + ; (list + ; (#%syntax/raw + ; (quote x) + + (cons (quasisyntax x) (quasisyntax #%internal-crunch (xs ...)))] + + ; (#%syntax-span x))) + + [(quasisyntax (x xs ...)) + ; (list + (#%syntax/raw (quote (x xs ...)) + (cons (quasisyntax x) (quasisyntax #%internal-crunch (xs ...))) + (#%syntax-span (x xs ...)))] + ; ) + + ; ((quasisyntax x) 'x))) + + ; ((quasisyntax (quote ())) '()) + [(quasisyntax x) (if (empty? 'x) (list) (#%syntax/raw 'x 'x (#%syntax-span x)))])) + +(define-syntax or + (syntax-rules () + [(or) #f] + [(or x) x] + [(or x y) (let ([z x]) (if z z y))] + [(or x y ...) (or x (or y ...))])) + +(define-syntax and + (syntax-rules () + [(and) #t] + [(and x) x] + [(and x y) (if x y #f)] + [(and x y ...) (and x (and y ...))])) + +(define-syntax when + (syntax-rules () + [(when a + b ...) + (if a + (begin + b ...) + void)])) + +(define-syntax unless + (syntax-rules () + [(unless a + b ...) + (if a + void + (begin + b ...))])) + +(define-syntax cond + (syntax-rules (else =>) + [(cond + [else + => + e1 ...]) + (begin + e1 ...)] + [(cond + [else + e1 ...]) + (begin + e1 ...)] + [(cond + [e1 + e2 ...]) + (when e1 + e2 ...)] + [(cond + [e1 + => + e2 ...] + c1 ...) + (if e1 + (begin + e2 ...) + (cond + c1 ...))] + [(cond + [e1 + e2 ...] + c1 ...) + (if e1 + (begin + e2 ...) + (cond + c1 ...))])) + +(define-syntax case + (syntax-rules (else) + [(case (key ...) + clauses ...) + (let ([atom-key (key ...)]) + (case atom-key + clauses ...))] + [(case key + [else + result1 + result2 ...]) + (begin + result1 + result2 ...)] + [(case key + [(atoms ...) + result1 + result2 ...]) + (when (member key '(atoms ...)) + (begin + result1 + result2 ...))] + + ; [(case key + ; ((atoms ...) result1 ...) + ; clause clauses ...) + ; (if (member key '(atoms ...)) + ; (begin result1 ...) + ; (case key clause clauses ...))] + + [(case key + [(atoms ...) + result1 + result2 ...] + clause + clauses ...) + (if (member key '(atoms ...)) + (begin + result1 + result2 ...) + (case key + clause + clauses ...))])) + +(define-syntax while + (syntax-rules (do) + [(while cond do body ...) + (begin + (define (loop) + (when cond + body ... + (loop))) + (loop))] + [(while cond body ...) + (begin + (define (loop) + (when cond + body ... + (loop))) + (loop))])) + +;; TODO add the single argument case +(define-syntax f> + (syntax-rules () + [(f> fun) fun] + [(f> fun args* ...) (lambda (x) (fun x args* ...))])) + +(define-syntax -> + (syntax-rules () + [(-> a) a] + [(-> a (b c ...)) ((f> b c ...) a)] + [(-> a (b)) ((f> b) a)] + [(-> a b c ...) (-> (-> a b) c ...)])) + +(define-syntax ~> + (syntax-rules () + [(~> a) a] + [(~> a (b c ...)) ((f> b c ...) a)] + [(~> a (b)) ((f> b) a)] + [(~> a b) ((f> b) a)] + [(~> a b c ...) (~> (~> a b) c ...)])) + +(define-syntax l> + (syntax-rules () + [(l> fun) fun] + [(l> fun args* ...) (lambda (x) (fun args* ... x))])) + +(define-syntax ~>> + (syntax-rules () + [(~>> a) a] + [(~>> a (b c ...)) ((l> b c ...) a)] + [(~>> a (b)) ((l> b) a)] + [(~>> a b) ((l> b) a)] + [(~>> a b c ...) (~>> (~>> a b) c ...)])) + +(define-syntax ->> + (syntax-rules () + [(->> a) a] + [(->> a (b c ...)) ((l> b c ...) a)] + [(->> a (b)) ((l> b) a)] + [(->> a b c ...) (->> (->> a b) c ...)])) + +(define-syntax swap + (syntax-rules () + [(swap a b) + (let ([tmp b]) + (begin + (set! b a) + (set! a tmp)))])) + +(define-syntax let* + (syntax-rules () + [(let* () + body ...) ; base case + ((lambda () + body ...))] + [(let* ([var val] rest ...) + body ...) ; binding case + ((lambda (var) + (let* (rest ...) + body ...)) + val)])) + +(define-syntax letrec*-helper + (syntax-rules () + [(letrec*-helper () body ...) + (begin + body ...)] + [(letrec*-helper ((var val) rest ...) body ...) + (begin + (define var val) + (letrec*-helper (rest ...) body ...))])) + +(define-syntax letrec* + (syntax-rules () + [(letrec* bindings body ...) ((lambda () (letrec*-helper bindings body ...)))])) + +(define-syntax module + (syntax-rules (provide gen-defines + contract/out) + [(module name (provide ids ...) + funcs ...) + (begin + (define (datum->syntax name) + ((lambda () + funcs ... + (module provide ids + ...)))) + (module gen-defines name + ids ...))] + + ;; in the contract case, ignore the contract in the hash + [(module provide (contract/out name contract) + ) + (%proto-hash% 'name name)] + ;; Normal case + [(module provide name + ) + (%proto-hash% 'name name)] + + ;; in the contract case, ignore the contract in the hash + [(module provide (contract/out name contract) + rest ...) + (%proto-hash-insert% (module provide rest + ...) + 'name + name)] + + ;; Normal case + [(module provide name + rest ...) + (%proto-hash-insert% (module provide rest + ...) + 'name + name)] + + ;; Module contract provides + [(module gen-defines mod + (contract/out name contract)) + (define (datum->syntax name) + (bind/c contract (%proto-hash-get% mod 'name)))] + [(module gen-defines mod + (contract/out name contract) + rest ...) + (begin + (define (datum->syntax name) + (bind/c contract (%proto-hash-get% mod 'name))) + (module gen-defines mod + rest ...))] + + ;; Normal provides + [(module gen-defines mod + name) + (define (datum->syntax name) + (%proto-hash-get% mod 'name))] + [(module gen-defines mod + name + rest ...) + (begin + (define (datum->syntax name) + (%proto-hash-get% mod 'name)) + (module gen-defines mod + rest ...))])) + +;; TODO: Replace some of these with just list ref to abuse the underlying implementation +(define caar (lambda (pair) (car (car pair)))) +(define cadr (lambda (pair) (car (cdr pair)))) +(define cdar (lambda (pair) (cdr (car pair)))) +(define cddr (lambda (pair) (cdr (cdr pair)))) +(define caaar (lambda (pair) (car (car (car pair))))) +(define caadr (lambda (pair) (car (car (cdr pair))))) +(define cadar (lambda (pair) (car (cdr (car pair))))) +(define caddr (lambda (pair) (car (cdr (cdr pair))))) +(define cdaar (lambda (pair) (cdr (car (car pair))))) +(define cdadr (lambda (pair) (cdr (car (cdr pair))))) +(define cddar (lambda (pair) (cdr (cdr (car pair))))) +(define cdddr (lambda (pair) (cdr (cdr (cdr pair))))) +(define caaaar (lambda (pair) (car (car (car (car pair)))))) +(define caaadr (lambda (pair) (car (car (car (cdr pair)))))) +(define caadar (lambda (pair) (car (car (cdr (car pair)))))) +(define caaddr (lambda (pair) (car (car (cdr (cdr pair)))))) +(define cadaar (lambda (pair) (car (cdr (car (car pair)))))) +(define cadadr (lambda (pair) (car (cdr (car (cdr pair)))))) +(define caddar (lambda (pair) (car (cdr (cdr (car pair)))))) +(define cadddr (lambda (pair) (car (cdr (cdr (cdr pair)))))) +(define cdaaar (lambda (pair) (cdr (car (car (car pair)))))) +(define cdaadr (lambda (pair) (cdr (car (car (cdr pair)))))) +(define cdadar (lambda (pair) (cdr (car (cdr (car pair)))))) +(define cdaddr (lambda (pair) (cdr (car (cdr (cdr pair)))))) +(define cddaar (lambda (pair) (cdr (cdr (car (car pair)))))) +(define cddadr (lambda (pair) (cdr (cdr (car (cdr pair)))))) +(define cdddar (lambda (pair) (cdr (cdr (cdr (car pair)))))) +(define cddddr (lambda (pair) (cdr (cdr (cdr (cdr pair)))))) +(define id (lambda (obj) obj)) +(define flip (lambda (func) (lambda (arg1 arg2) (func arg2 arg1)))) +(define curry (lambda (func arg1) (lambda (arg) (func arg1 arg)))) +(define curry2 (lambda (func arg1) (lambda (arg2 arg3) (func arg1 arg2 arg3)))) +; (define compose (lambda (f g) (lambda (arg) (f (g arg))))) + +(define (not a) + (if a #f #t)) + +(define (foldl func accum lst) + (if (null? lst) + accum + (foldl func + (func (car lst) accum) ; here's the change + (cdr lst)))) + +(define (map func lst . lsts) + + (cond + [(null? lst) '()] + [(null? lsts) (transduce lst (mapping func) (into-list))] + [else + => + (define (crunch composer remaining-lists) + (if (null? remaining-lists) + composer + (crunch (compose composer (zipping (car remaining-lists))) (cdr remaining-lists)))) + (if (null? lsts) + (map func lst) + ;; Handle the case for many lists + (let ([composed-transducer (crunch (compose) lsts)]) + (transduce lst composed-transducer (mapping (lambda (x) (apply func x))) (into-list))))])) + +; (if (null? lst) +; '() +; (transduce lst (mapping func) (into-list)))) + +(define foldr + (lambda (func accum lst) (if (null? lst) accum (func (car lst) (foldr func accum (cdr lst)))))) + +(define unfold + (lambda (func init pred) + (if (pred init) (cons init '()) (cons init (unfold func (func init) pred))))) + +(define fold (lambda (f a l) (foldl f a l))) +(define reduce (lambda (f a l) (fold f a l))) +(define max (lambda (x num-list) (fold (lambda (y z) (if (> y z) y z)) x (cons 0 num-list)))) +(define min (lambda (x num-list) (fold (lambda (y z) (if (< y z) y z)) x (cons 536870911 num-list)))) + +(define empty? null?) + +(define mem-helper + (lambda (pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))) +;; (define memq (lambda (obj lst) (fold (mem-helper (curry eq? obj) id) #f lst))) +; (define memv (lambda (obj lst) (fold (mem-helper (curry eqv? obj) id) #f lst))) +; (define member (lambda (obj lst) (fold (mem-helper (curry equal? obj) id) #f lst))) + +(define member + (lambda (x los) + (cond + [(null? los) #f] + [(equal? x (car los)) los] + [else (member x (cdr los))]))) + +(define (contains? pred? lst) + ; (displayln lst) + (cond + [(empty? lst) #f] + [(pred? (car lst)) #t] + [else (contains? pred? (cdr lst))])) + +;; TODO come back to this +; (define assq (lambda (obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))) + +;; (define assv (lambda (obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))) +; (define assoc (lambda (obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))) + +; (define assoc ) + +(define (assoc thing alist) + (if (null? alist) #f (if (equal? (car (car alist)) thing) (car alist) (assoc thing (cdr alist))))) + +(define (filter pred lst) + (if (empty? lst) '() (transduce lst (filtering pred) (into-list)))) + +; (define (fact n) +; (define factorial-tail (lambda (n acc) +; (if (= n 0) +; acc +; (factorial-tail (- n 1) (* acc n ))))) +; (factorial-tail n 1)) + +(define even-rec? (lambda (x) (if (= x 0) #t (odd-rec? (- x 1))))) +(define odd-rec? (lambda (x) (if (= x 0) #f (even-rec? (- x 1))))) + +(define sum (lambda (x) (reduce + 0 x))) +;; (define head car) +;; (define tail cdr) +(define (add1 n) + (+ 1 n)) +(define (sub1 n) + (- n 1)) +(define (zero? n) + (= n 0)) + +;; currently broken, doesn't work properly +; (defn (take lst n) +; (defn (loop x l acc) +; (if (= x 0) +; acc +; (loop (- x 1) (cdr l) (cons (car l) acc)))) +; (loop n lst (list))) + +(define (drop lst n) + (define (loop x l) + (if (zero? x) l (loop (sub1 x) (cdr l)))) + (loop n lst)) + +(define (slice l offset n) + (take (drop l offset) n)) + +(define (flatten lst) + (cond + [(null? lst) '()] + [(list? lst) (append (flatten (car lst)) (flatten (cdr lst)))] + [else (list lst)])) + +;;; Macros go here: + +(define-syntax reset + (syntax-rules () + [(reset ?e) (*reset (lambda () ?e))])) + +(define-syntax shift + (syntax-rules () + [(shift ?k ?e) (*shift (lambda (?k) ?e))])) + +;; TODO: This should be boxed at some point, we don't want it +;; to be globally accessible directly (I think) +(define (*meta-continuation* v) + (error "You forgot the top-level reset...")) + +(define (*abort thunk) + (let ([v (thunk)]) (*meta-continuation* v))) + +(define (*reset thunk) + (let ([mc *meta-continuation*]) + (call/cc (lambda (k) + (begin + (set! *meta-continuation* + (lambda (v) + (set! *meta-continuation* mc) + (k v))) + (*abort thunk)))))) + +(define (*shift f) + (call/cc (lambda (k) (*abort (lambda () (f (lambda (v) (reset (k v))))))))) + +(define-syntax with-handler + (syntax-rules () + [(with-handler handler expr) + (reset (call-with-exception-handler (lambda (err) + (handler err) + (shift k (k void))) + (lambda () expr)))] + [(with-handler handler expr ...) + (reset (call-with-exception-handler (lambda (err) + (handler err) + (shift k (k void))) + (lambda () + expr ...)))])) + +(define-syntax case-lambda + (syntax-rules () + [(case-lambda) (lambda args (error "CASE-LAMBDA without any clauses."))] + [(case-lambda + [?a1 + ?e1 ...] + ?clause1 ...) + (lambda args + (%plain-let ((l (length args))) + (case-lambda + "CLAUSE" + args + l + [?a1 + ?e1 ...] + ?clause1 ...)))] + [(case-lambda + "CLAUSE" + ?args + ?l + [(?a1 ...) + ?e1 ...]) + (if (= ?l (length '(?a1 ...))) + (apply (lambda (?a1 ...) + ?e1 ...) + ?args) + (error! "Arity mismatch"))] + [(case-lambda + "CLAUSE" + ?args + ?l + [(?a1 ...) + ?e1 ...] + ?clause1 ...) + (if (= ?l (length '(?a1 ...))) + (apply (lambda (?a1 ...) + ?e1 ...) + ?args) + (case-lambda + "CLAUSE" + ?args + ?l + ?clause1 ...))] + [(case-lambda + "CLAUSE" + ?args + ?l + [(?a1 . ?ar) + ?e1 ...] + ?clause1 ...) + (case-lambda + "IMPROPER" + ?args + ?l + 1 + [?a1 + . ?ar] + [?ar + ?e1 ...] + ?clause1 ...)] + [(case-lambda + "CLAUSE" + ?args + ?l + [?a1 + ?e1 ...]) + (%plain-let ((?a1 ?args)) ?e1 ...)] + [(case-lambda + "CLAUSE" + ?args + ?l) + (error "Wrong number of arguments to CASE-LAMBDA.")] + [(case-lambda + "IMPROPER" + ?args + ?l + ?k + ?al + [(?a1 . ?ar) + ?e1 ...] + ?clause1 ...) + (case-lambda + "IMPROPER" + ?args + ?l + [+ + ?k + 1] + ?al + [?ar + ?e1 ...] + ?clause1 ...)] + [(case-lambda + "IMPROPER" + ?args + ?l + ?k + ?al + [?ar + ?e1 ...] + ?clause1 ...) + (if (>= ?l ?k) + (apply (lambda ?al + ?e1 ...) + ?args) + (case-lambda + "CLAUSE" + ?args + ?l + ?clause1 ...))])) + +(define-syntax help + (syntax-rules () + [(help) (displayln "help expects an identifier to lookup documentation for")] + [(help ident) (%doc? %-builtin-module-steel/base (quote ident))] + [(help module ident) (%doc? (datum->syntax %-builtin-module- module) (quote ident))])) + +(define-syntax dbg! + (syntax-rules () + [(dbg! expr) + (let ([result expr]) + (displayln (quote expr) " = " result) + result)])) + +(define-syntax contract/out + (syntax-rules () + [(contract/out name contract) (%require-ident-spec name (bind/c contract name 'name))])) + +(define (force promise) + (promise)) + +;; syntax +(define-syntax delay + (syntax-rules () + [(delay expr) (lambda () expr)])) + +(define values list) +(define (call-with-values producer consumer) + (apply consumer (producer))) diff --git a/crates/steel-core/src/stdlib.rs b/crates/steel-core/src/stdlib.rs index 0723dc273..60034928f 100644 --- a/crates/steel-core/src/stdlib.rs +++ b/crates/steel-core/src/stdlib.rs @@ -1,11 +1,9 @@ #[cfg(not(target_os = "windows"))] -pub const PRELUDE: &str = include_str!("scheme/stdlib.rkt"); +pub const PRELUDE: &str = include_str!("scheme/stdlib.scm"); // pub const PRELUDE: &str = include_str!("scheme/test.rkt"); #[cfg(not(target_os = "windows"))] pub const TRIESORT: &str = include_str!("scheme/trie.rkt"); #[cfg(not(target_os = "windows"))] -pub const CONTRACTS: &str = include_str!("scheme/contract.rkt"); -#[cfg(not(target_os = "windows"))] pub const TYPES: &str = include_str!("scheme/types.rkt"); #[cfg(not(target_os = "windows"))] pub const METHODS: &str = include_str!("scheme/methods.rkt"); @@ -19,12 +17,10 @@ pub const DISPLAY: &str = include_str!("scheme/display.rkt"); pub const KERNEL: &str = include_str!("scheme/kernel.scm"); #[cfg(target_os = "windows")] -pub const PRELUDE: &str = include_str!(r#"scheme\stdlib.rkt"#); +pub const PRELUDE: &str = include_str!(r#"scheme\stdlib.scm"#); #[cfg(target_os = "windows")] pub const TRIESORT: &str = include_str!(r#"scheme\trie.rkt"#); #[cfg(target_os = "windows")] -pub const CONTRACTS: &str = include_str!(r#"scheme\contract.rkt"#); -#[cfg(target_os = "windows")] pub const TYPES: &str = include_str!(r#"scheme\types.rkt"#); #[cfg(target_os = "windows")] pub const MERGE: &str = include_str!(r#"scheme\merge.rkt"#); diff --git a/crates/steel-core/src/steel_vm/builtin.rs b/crates/steel-core/src/steel_vm/builtin.rs index 69068dd73..4876f9311 100644 --- a/crates/steel-core/src/steel_vm/builtin.rs +++ b/crates/steel-core/src/steel_vm/builtin.rs @@ -98,6 +98,7 @@ impl RegisterValue for BuiltInModule { pub static MODULE_GET: Lazy = Lazy::new(|| "%module-get%".into()); pub static VOID: Lazy = Lazy::new(|| "void".into()); +pub static GET_DYLIB: Lazy = Lazy::new(|| "#%get-dylib".into()); // Global function table thread_local! { @@ -211,7 +212,7 @@ impl BuiltInModule { } } - pub fn bound_identifiers(&self) -> im_lists::list::List { + pub fn bound_identifiers(&self) -> crate::values::lists::List { self.values .keys() .map(|x| SteelVal::StringV(x.to_string().into())) @@ -294,6 +295,62 @@ impl BuiltInModule { self.values.get(name.as_str()).unwrap().clone() } + // When we're loading dylib, we won't know anything about it until _after_ it is loaded. We don't explicitly + // want to load it before we need it, since the compiler should be able to analyze a dylib without having to + // have the dylib built and loaded into memory to do so. + pub fn dylib_to_syntax<'a>( + dylib_name: &'a str, + names: impl Iterator, + prefix: Option<&str>, + ) -> ExprKind { + // let module_name = self.unreadable_name(); + + // let dylib_name_interned = dylib_name.into(); + + let mut defines = names + .map(|x| { + // TODO: Consider a custom delimeter as well + // If we have a prefix, put the prefix at the front and append x + // Otherwise, just default to using the provided name + let name = prefix + .map(|pre| pre.to_string() + x) + .unwrap_or_else(|| x.to_string()); + + ExprKind::Define(Box::new(crate::parser::ast::Define::new( + // TODO: Add the custom prefix here + // Handling a more complex case of qualifying imports + ExprKind::atom(name), + ExprKind::List(crate::parser::ast::List::new(vec![ + ExprKind::atom(*MODULE_GET), + ExprKind::List(crate::parser::ast::List::new(vec![ + ExprKind::atom(*GET_DYLIB), + ExprKind::string_lit(dylib_name.to_string()), + ])), + ExprKind::Quote(Box::new(crate::parser::ast::Quote::new( + ExprKind::atom(x.to_string()), + SyntaxObject::default(TokenType::Quote), + ))), + ])), + SyntaxObject::default(TokenType::Define), + ))) + }) + .collect::>(); + + defines.push(ExprKind::List(crate::parser::ast::List::new(vec![ + ExprKind::atom(*MODULE_GET), + ExprKind::atom("%-builtin-module-".to_string() + "steel/constants"), + ExprKind::Quote(Box::new(crate::parser::ast::Quote::new( + ExprKind::atom(*VOID), + SyntaxObject::default(TokenType::Quote), + ))), + ]))); + + ExprKind::Begin(crate::parser::ast::Begin::new( + defines, + SyntaxObject::default(TokenType::Begin), + )) + } + /// This does the boot strapping for bundling modules /// Rather than expose a native hash-get, the built in module above should expose a raw /// function to fetch a dependency. It will be a packaged # with only a function to diff --git a/crates/steel-core/src/steel_vm/contracts.rs b/crates/steel-core/src/steel_vm/contracts.rs index 07089e262..bb1c10a61 100644 --- a/crates/steel-core/src/steel_vm/contracts.rs +++ b/crates/steel-core/src/steel_vm/contracts.rs @@ -1,467 +1,452 @@ -use super::vm::VmCore; -use crate::{ - gc::Gc, - parser::span::Span, - rvals::{Result, SteelVal}, - stop, - values::contracts::{ - Contract, ContractType, ContractedFunction, DependentContract, FlatContract, - FunctionContract, FunctionKind, - }, -}; - -use log::debug; - -impl ContractedFunction { - pub fn apply( - &self, - arguments: Vec, - cur_inst_span: &Span, - ctx: &mut VmCore, - ) -> Result { - // Walk back and find the contracts to apply - { - let mut parent = self.contract.parent(); - while let Some(p) = parent { - // println!("Applying parents"); - p.apply(&self.name, &self.function, &arguments, cur_inst_span, ctx)?; - - parent = p.parent() - } - } - - self.contract - .apply(&self.name, &self.function, &arguments, cur_inst_span, ctx) - } -} - -impl FlatContract { - pub fn apply(&self, arg: SteelVal, cur_inst_span: &Span, ctx: &mut VmCore) -> Result<()> { - // TODO make this not clone the argument - let output = match self.predicate() { - SteelVal::FuncV(func) => func(&[arg.clone()]).map_err(|x| x.set_span(*cur_inst_span)), - SteelVal::BoxedFunction(func) => { - func.func()(&[arg.clone()]).map_err(|x| x.set_span(*cur_inst_span)) - } - SteelVal::Closure(closure) => ctx.call_with_one_arg(closure, arg.clone()), - SteelVal::ContractedFunction(c) => c.apply(vec![arg.clone()], cur_inst_span, ctx), - _ => { - stop!(TypeMismatch => format!("contract expected a function, found: {:?}", self.predicate()); *cur_inst_span) - } - }?; - - if output.is_truthy() { - Ok(()) - } else { - stop!(ContractViolation => format!("Found in the application of a flat contract for {}: the given input: {} resulted in a contract violation", &self.name, arg); *cur_inst_span); - } - } -} - -/// Extension trait for the application of function contracts -pub(crate) trait FunctionContractExt { - fn apply( - &self, - name: &Option, - // function: &Gc, - function: &SteelVal, - arguments: &[SteelVal], - cur_inst_span: &Span, - ctx: &mut VmCore, - ) -> Result; -} - -impl FunctionContractExt for FunctionKind { - fn apply( - &self, - name: &Option, - function: &SteelVal, - arguments: &[SteelVal], - cur_inst_span: &Span, - ctx: &mut VmCore, - ) -> Result { - match self { - Self::Basic(fc) => fc.apply(name, function, arguments, cur_inst_span, ctx), - Self::Dependent(dc) => dc.apply(name, function, arguments, cur_inst_span, ctx), - } - } -} - -impl FunctionContractExt for DependentContract { - fn apply( - &self, - name: &Option, - function: &SteelVal, - arguments: &[SteelVal], - cur_inst_span: &Span, - ctx: &mut VmCore, - ) -> Result { - let mut verified_args: Vec = Vec::new(); - - for (i, (arg, dependent_pair)) in - arguments.iter().zip(self.pre_conditions.iter()).enumerate() - { - let thunk = &dependent_pair.thunk; - - let arg_stack = dependent_pair - .arguments - .iter() - .map(|named_argument| { - self.arg_positions - .get(named_argument) - .and_then(|x| arguments.get(*x)) - .cloned() - }) - .collect::>>() - .expect("missing argument in dependent contract"); - - let contract = { - ctx.call_with_args(thunk, arg_stack)?.contract_or_else( - throw!(TypeMismatch => "dependent contract expected a contract"), - )? - }; - - match contract.as_ref() { - ContractType::Flat(f) => { - debug!("applying flat contract in pre condition: {}", f.name); - - if let Err(e) = f.apply(arg.clone(), cur_inst_span, ctx) { - debug!( - "Blame locations: {:?}, {:?}", - self.contract_attachment_location, name - ); - - let message = format!("This function call caused an error - it occured in the domain position: {}, with the contract: {}, {}, blaming: {:?} (callsite)", i, self, e, self.contract_attachment_location); - - stop!(ContractViolation => message; *cur_inst_span); - } - - verified_args.push(arg.clone()); - } - ContractType::Function(fc) => match arg { - SteelVal::ContractedFunction(contracted_function) => { - let mut pre_parent = contracted_function.contract.clone(); - pre_parent.set_attachment_location(contracted_function.name.clone()); - - let parent = Gc::new(pre_parent); - - let func = contracted_function.function.clone(); - - debug!( - "Setting the parent: {} on a precondition function: {}", - parent.to_string(), - fc.to_string() - ); - - // Get the contract down from the - let mut fc = fc.clone(); - fc.set_parent(parent); - debug!( - "Inside: {:?}, Setting attachment location in range to: {:?}", - name, contracted_function.name - ); - fc.set_attachment_location(contracted_function.name.clone()); - - // TODO Don't pass in None - let new_arg = ContractedFunction::new(fc, func, name.clone()).into(); - - verified_args.push(new_arg); - } - - _ => verified_args.push( - ContractedFunction::new(fc.clone(), arg.clone(), name.clone()).into(), - ), - }, - } - } - - let output = match function { - SteelVal::Closure(function) => ctx.call_with_args(function, verified_args)?, - SteelVal::BoxedFunction(f) => { - f.func()(&verified_args).map_err(|x| x.set_span(*cur_inst_span))? - } - SteelVal::FuncV(f) => f(&verified_args).map_err(|x| x.set_span(*cur_inst_span))?, - SteelVal::FutureFunc(f) => SteelVal::FutureV(Gc::new( - f(&verified_args).map_err(|x| x.set_span(*cur_inst_span))?, - )), - _ => { - todo!("Implement contract application for non bytecode values"); - } - }; - - let thunk = &self.post_condition.thunk; - - let arg_stack = self - .post_condition - .arguments - .iter() - .map(|named_argument| { - self.arg_positions - .get(named_argument) - .and_then(|x| arguments.get(*x)) - .cloned() - }) - .collect::>>() - .expect("missing argument in dependent contract"); - - let contract = { - ctx.call_with_args(thunk, arg_stack)?.contract_or_else( - throw!(TypeMismatch => "dependent contract expected a contract"), - )? - }; - - match contract.as_ref() { - ContractType::Flat(f) => { - debug!("applying flat contract in post condition: {}", f.name); - - if let Err(e) = f.apply(output.clone(), cur_inst_span, ctx) { - debug!( - "Blame locations: {:?}, {:?}", - self.contract_attachment_location, name - ); - - debug!("Parent exists: {}", self.parent().is_some()); - - let blame_location = if self.contract_attachment_location.is_none() { - name - } else { - &self.contract_attachment_location - }; - - // TODO clean this up - if let Some(blame_location) = blame_location { - let error_message = format!("this function call resulted in an error - occured in the range position of this contract: {self} \n - {e} - blaming: {blame_location} - broke its own contract"); - - stop!(ContractViolation => error_message; *cur_inst_span); - } else { - let error_message = format!("this function call resulted in an error - occured in the range position of this contract: {self} \n - {e} - blaming: None - broke its own contract"); - - stop!(ContractViolation => error_message; *cur_inst_span); - } - } - - Ok(output) - } - ContractType::Function(fc) => match output { - SteelVal::ContractedFunction(contracted_function) => { - let mut pre_parent = contracted_function.contract.clone(); - pre_parent.set_attachment_location(contracted_function.name.clone()); - - let parent = Gc::new(pre_parent); - - let func = contracted_function.function.clone(); - - debug!( - "Setting the parent: {} on a postcondition function: {}", - parent.to_string(), - fc.to_string() - ); - - // Get the contract down from the parent - let mut fc = fc.clone(); - fc.set_parent(parent); - debug!( - "Inside: {:?}, Setting attachment location in range to: {:?}", - name, contracted_function.name - ); - - // TODO Don't pass in None here - let output = ContractedFunction::new(fc, func, name.clone()).into(); - - Ok(output) - } - - _ => Ok(ContractedFunction::new(fc.clone(), output, name.clone()).into()), - }, - } - } -} - -impl FunctionContract { - pub fn apply( - &self, - name: &Option, - function: &SteelVal, - arguments: &[SteelVal], - cur_inst_span: &Span, - ctx: &mut VmCore, - ) -> Result { - let verified_args = self.verify_preconditions(arguments, cur_inst_span, ctx, name)?; - - // TODO use actual VM with real stack instead - - /* - Ideas for this: call a builtin - - */ - - let output = match function { - SteelVal::Closure(function) => { - // TODO: Here is the problem - we recur by calling the function - // What we should do is actually leverage the stack in the VM directly instead of making a recursive call here - ctx.call_with_args(function, verified_args.into_iter())? - } - SteelVal::BoxedFunction(f) => { - f.func()(&verified_args).map_err(|x| x.set_span(*cur_inst_span))? - } - SteelVal::FuncV(f) => f(&verified_args).map_err(|x| x.set_span(*cur_inst_span))?, - SteelVal::FutureFunc(f) => SteelVal::FutureV(Gc::new( - f(&verified_args).map_err(|x| x.set_span(*cur_inst_span))?, - )), - _ => { - todo!("Implement contract application for non bytecode values"); - } - }; - - match self.post_condition().as_ref() { - ContractType::Flat(f) => { - // unimplemented!(); - - debug!("applying flat contract in post condition: {}", f.name); - - if let Err(e) = f.apply(output.clone(), cur_inst_span, ctx) { - debug!( - "Blame locations: {:?}, {:?}", - self.contract_attachment_location, name - ); - - debug!("Parent exists: {}", self.parent().is_some()); - - let blame_location = if self.contract_attachment_location.is_none() { - name - } else { - &self.contract_attachment_location - }; - - // TODO clean this up - if let Some(blame_location) = blame_location { - let error_message = format!("this function call resulted in an error - occured in the range position of this contract: {self} \n - {e} - blaming: {blame_location} - broke its own contract"); - - stop!(ContractViolation => error_message; *cur_inst_span); - } else { - let error_message = format!("this function call resulted in an error - occured in the range position of this contract: {self} \n - {e} - blaming: None - broke its own contract"); - - stop!(ContractViolation => error_message; *cur_inst_span); - } - } - - Ok(output) - } - ContractType::Function(fc) => match output { - SteelVal::ContractedFunction(contracted_function) => { - let mut pre_parent = contracted_function.contract.clone(); - pre_parent.set_attachment_location(contracted_function.name.clone()); - - let parent = Gc::new(pre_parent); - - let func = contracted_function.function.clone(); - - debug!( - "Setting the parent: {} on a postcondition function: {}", - parent.to_string(), - fc.to_string() - ); - - // Get the contract down from the parent - let mut fc = fc.clone(); - fc.set_parent(parent); - debug!( - "Inside: {:?}, Setting attachment location in range to: {:?}", - name, contracted_function.name - ); - - // TODO Don't pass in None here - let output = ContractedFunction::new(fc, func, name.clone()).into(); - - Ok(output) - } - - _ => Ok(ContractedFunction::new(fc.clone(), output, name.clone()).into()), - }, - } - } -} - -impl FunctionContract { - fn verify_preconditions( - &self, - arguments: &[SteelVal], - cur_inst_span: &Span, - ctx: &mut VmCore, - name: &Option, - ) -> Result> { - let mut verified_args = Vec::new(); - - for (i, (arg, contract)) in arguments - .iter() - .zip(self.pre_conditions().iter()) - .enumerate() - { - match contract.as_ref() { - ContractType::Flat(f) => { - debug!("applying flat contract in pre condition: {}", f.name); - - if let Err(e) = f.apply(arg.clone(), cur_inst_span, ctx) { - debug!( - "Blame locations: {:?}, {:?}", - self.contract_attachment_location, name - ); - - let message = format!("This function call caused an error - it occured in the domain position: {}, with the contract: {}, {}, blaming: {:?} (callsite)", i, self, e, self.contract_attachment_location); - - stop!(ContractViolation => message; *cur_inst_span); - } - - verified_args.push(arg.clone()); - } - ContractType::Function(fc) => match arg { - SteelVal::ContractedFunction(contracted_function) => { - let mut pre_parent = contracted_function.contract.clone(); - pre_parent.set_attachment_location(contracted_function.name.clone()); - - let parent = Gc::new(pre_parent); - - let func = contracted_function.function.clone(); - - debug!( - "Setting the parent: {} on a precondition function: {}", - parent.to_string(), - fc.to_string() - ); - - // Get the contract down from the - let mut fc = fc.clone(); - fc.set_parent(parent); - debug!( - "Inside: {:?}, Setting attachment location in range to: {:?}", - name, contracted_function.name - ); - fc.set_attachment_location(contracted_function.name.clone()); - - // TODO Don't pass in None - let new_arg = ContractedFunction::new(fc, func, name.clone()).into(); - - verified_args.push(new_arg); - } - - _ => verified_args.push( - ContractedFunction::new(fc.clone(), arg.clone(), name.clone()).into(), - ), - }, - } - } - - Ok(verified_args) - } -} +// impl ContractedFunction { +// pub fn apply( +// &self, +// arguments: Vec, +// cur_inst_span: &Span, +// ctx: &mut VmCore, +// ) -> Result { +// // Walk back and find the contracts to apply +// { +// let mut parent = self.contract.parent(); +// while let Some(p) = parent { +// // println!("Applying parents"); +// p.apply(&self.name, &self.function, &arguments, cur_inst_span, ctx)?; + +// parent = p.parent() +// } +// } + +// self.contract +// .apply(&self.name, &self.function, &arguments, cur_inst_span, ctx) +// } +// } + +// impl FlatContract { +// pub fn apply(&self, arg: SteelVal, cur_inst_span: &Span, ctx: &mut VmCore) -> Result<()> { +// // TODO make this not clone the argument +// let output = match self.predicate() { +// SteelVal::FuncV(func) => func(&[arg.clone()]).map_err(|x| x.set_span(*cur_inst_span)), +// SteelVal::BoxedFunction(func) => { +// func.func()(&[arg.clone()]).map_err(|x| x.set_span(*cur_inst_span)) +// } +// SteelVal::Closure(closure) => ctx.call_with_one_arg(closure, arg.clone()), +// SteelVal::ContractedFunction(c) => c.apply(vec![arg.clone()], cur_inst_span, ctx), +// _ => { +// stop!(TypeMismatch => format!("contract expected a function, found: {:?}", self.predicate()); *cur_inst_span) +// } +// }?; + +// if output.is_truthy() { +// Ok(()) +// } else { +// stop!(ContractViolation => format!("Found in the application of a flat contract for {}: the given input: {} resulted in a contract violation", &self.name, arg); *cur_inst_span); +// } +// } +// } + +// /// Extension trait for the application of function contracts +// pub(crate) trait FunctionContractExt { +// fn apply( +// &self, +// name: &Option, +// // function: &Gc, +// function: &SteelVal, +// arguments: &[SteelVal], +// cur_inst_span: &Span, +// ctx: &mut VmCore, +// ) -> Result; +// } + +// impl FunctionContractExt for FunctionKind { +// fn apply( +// &self, +// name: &Option, +// function: &SteelVal, +// arguments: &[SteelVal], +// cur_inst_span: &Span, +// ctx: &mut VmCore, +// ) -> Result { +// match self { +// Self::Basic(fc) => fc.apply(name, function, arguments, cur_inst_span, ctx), +// Self::Dependent(dc) => dc.apply(name, function, arguments, cur_inst_span, ctx), +// } +// } +// } + +// impl FunctionContractExt for DependentContract { +// fn apply( +// &self, +// name: &Option, +// function: &SteelVal, +// arguments: &[SteelVal], +// cur_inst_span: &Span, +// ctx: &mut VmCore, +// ) -> Result { +// let mut verified_args: Vec = Vec::new(); + +// for (i, (arg, dependent_pair)) in +// arguments.iter().zip(self.pre_conditions.iter()).enumerate() +// { +// let thunk = &dependent_pair.thunk; + +// let arg_stack = dependent_pair +// .arguments +// .iter() +// .map(|named_argument| { +// self.arg_positions +// .get(named_argument) +// .and_then(|x| arguments.get(*x)) +// .cloned() +// }) +// .collect::>>() +// .expect("missing argument in dependent contract"); + +// let contract = { +// ctx.call_with_args(thunk, arg_stack)?.contract_or_else( +// throw!(TypeMismatch => "dependent contract expected a contract"), +// )? +// }; + +// match contract.as_ref() { +// ContractType::Flat(f) => { +// debug!("applying flat contract in pre condition: {}", f.name); + +// if let Err(e) = f.apply(arg.clone(), cur_inst_span, ctx) { +// debug!( +// "Blame locations: {:?}, {:?}", +// self.contract_attachment_location, name +// ); + +// let message = format!("This function call caused an error - it occured in the domain position: {}, with the contract: {}, {}, blaming: {:?} (callsite)", i, self, e, self.contract_attachment_location); + +// stop!(ContractViolation => message; *cur_inst_span); +// } + +// verified_args.push(arg.clone()); +// } +// ContractType::Function(fc) => match arg { +// SteelVal::ContractedFunction(contracted_function) => { +// let mut pre_parent = contracted_function.contract.clone(); +// pre_parent.set_attachment_location(contracted_function.name.clone()); + +// let parent = Gc::new(pre_parent); + +// let func = contracted_function.function.clone(); + +// debug!( +// "Setting the parent: {} on a precondition function: {}", +// parent.to_string(), +// fc.to_string() +// ); + +// // Get the contract down from the +// let mut fc = fc.clone(); +// fc.set_parent(parent); +// debug!( +// "Inside: {:?}, Setting attachment location in range to: {:?}", +// name, contracted_function.name +// ); +// fc.set_attachment_location(contracted_function.name.clone()); + +// // TODO Don't pass in None +// let new_arg = ContractedFunction::new(fc, func, name.clone()).into(); + +// verified_args.push(new_arg); +// } + +// _ => verified_args.push( +// ContractedFunction::new(fc.clone(), arg.clone(), name.clone()).into(), +// ), +// }, +// } +// } + +// let output = match function { +// SteelVal::Closure(function) => ctx.call_with_args(function, verified_args)?, +// SteelVal::BoxedFunction(f) => { +// f.func()(&verified_args).map_err(|x| x.set_span(*cur_inst_span))? +// } +// SteelVal::FuncV(f) => f(&verified_args).map_err(|x| x.set_span(*cur_inst_span))?, +// SteelVal::FutureFunc(f) => SteelVal::FutureV(Gc::new( +// f(&verified_args).map_err(|x| x.set_span(*cur_inst_span))?, +// )), +// _ => { +// todo!("Implement contract application for non bytecode values"); +// } +// }; + +// let thunk = &self.post_condition.thunk; + +// let arg_stack = self +// .post_condition +// .arguments +// .iter() +// .map(|named_argument| { +// self.arg_positions +// .get(named_argument) +// .and_then(|x| arguments.get(*x)) +// .cloned() +// }) +// .collect::>>() +// .expect("missing argument in dependent contract"); + +// let contract = { +// ctx.call_with_args(thunk, arg_stack)?.contract_or_else( +// throw!(TypeMismatch => "dependent contract expected a contract"), +// )? +// }; + +// match contract.as_ref() { +// ContractType::Flat(f) => { +// debug!("applying flat contract in post condition: {}", f.name); + +// if let Err(e) = f.apply(output.clone(), cur_inst_span, ctx) { +// debug!( +// "Blame locations: {:?}, {:?}", +// self.contract_attachment_location, name +// ); + +// debug!("Parent exists: {}", self.parent().is_some()); + +// let blame_location = if self.contract_attachment_location.is_none() { +// name +// } else { +// &self.contract_attachment_location +// }; + +// // TODO clean this up +// if let Some(blame_location) = blame_location { +// let error_message = format!("this function call resulted in an error - occured in the range position of this contract: {self} \n +// {e} +// blaming: {blame_location} - broke its own contract"); + +// stop!(ContractViolation => error_message; *cur_inst_span); +// } else { +// let error_message = format!("this function call resulted in an error - occured in the range position of this contract: {self} \n +// {e} +// blaming: None - broke its own contract"); + +// stop!(ContractViolation => error_message; *cur_inst_span); +// } +// } + +// Ok(output) +// } +// ContractType::Function(fc) => match output { +// SteelVal::ContractedFunction(contracted_function) => { +// let mut pre_parent = contracted_function.contract.clone(); +// pre_parent.set_attachment_location(contracted_function.name.clone()); + +// let parent = Gc::new(pre_parent); + +// let func = contracted_function.function.clone(); + +// debug!( +// "Setting the parent: {} on a postcondition function: {}", +// parent.to_string(), +// fc.to_string() +// ); + +// // Get the contract down from the parent +// let mut fc = fc.clone(); +// fc.set_parent(parent); +// debug!( +// "Inside: {:?}, Setting attachment location in range to: {:?}", +// name, contracted_function.name +// ); + +// // TODO Don't pass in None here +// let output = ContractedFunction::new(fc, func, name.clone()).into(); + +// Ok(output) +// } + +// _ => Ok(ContractedFunction::new(fc.clone(), output, name.clone()).into()), +// }, +// } +// } +// } + +// impl FunctionContract { +// pub fn apply( +// &self, +// name: &Option, +// function: &SteelVal, +// arguments: &[SteelVal], +// cur_inst_span: &Span, +// ctx: &mut VmCore, +// ) -> Result { +// let verified_args = self.verify_preconditions(arguments, cur_inst_span, ctx, name)?; + +// // TODO use actual VM with real stack instead + +// /* +// Ideas for this: call a builtin + +// */ +// let output = match function { +// SteelVal::Closure(function) => { +// // TODO: Here is the problem - we recur by calling the function +// // What we should do is actually leverage the stack in the VM directly instead of making a recursive call here +// ctx.call_with_args(function, verified_args.into_iter())? +// } +// SteelVal::BoxedFunction(f) => { +// f.func()(&verified_args).map_err(|x| x.set_span(*cur_inst_span))? +// } +// SteelVal::FuncV(f) => f(&verified_args).map_err(|x| x.set_span(*cur_inst_span))?, +// SteelVal::FutureFunc(f) => SteelVal::FutureV(Gc::new( +// f(&verified_args).map_err(|x| x.set_span(*cur_inst_span))?, +// )), +// _ => { +// todo!("Implement contract application for non bytecode values"); +// } +// }; + +// match self.post_condition().as_ref() { +// ContractType::Flat(f) => { +// // unimplemented!(); + +// debug!("applying flat contract in post condition: {}", f.name); + +// if let Err(e) = f.apply(output.clone(), cur_inst_span, ctx) { +// debug!( +// "Blame locations: {:?}, {:?}", +// self.contract_attachment_location, name +// ); + +// debug!("Parent exists: {}", self.parent().is_some()); + +// let blame_location = if self.contract_attachment_location.is_none() { +// name +// } else { +// &self.contract_attachment_location +// }; + +// // TODO clean this up +// if let Some(blame_location) = blame_location { +// let error_message = format!("this function call resulted in an error - occured in the range position of this contract: {self} \n +// {e} +// blaming: {blame_location} - broke its own contract"); + +// stop!(ContractViolation => error_message; *cur_inst_span); +// } else { +// let error_message = format!("this function call resulted in an error - occured in the range position of this contract: {self} \n +// {e} +// blaming: None - broke its own contract"); + +// stop!(ContractViolation => error_message; *cur_inst_span); +// } +// } + +// Ok(output) +// } +// ContractType::Function(fc) => match output { +// SteelVal::ContractedFunction(contracted_function) => { +// let mut pre_parent = contracted_function.contract.clone(); +// pre_parent.set_attachment_location(contracted_function.name.clone()); + +// let parent = Gc::new(pre_parent); + +// let func = contracted_function.function.clone(); + +// debug!( +// "Setting the parent: {} on a postcondition function: {}", +// parent.to_string(), +// fc.to_string() +// ); + +// // Get the contract down from the parent +// let mut fc = fc.clone(); +// fc.set_parent(parent); +// debug!( +// "Inside: {:?}, Setting attachment location in range to: {:?}", +// name, contracted_function.name +// ); + +// // TODO Don't pass in None here +// let output = ContractedFunction::new(fc, func, name.clone()).into(); + +// Ok(output) +// } + +// _ => Ok(ContractedFunction::new(fc.clone(), output, name.clone()).into()), +// }, +// } +// } +// } + +// impl FunctionContract { +// fn verify_preconditions( +// &self, +// arguments: &[SteelVal], +// cur_inst_span: &Span, +// ctx: &mut VmCore, +// name: &Option, +// ) -> Result> { +// let mut verified_args = Vec::new(); + +// for (i, (arg, contract)) in arguments +// .iter() +// .zip(self.pre_conditions().iter()) +// .enumerate() +// { +// match contract.as_ref() { +// ContractType::Flat(f) => { +// debug!("applying flat contract in pre condition: {}", f.name); + +// if let Err(e) = f.apply(arg.clone(), cur_inst_span, ctx) { +// debug!( +// "Blame locations: {:?}, {:?}", +// self.contract_attachment_location, name +// ); + +// let message = format!("This function call caused an error - it occured in the domain position: {}, with the contract: {}, {}, blaming: {:?} (callsite)", i, self, e, self.contract_attachment_location); + +// stop!(ContractViolation => message; *cur_inst_span); +// } + +// verified_args.push(arg.clone()); +// } +// ContractType::Function(fc) => match arg { +// SteelVal::ContractedFunction(contracted_function) => { +// let mut pre_parent = contracted_function.contract.clone(); +// pre_parent.set_attachment_location(contracted_function.name.clone()); + +// let parent = Gc::new(pre_parent); + +// let func = contracted_function.function.clone(); + +// debug!( +// "Setting the parent: {} on a precondition function: {}", +// parent.to_string(), +// fc.to_string() +// ); + +// // Get the contract down from the +// let mut fc = fc.clone(); +// fc.set_parent(parent); +// debug!( +// "Inside: {:?}, Setting attachment location in range to: {:?}", +// name, contracted_function.name +// ); +// fc.set_attachment_location(contracted_function.name.clone()); + +// // TODO Don't pass in None +// let new_arg = ContractedFunction::new(fc, func, name.clone()).into(); + +// verified_args.push(new_arg); +// } + +// _ => verified_args.push( +// ContractedFunction::new(fc.clone(), arg.clone(), name.clone()).into(), +// ), +// }, +// } +// } + +// Ok(verified_args) +// } +// } #[cfg(test)] mod contract_tests { diff --git a/crates/steel-core/src/steel_vm/dylib.rs b/crates/steel-core/src/steel_vm/dylib.rs index b80c67ad3..80e5d6c09 100644 --- a/crates/steel-core/src/steel_vm/dylib.rs +++ b/crates/steel-core/src/steel_vm/dylib.rs @@ -1,6 +1,9 @@ #![allow(non_camel_case_types)] use std::{ + cell::RefCell, + collections::HashMap, path::{Path, PathBuf}, + rc::Rc, sync::{Arc, Mutex}, }; @@ -13,12 +16,18 @@ use abi_stable::{ }; use once_cell::sync::Lazy; -use super::ffi::FFIModule; +use crate::rvals::{IntoSteelVal, SteelString, SteelVal}; + +use super::{builtin::BuiltInModule, ffi::FFIModule}; // The new and improved loading of modules static LOADED_MODULES: Lazy>>> = Lazy::new(|| Arc::new(Mutex::new(Vec::new()))); +thread_local! { + static BUILT_DYLIBS: Rc>> = Rc::new(RefCell::new(HashMap::new())); +} + #[repr(C)] #[derive(StableAbi)] #[sabi(kind(Prefix(prefix_ref = GenerateModule_Ref)))] @@ -41,17 +50,19 @@ pub fn load_root_module_in_directory(file: &Path) -> Result Remove this, drop the dependency on dlopen -// #[derive(WrapperApi, Clone)] -// struct ModuleApi { -// generate_module: extern "C" fn() -> RBox, -// // build_module: fn(module: &mut BuiltInModule), -// // free_module: fn(ptr: *mut BuiltInModule), -// } - #[derive(Clone)] pub(crate) struct DylibContainers {} +#[steel_derive::function(name = "#%get-dylib")] +pub fn load_module(target: &SteelString) -> crate::rvals::Result { + match DylibContainers::load_module(target.clone()) { + Some(container) => container.into_steelval(), + None => { + stop!(Generic => format!("dylib not found: {} or dylibs are not enabled for this instance of the steel runtime", target)) + } + } +} + impl DylibContainers { pub fn new() -> Self { Self { @@ -59,86 +70,88 @@ impl DylibContainers { } } - // TODO: @Matt - make these load modules lazily. Loading all modules right at the start - // could be fairly burdensome from a startup time standpoint, and also requires modules to be separated from the standard ones. - pub fn load_modules_from_directory(&mut self, home: Option) { - #[cfg(feature = "profiling")] - let now = std::time::Instant::now(); + // home should... probably just be $STEEL_HOME? + pub fn load_module(target: SteelString) -> Option { + #[cfg(not(feature = "dylibs"))] + { + None // TODO: This _should_ just error instead! + } - // let home = std::env::var("STEEL_HOME"); + #[cfg(feature = "dylibs")] + { + if let Some(module) = BUILT_DYLIBS.with(|x| x.borrow().get(target.as_str()).cloned()) { + return Some(module); + } - if let Some(home) = home { - // let guard = LOADED_DYLIBS.lock().unwrap(); - let mut module_guard = LOADED_MODULES.lock().unwrap(); + let home = std::env::var("STEEL_HOME").ok(); - let mut home = PathBuf::from(home); - home.push("native"); + if let Some(home) = home { + // let guard = LOADED_DYLIBS.lock().unwrap(); + let mut module_guard = LOADED_MODULES.lock().unwrap(); - if home.exists() { - let paths = std::fs::read_dir(home).unwrap(); + let mut home = PathBuf::from(home); + home.push("native"); - for path in paths { - // println!("{:?}", path); + if home.exists() { + let paths = std::fs::read_dir(home).unwrap(); - let path = path.unwrap().path(); + for path in paths { + // println!("{:?}", path); - if path.extension().unwrap() != "so" && path.extension().unwrap() != "dylib" { - continue; - } + let path = path.unwrap().path(); - let path_name = path.file_name().and_then(|x| x.to_str()).unwrap(); - log::info!(target: "dylibs", "Loading dylib: {}", path_name); + if path.extension().unwrap() != "so" && path.extension().unwrap() != "dylib" + { + continue; + } - let module_name = path_name.to_string(); + let path_name = path + .file_stem() + // .file_name() + .and_then(|x| x.to_str()) + .unwrap(); + log::info!(target: "dylibs", "Loading dylib: {}", path_name); - if module_guard.iter().find(|x| x.0 == path_name).is_some() { - continue; - } + // Didn't match! skip it + if path_name != target.as_str() { + continue; + } + + let module_name = path_name.to_string(); + + if module_guard.iter().find(|x| x.0 == path_name).is_some() { + continue; + } - // Load the module in - let container = load_root_module_in_directory(&path).unwrap(); - module_guard.push((module_name, container)); + // Load the module in + let container = load_root_module_in_directory(&path).unwrap(); + + let dylib_module = container.generate_module()(); + + module_guard.push((module_name, container)); + + let external_module = + crate::steel_vm::ffi::FFIWrappedModule::new(dylib_module) + .expect("dylib failed to load!") + .build(); + + BUILT_DYLIBS.with(|x| { + x.borrow_mut() + .insert(target.to_string(), external_module.clone()) + }); + + log::info!(target: "dylibs", "Registering dylib: {} - {}", path_name, target); + + return Some(external_module); + } + } else { + log::warn!(target: "dylibs", "$STEEL_HOME/native directory does not exist") } } else { - log::warn!(target: "dylibs", "$STEEL_HOME/native directory does not exist") + log::warn!(target: "dylibs", "STEEL_HOME variable missing - unable to read shared dylibs") } - } else { - log::warn!(target: "dylibs", "STEEL_HOME variable missing - unable to read shared dylibs") - } - - // self.containers = Arc::clone(&LOADED_DYLIBS); - #[cfg(feature = "profiling")] - if log::log_enabled!(target: "pipeline_time", log::Level::Debug) { - log::debug!(target: "pipeline_time", "Dylib loading time: {:?}", now.elapsed()); + None } } - - // TODO: This should be lazily loaded on the first require-builtin - // For now, we can just load everything at the start when the interpreter boots up - pub fn load_modules(&mut self) { - self.load_modules_from_directory(std::env::var("STEEL_HOME").ok()) - } - - // pub fn modules(&self) -> Vec<*const BuiltInModule> { - // LOADED_DYLIBS - // .lock() - // .unwrap() - // .iter() - // .map(|x| x.1.generate_module()) - // .collect() - // } - - pub fn modules(&self) -> Vec> { - LOADED_MODULES - .lock() - .unwrap() - .iter() - .map(|x| { - // let mut module = BuiltInModule::raw(); - x.1.generate_module()() - // module - }) - .collect() - } } diff --git a/crates/steel-core/src/steel_vm/engine.rs b/crates/steel-core/src/steel_vm/engine.rs index 88617745d..1873e43fe 100644 --- a/crates/steel-core/src/steel_vm/engine.rs +++ b/crates/steel-core/src/steel_vm/engine.rs @@ -14,7 +14,7 @@ use super::dylib::DylibContainers; use crate::{ compiler::{ - compiler::Compiler, + compiler::{Compiler, SerializableCompiler}, modules::CompiledModule, program::{Executable, RawProgramWithSymbols, SerializableRawProgramWithSymbols}, }, @@ -34,13 +34,22 @@ use crate::{ parser::{ParseError, Parser, Sources}, }, rerrs::{back_trace, back_trace_to_string}, - rvals::{FromSteelVal, IntoSteelVal, Result, SteelVal}, + rvals::{ + cycles::{install_printer, print_in_engine, PRINT_IN_ENGINE_DEFINITION}, + FromSteelVal, IntoSteelVal, Result, SteelVal, + }, steel_vm::register_fn::RegisterFn, stop, throw, values::functions::BoxedDynFunction, SteelErr, }; -use std::{collections::HashMap, path::PathBuf, rc::Rc, sync::Arc}; +use std::{ + cell::{Cell, RefCell}, + collections::{HashMap, HashSet}, + path::PathBuf, + rc::Rc, + sync::Arc, +}; use im_rc::HashMap as ImmutableHashMap; use lasso::ThreadedRodeo; @@ -48,9 +57,20 @@ use serde::{Deserialize, Serialize}; use crate::parser::ast::IteratorExtensions; +thread_local! { + static KERNEL_BIN_FILE: Cell> = Cell::new(None); +} + +// Install the binary file to be used during bootup +// pub fn install_bin_file(bin: &'static [u8]) { +// KERNEL_BIN_FILE.with(|x| x.set(Some(bin))); +// } + #[derive(Clone, Default)] pub struct ModuleContainer { modules: ImmutableHashMap, BuiltInModule>, + // Modules that... might eventually be a dynamic library + maybe_module: HashSet, } impl ModuleContainer { @@ -103,19 +123,27 @@ struct BootstrapImage { // Pre compiled programs along with the global state to set before we start any further processing #[derive(Serialize, Deserialize)] struct StartupBootstrapImage { - interner: Arc, syntax_object_id: usize, function_id: usize, sources: Sources, - programs: Vec, - macros: HashMap, + pre_kernel_programs: Vec, + post_kernel_programs: Vec, + kernel: Option, + compiler: Option, } -// #[test] -fn run_bootstrap() { - Engine::create_bootstrap_from_programs(); +#[derive(Serialize, Deserialize)] +struct KernelImage { + // Kernel macros + compiler: SerializableCompiler, + sources: Sources, + kernel_source: SerializableRawProgramWithSymbols, } +// fn steel_create_bootstrap() { +// Engine::create_bootstrap_from_programs("src/boot/bootstrap.bin".into()); +// } + pub struct LifetimeGuard<'a> { engine: &'a mut Engine, } @@ -196,7 +224,7 @@ impl Engine { /// Has access to primitives and syntax rules, but will not defer to a child /// kernel in the compiler pub(crate) fn new_kernel() -> Self { - log::info!(target:"kernel", "Instantiating a new kernel"); + log::debug!(target:"kernel", "Instantiating a new kernel"); let mut vm = Engine { virtual_machine: SteelThread::new(), @@ -213,51 +241,19 @@ impl Engine { vm.compile_and_run_raw_program(crate::steel_vm::primitives::ALL_MODULES) .unwrap(); - log::info!(target:"kernel", "Registered modules in the kernel!"); + log::debug!(target:"kernel", "Registered modules in the kernel!"); - let core_libraries = [ - crate::stdlib::PRELUDE, - crate::stdlib::CONTRACTS, - crate::stdlib::DISPLAY, - ]; + let core_libraries = [crate::stdlib::PRELUDE, crate::stdlib::DISPLAY]; for core in core_libraries.into_iter() { vm.compile_and_run_raw_program(core).unwrap(); } - log::info!(target: "kernel", "Loaded prelude in the kernel!"); - - #[cfg(feature = "dylibs")] - { - vm.dylibs.load_modules(); - - let modules = vm.dylibs.modules(); - - for module in modules { - vm.register_external_module(module).unwrap(); - } - - log::info!(target: "kernel", "Loaded dylibs in the kernel!"); - } + log::debug!(target: "kernel", "Loaded prelude in the kernel!"); vm } - /// Load dylibs from the given path and make them - #[cfg(feature = "dylibs")] - pub fn load_modules_from_directory(&mut self, directory: String) { - log::info!("Loading modules from directory: {}", &directory); - self.dylibs.load_modules_from_directory(Some(directory)); - - let modules = self.dylibs.modules(); - - for module in modules { - self.register_external_module(module).unwrap(); - } - - log::info!("Successfully loaded modules!"); - } - pub fn builtin_modules(&self) -> &ModuleContainer { &self.modules } @@ -266,6 +262,10 @@ impl Engine { /// Has access to primitives and syntax rules, but will not defer to a child /// kernel in the compiler pub(crate) fn new_bootstrap_kernel() -> Self { + // if !install_drop_handler() { + // panic!("Unable to install the drop handler!"); + // } + // If the interner has already been initialized, it most likely means that either: // 1) Tests are being run // 2) The parser was used in a standalone fashion, somewhere, which invalidates the bootstrap @@ -278,7 +278,7 @@ impl Engine { return Engine::new_kernel(); } - log::info!(target:"kernel", "Instantiating a new kernel"); + log::debug!(target:"kernel", "Instantiating a new kernel"); let mut vm = Engine { virtual_machine: SteelThread::new(), @@ -303,21 +303,7 @@ impl Engine { // vm.run_raw_program_from_exprs(ast).unwrap(); } - log::info!(target: "kernel", "Loaded prelude in the kernel!"); - - #[cfg(feature = "dylib")] - { - vm.dylibs.load_modules(); - - let modules = vm.dylibs.modules(); - - for module in modules { - vm.register_external_module(module).unwrap(); - // vm.register_module(module); - } - - log::info!(target: "kernel", "Loaded dylibs in the kernel!"); - } + log::debug!(target: "kernel", "Loaded prelude in the kernel!"); let sources = vm.sources.clone(); @@ -362,10 +348,12 @@ impl Engine { fn load_from_bootstrap(vm: &mut Engine) -> Option> { if matches!(option_env!("STEEL_BOOTSTRAP"), Some("false") | None) { return None; + } else { + println!("LOADING A KERNEL FROM THE BIN FILE"); } let bootstrap: StartupBootstrapImage = - bincode::deserialize(include_bytes!("../boot/bootstrap.bin")).unwrap(); + bincode::deserialize(KERNEL_BIN_FILE.with(|x| x.get())?).unwrap(); // Set the syntax object id to be AFTER the previous items have been parsed SYNTAX_OBJECT_ID.store( @@ -376,24 +364,22 @@ impl Engine { crate::compiler::code_gen::FUNCTION_ID .store(bootstrap.function_id, std::sync::atomic::Ordering::Relaxed); - // Set up the interner to have this latest state - if crate::parser::interner::initialize_with(bootstrap.interner).is_err() { - return None; - } - vm.sources = bootstrap.sources; - vm.compiler.macro_env = bootstrap.macros; + // vm.compiler.macro_env = bootstrap.macros; + + todo!(); Some( bootstrap - .programs + .pre_kernel_programs .into_iter() .map(SerializableRawProgramWithSymbols::into_raw_program) .collect(), ) } - fn create_bootstrap_from_programs() { + // Create kernel bootstrap + pub fn create_kernel_bootstrap_from_programs(output_path: PathBuf) { let mut vm = Engine { virtual_machine: SteelThread::new(), compiler: Compiler::default(), @@ -411,27 +397,90 @@ impl Engine { let bootstrap_sources = [ crate::steel_vm::primitives::ALL_MODULES, crate::stdlib::PRELUDE, - crate::stdlib::CONTRACTS, crate::stdlib::DISPLAY, ]; for source in bootstrap_sources { - // let id = vm.sources.add_source(source.to_string(), None); + let raw_program = vm.emit_raw_program_no_path(source).unwrap(); + programs.push(raw_program.clone()); + vm.run_raw_program(raw_program).unwrap(); + } - // Could fail here - // let parsed: Vec = Parser::new(source, Some(id)) - // .collect::>() - // .unwrap(); + // Grab the last value of the offset + let syntax_object_id = SYNTAX_OBJECT_ID.load(std::sync::atomic::Ordering::Relaxed); + let function_id = + crate::compiler::code_gen::FUNCTION_ID.load(std::sync::atomic::Ordering::Relaxed); - let raw_program = vm.emit_raw_program_no_path(source).unwrap(); + let bootstrap = StartupBootstrapImage { + syntax_object_id, + function_id, + sources: vm.sources, + pre_kernel_programs: programs + .into_iter() + .map(RawProgramWithSymbols::into_serializable_program) + .collect::>() + .unwrap(), + // macros: vm.compiler.macro_env, + post_kernel_programs: Vec::new(), + kernel: None, + compiler: None, + }; - programs.push(raw_program.clone()); + // Encode to something implementing `Write` + let mut f = std::fs::File::create(output_path).unwrap(); + bincode::serialize_into(&mut f, &bootstrap).unwrap(); + } + pub fn create_new_engine_from_bootstrap(output_path: PathBuf) { + let mut vm = Engine { + virtual_machine: SteelThread::new(), + compiler: Compiler::default(), + constants: None, + modules: ModuleContainer::default(), + sources: Sources::new(), + #[cfg(feature = "dylibs")] + dylibs: DylibContainers::new(), + }; + + register_builtin_modules(&mut vm); + + let mut pre_kernel_programs = Vec::new(); + + let bootstrap_sources = [ + crate::steel_vm::primitives::ALL_MODULES, + crate::stdlib::PRELUDE, + crate::stdlib::DISPLAY, + ]; + + for source in bootstrap_sources { + let raw_program = vm.emit_raw_program_no_path(source).unwrap(); + pre_kernel_programs.push(raw_program.clone()); vm.run_raw_program(raw_program).unwrap(); + } + + // This will be our new top level engine + let mut top_level_engine = vm.clone(); + + let sources = vm.sources.clone(); - // asts.push(parsed.clone()); + vm.register_fn("report-error!", move |error: SteelErr| { + raise_error(&sources, error); + }); - // vm.run_raw_program_from_exprs(parsed).unwrap(); + let (kernel, kernel_program) = Kernel::bootstrap(vm); + + // Create kernel for the compiler for the top level vm + top_level_engine.compiler.kernel = Some(kernel); + + let builtin_modules = + ["(require \"#%private/steel/contract\" (for-syntax \"#%private/steel/contract\"))"]; + + let mut post_kernel_programs = Vec::new(); + + for source in builtin_modules { + let raw_program = top_level_engine.emit_raw_program_no_path(source).unwrap(); + post_kernel_programs.push(raw_program.clone()); + top_level_engine.run_raw_program(raw_program).unwrap(); } // Grab the last value of the offset @@ -439,24 +488,131 @@ impl Engine { let function_id = crate::compiler::code_gen::FUNCTION_ID.load(std::sync::atomic::Ordering::Relaxed); + let kernel_sources = top_level_engine + .compiler + .kernel + .as_ref() + .unwrap() + .engine + .sources + .clone(); let bootstrap = StartupBootstrapImage { - interner: take_interner(), syntax_object_id, function_id, - sources: vm.sources, - programs: programs + sources: top_level_engine.sources, + pre_kernel_programs: pre_kernel_programs + .into_iter() + .map(RawProgramWithSymbols::into_serializable_program) + .collect::>() + .unwrap(), + post_kernel_programs: post_kernel_programs .into_iter() .map(RawProgramWithSymbols::into_serializable_program) .collect::>() .unwrap(), - macros: vm.compiler.macro_env, + kernel: Some(KernelImage { + compiler: top_level_engine + .compiler + .kernel + .take() + .unwrap() + .engine + .compiler + .into_serializable_compiler() + .unwrap(), + sources: kernel_sources, + kernel_source: kernel_program.into_serializable_program().unwrap(), + }), + compiler: Some( + top_level_engine + .compiler + .into_serializable_compiler() + .unwrap(), + ), }; // Encode to something implementing `Write` - let mut f = std::fs::File::create("src/boot/bootstrap.bin").unwrap(); + let mut f = std::fs::File::create(output_path).unwrap(); bincode::serialize_into(&mut f, &bootstrap).unwrap(); } + pub fn top_level_load_from_bootstrap(bin: &[u8]) -> Engine { + let bootstrap: StartupBootstrapImage = bincode::deserialize(bin).unwrap(); + + // This is going to be the kernel + let mut vm = Engine { + virtual_machine: SteelThread::new(), + compiler: Compiler::default(), + constants: None, + modules: ModuleContainer::default(), + sources: Sources::new(), + #[cfg(feature = "dylibs")] + dylibs: DylibContainers::new(), + }; + + // Register the modules + register_builtin_modules(&mut vm); + + // Set the syntax object id to be AFTER the previous items have been parsed + SYNTAX_OBJECT_ID.store( + bootstrap.syntax_object_id, + std::sync::atomic::Ordering::Relaxed, + ); + + crate::compiler::code_gen::FUNCTION_ID + .store(bootstrap.function_id, std::sync::atomic::Ordering::Relaxed); + + let bootstrap_kernel = bootstrap.kernel.unwrap(); + + vm.sources = bootstrap_kernel.sources; + vm.compiler = bootstrap_kernel.compiler.into_compiler(); + + // TODO: Only need to bring around the last constant map + for program in bootstrap + .pre_kernel_programs + .into_iter() + .map(SerializableRawProgramWithSymbols::into_raw_program) + { + vm.compiler.constant_map = program.constant_map.clone(); + vm.virtual_machine.constant_map = program.constant_map.clone(); + + vm.run_raw_program(program).unwrap(); + } + + log::debug!(target: "kernel", "Loaded prelude in the kernel!"); + + let sources = vm.sources.clone(); + + vm.register_fn("report-error!", move |error: SteelErr| { + raise_error(&sources, error); + }); + + // Now we're going to set up the top level environment + let mut kernel = Kernel::initialize_post_bootstrap(vm.clone()); + + kernel + .engine + .run_raw_program(bootstrap_kernel.kernel_source.into_raw_program()) + .unwrap(); + + vm.sources = bootstrap.sources; + vm.compiler = bootstrap.compiler.unwrap().into_compiler(); + vm.compiler.kernel = Some(kernel); + + for program in bootstrap + .post_kernel_programs + .into_iter() + .map(SerializableRawProgramWithSymbols::into_raw_program) + { + vm.compiler.constant_map = program.constant_map.clone(); + vm.virtual_machine.constant_map = program.constant_map.clone(); + + vm.run_raw_program(program).unwrap(); + } + + vm + } + fn create_bootstrap() { let mut vm = Engine { virtual_machine: SteelThread::new(), @@ -475,9 +631,7 @@ impl Engine { let bootstrap_sources = [ crate::steel_vm::primitives::ALL_MODULES, crate::stdlib::PRELUDE, - crate::stdlib::CONTRACTS, crate::stdlib::DISPLAY, - // crate::stdlib::KERNEL, ]; for source in bootstrap_sources { @@ -560,18 +714,6 @@ impl Engine { vm.compile_and_run_raw_program(crate::steel_vm::primitives::ALL_MODULES) .unwrap(); - #[cfg(feature = "dylibs")] - { - vm.dylibs.load_modules(); - - let modules = vm.dylibs.modules(); - - for module in modules { - vm.register_external_module(module).unwrap(); - // vm.register_module(module); - } - } - // vm.dylibs.load_modules(&mut vm); vm @@ -592,11 +734,7 @@ impl Engine { vm.compile_and_run_raw_program(crate::steel_vm::primitives::SANDBOXED_MODULES) .unwrap(); - let core_libraries = [ - crate::stdlib::PRELUDE, - crate::stdlib::CONTRACTS, - crate::stdlib::DISPLAY, - ]; + let core_libraries = [crate::stdlib::PRELUDE, crate::stdlib::DISPLAY]; for core in core_libraries.into_iter() { vm.compile_and_run_raw_program(core).unwrap(); @@ -607,7 +745,7 @@ impl Engine { /// Call the print method within the VM pub fn call_printing_method_in_context(&mut self, argument: SteelVal) -> Result { - let function = self.extract_value("println")?; + let function = self.extract_value("displayln")?; self.call_function_with_args(function, vec![argument]) } @@ -790,6 +928,27 @@ impl Engine { pub fn new() -> Self { let mut engine = fresh_kernel_image(); + // Touch the printer to initialize it + // install_printer(); + // engine.register_fn("print-in-engine", print_in_engine); + + engine.compiler.kernel = Some(Kernel::new()); + + engine + .run( + "(require \"#%private/steel/contract\" (for-syntax \"#%private/steel/contract\")) + (require \"#%private/steel/print\") + (require \"#%private/steel/control\" (for-syntax \"#%private/steel/control\")) + ", + ) + .unwrap(); + + engine + } + + pub(crate) fn new_printer() -> Self { + let mut engine = fresh_kernel_image(); + engine.compiler.kernel = Some(Kernel::new()); engine @@ -807,11 +966,7 @@ impl Engine { /// vm.run("(+ 1 2 3)").unwrap(); /// ``` pub fn with_prelude(mut self) -> Result { - let core_libraries = &[ - crate::stdlib::PRELUDE, - crate::stdlib::DISPLAY, - crate::stdlib::CONTRACTS, - ]; + let core_libraries = &[crate::stdlib::PRELUDE, crate::stdlib::DISPLAY]; for core in core_libraries { self.compile_and_run_raw_program(core)?; @@ -833,11 +988,7 @@ impl Engine { /// vm.run("(+ 1 2 3)").unwrap(); /// ``` pub fn register_prelude(&mut self) -> Result<&mut Self> { - let core_libraries = &[ - crate::stdlib::PRELUDE, - crate::stdlib::DISPLAY, - crate::stdlib::CONTRACTS, - ]; + let core_libraries = &[crate::stdlib::PRELUDE, crate::stdlib::DISPLAY]; for core in core_libraries { self.compile_and_run_raw_program(core)?; @@ -1039,7 +1190,7 @@ impl Engine { let result = program.build("TestProgram".to_string(), &mut self.compiler.symbol_map); if result.is_err() { - // println!("Rolling back symbol map"); + // panic!("Rolling back symbol map"); self.compiler.symbol_map.roll_back(symbol_map_offset); } @@ -1454,6 +1605,13 @@ impl Engine { pub fn in_scope_macros(&self) -> &HashMap { &self.compiler.macro_env } + + pub fn get_module(&self, path: PathBuf) -> Result { + let module_path = + "__module-mangler".to_string() + path.as_os_str().to_str().unwrap() + "__%#__"; + + self.extract_value(&module_path) + } } // #[cfg(test)] diff --git a/crates/steel-core/src/steel_vm/ffi.rs b/crates/steel-core/src/steel_vm/ffi.rs index 51275f49c..dcb4f55dc 100644 --- a/crates/steel-core/src/steel_vm/ffi.rs +++ b/crates/steel-core/src/steel_vm/ffi.rs @@ -10,7 +10,8 @@ use crate::{ gc::{unsafe_erased_pointers::OpaqueReference, Gc}, rerrs::ErrorKind, rvals::{ - as_underlying_type, Custom, CustomType, FutureResult, IntoSteelVal, Result, SRef, SteelVal, + as_underlying_type, Custom, CustomType, FutureResult, IntoSteelVal, Result, SRef, + SteelHashMap, SteelVal, }, values::functions::{BoxedDynFunction, StaticOrRcStr}, SteelErr, @@ -685,8 +686,8 @@ impl FFIValue { }) .collect::>>() .map(Gc::new) + .map(SteelHashMap::from) .map(SteelVal::HashMapV), - // FFIValue::Future { fut } => Ok(SteelVal::FutureV(Gc::new(Sharedfut.map(|x| { // match x { // RResult::ROk(v) => { @@ -737,6 +738,7 @@ impl IntoSteelVal for FFIValue { }) .collect::>>() .map(Gc::new) + .map(SteelHashMap::from) .map(SteelVal::HashMapV), // Attempt to move this across the FFI Boundary... We'll see how successful it is. diff --git a/crates/steel-core/src/steel_vm/meta.rs b/crates/steel-core/src/steel_vm/meta.rs index af3191944..203477f7d 100644 --- a/crates/steel-core/src/steel_vm/meta.rs +++ b/crates/steel-core/src/steel_vm/meta.rs @@ -4,7 +4,8 @@ use std::{cell::RefCell, convert::TryFrom, io::Write, rc::Rc}; -use im_lists::list::List; +// use im_lists::list::List; +use crate::values::lists::List; use crate::{ parser::ast::ExprKind, @@ -35,7 +36,7 @@ impl EngineWrapper { } // - pub(crate) fn modules(&self) -> List { + pub(crate) fn modules(&self) -> Vec { self.0 .modules() .iter() @@ -264,19 +265,21 @@ pub fn eval(program: String) -> List { DEFAULT_OUTPUT_PORT.with(|x| *x.borrow_mut() = SteelPort::default_current_output_port()); match res { - Ok(v) => im_lists::list![ + Ok(v) => vec![ SteelVal::ListV(v.into()), SteelVal::StringV(drain_custom_output_port().into()), - SteelVal::StringV("".into()) - ], + SteelVal::StringV("".into()), + ] + .into(), Err(e) => { let report = e.emit_result_to_string("input.stl", &program); - im_lists::list![ + vec![ SteelVal::ListV(List::new()), SteelVal::StringV(drain_custom_output_port().into()), - SteelVal::StringV(report.into()) + SteelVal::StringV(report.into()), ] + .into() // Err(e) } diff --git a/crates/steel-core/src/steel_vm/primitives.rs b/crates/steel-core/src/steel_vm/primitives.rs index f6e0371a0..682e486dc 100644 --- a/crates/steel-core/src/steel_vm/primitives.rs +++ b/crates/steel-core/src/steel_vm/primitives.rs @@ -9,9 +9,9 @@ use super::{ }; use crate::{ gc::Gc, - parser::span::Span, + parser::{interner::InternedString, span::Span}, primitives::{ - contracts, + fs_module, hashmaps::hashmap_module, hashmaps::{HM_CONSTRUCT, HM_GET, HM_INSERT}, hashsets::hashset_module, @@ -22,18 +22,23 @@ use crate::{ random::random_module, string_module, time::time_module, - ControlOperations, FsFunctions, IoFunctions, MetaOperations, NumOperations, - StreamOperations, SymbolOperations, VectorOperations, + ControlOperations, IoFunctions, MetaOperations, NumOperations, StreamOperations, + SymbolOperations, VectorOperations, }, rerrs::ErrorKind, - rvals::{FromSteelVal, NUMBER_EQUALITY_DEFINITION}, + rvals::{ + as_underlying_type, + cycles::{BreadthFirstSearchSteelValVisitor, SteelCycleCollector}, + FromSteelVal, ITERATOR_FINISHED, NUMBER_EQUALITY_DEFINITION, + }, steel_vm::{ builtin::{get_function_name, Arity}, vm::threads::threading_module, }, values::{ + closed::HeapRef, functions::{attach_contract_struct, get_contract, LambdaMetadataTable}, - structs::{build_type_id_module, make_struct_type}, + structs::{build_type_id_module, make_struct_type, UserDefinedStruct}, }, }; use crate::{ @@ -51,8 +56,10 @@ use crate::primitives::web::{requests::requests_module, websockets::websockets_m #[cfg(feature = "colors")] use crate::primitives::colors::string_coloring_module; -// use itertools::Itertools; +use crate::values::lists::List; +use im_rc::HashMap; use num::Signed; +use once_cell::sync::Lazy; macro_rules! ensure_tonicity_two { ($check_fn:expr) => {{ @@ -146,6 +153,7 @@ macro_rules! gen_pred { } const LIST: &str = "list"; +const PRIM_LIST: &str = "#%prim.list"; const CAR: &str = "car"; const CDR: &str = "cdr"; const CONS: &str = "cons"; @@ -170,56 +178,104 @@ const LIST_HUH: &str = "list?"; const BOOLEAN_HUH: &str = "boolean?"; const FUNCTION_HUH: &str = "function?"; +// TODO: Add the equivalent with prim in front pub const CONSTANTS: &[&str] = &[ "+", + "#%prim.+", "i+", + "#%prim.i+", "f+", + "#%prim.f+", "*", + "#%prim.*", "/", + "#%prim./", "-", + "#%prim.-", CAR, + "#%prim.car", CDR, + "#%prim.cdr", FIRST, + "#%prim.first", REST, + "#%prim.rest", RANGE, + "#%prim.range", NULL_HUH, + "#%prim.null?", INT_HUH, + "#%prim.int?", FLOAT_HUH, + "#%prim.float?", NUMBER_HUH, + "#%prim.number?", STRING_HUH, + "#%prim.string?", SYMBOL_HUH, + "#%prim.symbol?", VECTOR_HUH, + "#%prim.vector?", LIST_HUH, + "#%prim.list?", INTEGER_HUH, + "#%prim.integer?", BOOLEAN_HUH, + "#%prim.boolean?", FUNCTION_HUH, + "#%prim.function?", "=", + "#%prim.=", "equal?", + "#%prim.equal?", ">", + "#%prim.>", ">=", + "#%prim.>=", "<", + "#%prim.<", "<=", + "#%prim.<=", "string-append", + "#%prim.string-append", "string->list", + "#%prim.string->list", "string-upcase", + "#%prim.string-upcase", "string-lowercase", + "#%prim.string-lowercase", "trim", + "#%prim.trim", "trim-start", + "#%prim.trim-start", "trim-end", + "#%prim.trim-end", "split-whitespace", + "#%prim.split-whitespace", "void", + "#%prim.void", "list->string", + "#%prim.list->string", "concat-symbols", + "#%prim.concat-symbols", "string->int", + "#%prim.string->int", "even?", + "#%prim.even?", "odd", CONS, + "#%prim.cons", APPEND, + "#%prim.append", PUSH_BACK, LENGTH, + "#%prim.length", REVERSE, + "#%prim.reverse", LIST_TO_STRING, + "#%prim.list->string", LIST, + PRIM_LIST, ]; thread_local! { @@ -229,7 +285,7 @@ thread_local! { pub static STRING_MODULE: BuiltInModule = string_module(); pub static VECTOR_MODULE: BuiltInModule = vector_module(); pub static STREAM_MODULE: BuiltInModule = stream_module(); - pub static CONTRACT_MODULE: BuiltInModule = contract_module(); + // pub static CONTRACT_MODULE: BuiltInModule = contract_module(); pub static IDENTITY_MODULE: BuiltInModule = identity_module(); pub static NUMBER_MODULE: BuiltInModule = number_module(); pub static EQUALITY_MODULE: BuiltInModule = equality_module(); @@ -254,6 +310,9 @@ thread_local! { pub static TIME_MODULE: BuiltInModule = time_module(); pub static THREADING_MODULE: BuiltInModule = threading_module(); + pub static MUTABLE_HASH_MODULE: BuiltInModule = mutable_hashmap_module(); + pub static MUTABLE_VECTOR_MODULE: BuiltInModule = mutable_vector_module(); + #[cfg(feature = "web")] pub static WEBSOCKETS_MODULE: BuiltInModule = websockets_module(); @@ -278,7 +337,7 @@ pub fn prelude() -> BuiltInModule { .with_module(STRING_MODULE.with(|x| x.clone())) .with_module(VECTOR_MODULE.with(|x| x.clone())) .with_module(STREAM_MODULE.with(|x| x.clone())) - .with_module(CONTRACT_MODULE.with(|x| x.clone())) + // .with_module(CONTRACT_MODULE.with(|x| x.clone())) .with_module(IDENTITY_MODULE.with(|x| x.clone())) .with_module(NUMBER_MODULE.with(|x| x.clone())) .with_module(EQUALITY_MODULE.with(|x| x.clone())) @@ -304,6 +363,8 @@ pub fn register_builtin_modules_without_io(engine: &mut Engine) { engine.register_fn("##__module-get", BuiltInModule::get); engine.register_fn("%module-get%", BuiltInModule::get); + engine.register_fn("load-from-module!", BuiltInModule::get); + engine.register_value("%proto-hash%", HM_CONSTRUCT); engine.register_value("%proto-hash-insert%", HM_INSERT); engine.register_value("%proto-hash-get%", HM_GET); @@ -318,7 +379,7 @@ pub fn register_builtin_modules_without_io(engine: &mut Engine) { .register_module(STRING_MODULE.with(|x| x.clone())) .register_module(VECTOR_MODULE.with(|x| x.clone())) .register_module(STREAM_MODULE.with(|x| x.clone())) - .register_module(CONTRACT_MODULE.with(|x| x.clone())) + // .register_module(CONTRACT_MODULE.with(|x| x.clone())) .register_module(IDENTITY_MODULE.with(|x| x.clone())) .register_module(NUMBER_MODULE.with(|x| x.clone())) .register_module(EQUALITY_MODULE.with(|x| x.clone())) @@ -344,8 +405,13 @@ fn render_as_md(text: String) { } pub fn register_builtin_modules(engine: &mut Engine) { + engine.register_value("std::env::args", SteelVal::ListV(List::new())); + engine.register_fn("##__module-get", BuiltInModule::get); engine.register_fn("%module-get%", BuiltInModule::get); + + engine.register_fn("load-from-module!", BuiltInModule::get); + engine.register_fn("%doc?", BuiltInModule::get_doc); // engine.register_fn("%module-docs", BuiltInModule::docs); engine.register_value("%list-modules!", SteelVal::BuiltIn(list_modules)); @@ -376,7 +442,7 @@ pub fn register_builtin_modules(engine: &mut Engine) { .register_module(STRING_MODULE.with(|x| x.clone())) .register_module(VECTOR_MODULE.with(|x| x.clone())) .register_module(STREAM_MODULE.with(|x| x.clone())) - .register_module(CONTRACT_MODULE.with(|x| x.clone())) + // .register_module(CONTRACT_MODULE.with(|x| x.clone())) .register_module(IDENTITY_MODULE.with(|x| x.clone())) .register_module(NUMBER_MODULE.with(|x| x.clone())) .register_module(EQUALITY_MODULE.with(|x| x.clone())) @@ -399,6 +465,10 @@ pub fn register_builtin_modules(engine: &mut Engine) { .register_module(RANDOM_MODULE.with(|x| x.clone())) .register_module(THREADING_MODULE.with(|x| x.clone())); + // Private module + engine.register_module(MUTABLE_HASH_MODULE.with(|x| x.clone())); + engine.register_module(MUTABLE_VECTOR_MODULE.with(|x| x.clone())); + #[cfg(feature = "colors")] engine.register_module(STRING_COLORS_MODULE.with(|x| x.clone())); @@ -414,6 +484,36 @@ pub fn register_builtin_modules(engine: &mut Engine) { engine.register_module(BLOCKING_REQUESTS_MODULE.with(|x| x.clone())); } +pub static MODULE_IDENTIFIERS: Lazy> = Lazy::new(|| { + let mut set = fxhash::FxHashSet::default(); + + // TODO: Consolidate the prefixes and module names into one spot + set.insert("%-builtin-module-steel/hash".into()); + set.insert("%-builtin-module-steel/sets".into()); + set.insert("%-builtin-module-steel/lists".into()); + set.insert("%-builtin-module-steel/strings".into()); + set.insert("%-builtin-module-steel/vectors".into()); + set.insert("%-builtin-module-steel/streams".into()); + set.insert("%-builtin-module-steel/identity".into()); + set.insert("%-builtin-module-steel/numbers".into()); + set.insert("%-builtin-module-steel/equality".into()); + set.insert("%-builtin-module-steel/ord".into()); + set.insert("%-builtin-module-steel/transducers".into()); + set.insert("%-builtin-module-steel/io".into()); + set.insert("%-builtin-module-steel/filesystem".into()); + set.insert("%-builtin-module-steel/ports".into()); + set.insert("%-builtin-module-steel/meta".into()); + set.insert("%-builtin-module-steel/constants".into()); + set.insert("%-builtin-module-steel/syntax".into()); + set.insert("%-builtin-module-steel/process".into()); + set.insert("%-builtin-module-steel/core/result".into()); + set.insert("%-builtin-module-steel/core/option".into()); + set.insert("%-builtin-module-steel/threads".into()); + set.insert("%-builtin-module-steel/base".into()); + + set +}); + pub static ALL_MODULES: &str = r#" (require-builtin steel/hash) (require-builtin steel/sets) @@ -422,7 +522,6 @@ pub static ALL_MODULES: &str = r#" (require-builtin steel/symbols) (require-builtin steel/vectors) (require-builtin steel/streams) - (require-builtin steel/contracts) (require-builtin steel/identity) (require-builtin steel/numbers) (require-builtin steel/equality) @@ -440,6 +539,60 @@ pub static ALL_MODULES: &str = r#" (require-builtin steel/core/option) (require-builtin steel/core/types) (require-builtin steel/threads) + + + (require-builtin steel/hash as #%prim.) + (require-builtin steel/sets as #%prim.) + (require-builtin steel/lists as #%prim.) + (require-builtin steel/strings as #%prim.) + (require-builtin steel/symbols as #%prim.) + (require-builtin steel/vectors as #%prim.) + (require-builtin steel/streams as #%prim.) + (require-builtin steel/identity as #%prim.) + (require-builtin steel/numbers as #%prim.) + (require-builtin steel/equality as #%prim.) + (require-builtin steel/ord as #%prim.) + (require-builtin steel/transducers as #%prim.) + (require-builtin steel/io as #%prim.) + (require-builtin steel/filesystem as #%prim.) + (require-builtin steel/ports as #%prim.) + (require-builtin steel/meta as #%prim.) + (require-builtin steel/json as #%prim.) + (require-builtin steel/constants as #%prim.) + (require-builtin steel/syntax as #%prim.) + (require-builtin steel/process as #%prim.) + (require-builtin steel/core/result as #%prim.) + (require-builtin steel/core/option as #%prim.) + (require-builtin steel/core/types as #%prim.) + (require-builtin steel/threads as #%prim.) + +"#; + +pub static ALL_MODULES_RESERVED: &str = r#" + (require-builtin steel/hash as #%prim.) + (require-builtin steel/sets as #%prim.) + (require-builtin steel/lists as #%prim.) + (require-builtin steel/strings as #%prim.) + (require-builtin steel/symbols as #%prim.) + (require-builtin steel/vectors as #%prim.) + (require-builtin steel/streams as #%prim.) + (require-builtin steel/identity as #%prim.) + (require-builtin steel/numbers as #%prim.) + (require-builtin steel/equality as #%prim.) + (require-builtin steel/ord as #%prim.) + (require-builtin steel/transducers as #%prim.) + (require-builtin steel/io as #%prim.) + (require-builtin steel/filesystem as #%prim.) + (require-builtin steel/ports as #%prim.) + (require-builtin steel/meta as #%prim.) + (require-builtin steel/json as #%prim.) + (require-builtin steel/constants as #%prim.) + (require-builtin steel/syntax as #%prim.) + (require-builtin steel/process as #%prim.) + (require-builtin steel/core/result as #%prim.) + (require-builtin steel/core/option as #%prim.) + (require-builtin steel/core/types as #%prim.) + (require-builtin steel/threads as #%prim.) "#; pub static SANDBOXED_MODULES: &str = r#" @@ -450,7 +603,6 @@ pub static SANDBOXED_MODULES: &str = r#" (require-builtin steel/symbols) (require-builtin steel/vectors) (require-builtin steel/streams) - (require-builtin steel/contracts) (require-builtin steel/identity) (require-builtin steel/numbers) (require-builtin steel/equality) @@ -535,6 +687,11 @@ fn hashp(value: &SteelVal) -> bool { matches!(value, SteelVal::HashMapV(_)) } +#[steel_derive::function(name = "set?", constant = true)] +fn hashsetp(value: &SteelVal) -> bool { + matches!(value, SteelVal::HashSetV(_)) +} + #[steel_derive::function(name = "continuation?", constant = true)] fn continuationp(value: &SteelVal) -> bool { matches!(value, SteelVal::ContinuationFunction(_)) @@ -555,13 +712,27 @@ fn voidp(value: &SteelVal) -> bool { matches!(value, SteelVal::Void) } +#[steel_derive::function(name = "struct?", constant = true)] +fn structp(value: &SteelVal) -> bool { + if let SteelVal::CustomStruct(s) = value { + s.is_transparent() + } else { + false + } +} + +#[steel_derive::function(name = "#%private-struct?", constant = true)] +fn private_structp(value: &SteelVal) -> bool { + matches!(value, SteelVal::CustomStruct(_)) +} + #[steel_derive::function(name = "function?", constant = true)] fn functionp(value: &SteelVal) -> bool { matches!( value, SteelVal::Closure(_) | SteelVal::FuncV(_) - | SteelVal::ContractedFunction(_) + // | SteelVal::ContractedFunction(_) | SteelVal::BoxedFunction(_) | SteelVal::ContinuationFunction(_) | SteelVal::MutFunc(_) @@ -575,7 +746,7 @@ fn procedurep(value: &SteelVal) -> bool { value, SteelVal::Closure(_) | SteelVal::FuncV(_) - | SteelVal::ContractedFunction(_) + // | SteelVal::ContractedFunction(_) | SteelVal::BoxedFunction(_) | SteelVal::ContinuationFunction(_) | SteelVal::MutFunc(_) @@ -596,10 +767,13 @@ fn identity_module() -> BuiltInModule { .register_native_fn_definition(VECTORP_DEFINITION) .register_native_fn_definition(SYMBOLP_DEFINITION) .register_native_fn_definition(HASHP_DEFINITION) + .register_native_fn_definition(HASHSETP_DEFINITION) .register_native_fn_definition(CONTINUATIONP_DEFINITION) .register_native_fn_definition(BOOLEANP_DEFINITION) .register_native_fn_definition(BOOLP_DEFINITION) .register_native_fn_definition(VOIDP_DEFINITION) + .register_native_fn_definition(STRUCTP_DEFINITION) + .register_native_fn_definition(PRIVATE_STRUCTP_DEFINITION) .register_value("mutable-vector?", gen_pred!(MutableVector)) .register_value("char?", gen_pred!(CharV)) .register_value("future?", gen_pred!(FutureV)) @@ -623,20 +797,20 @@ fn stream_module() -> BuiltInModule { module } -fn contract_module() -> BuiltInModule { - let mut module = BuiltInModule::new("steel/contracts"); - module - .register_value("bind/c", contracts::BIND_CONTRACT_TO_FUNCTION) - .register_value("make-flat/c", contracts::MAKE_FLAT_CONTRACT) - .register_value( - "make-dependent-function/c", - contracts::MAKE_DEPENDENT_CONTRACT, - ) - .register_value("make-function/c", contracts::MAKE_FUNCTION_CONTRACT) - .register_value("make/c", contracts::MAKE_C); - - module -} +// fn contract_module() -> BuiltInModule { +// let mut module = BuiltInModule::new("steel/contracts"); +// module +// .register_value("bind/c", contracts::BIND_CONTRACT_TO_FUNCTION) +// .register_value("make-flat/c", contracts::MAKE_FLAT_CONTRACT) +// .register_value( +// "make-dependent-function/c", +// contracts::MAKE_DEPENDENT_CONTRACT, +// ) +// .register_value("make-function/c", contracts::MAKE_FUNCTION_CONTRACT) +// .register_value("make/c", contracts::MAKE_C); + +// module +// } #[steel_derive::function(name = "abs", constant = true)] fn abs(number: &SteelVal) -> Result { @@ -816,6 +990,8 @@ fn io_module() -> BuiltInModule { module .register_value("display", IoFunctions::display()) .register_value("displayln", IoFunctions::displayln()) + .register_value("simple-display", IoFunctions::display()) + .register_value("simple-displayln", IoFunctions::displayln()) .register_value("newline", IoFunctions::newline()) .register_value("read-to-string", IoFunctions::read_to_string()); @@ -841,28 +1017,6 @@ fn constants_module() -> BuiltInModule { module } -fn fs_module() -> BuiltInModule { - let mut module = BuiltInModule::new("steel/filesystem"); - module - .register_value("is-dir?", FsFunctions::is_dir()) - .register_value("is-file?", FsFunctions::is_file()) - .register_value("read-dir", FsFunctions::read_dir()) - .register_value("path-exists?", FsFunctions::path_exists()) - .register_value( - "copy-directory-recursively!", - FsFunctions::copy_directory_recursively(), - ) - .register_value("delete-directory!", FsFunctions::delete_directory()) - .register_value("create-directory!", FsFunctions::create_dir_all()) - .register_value("file-name", FsFunctions::file_name()) - .register_value("current-directory", FsFunctions::current_dir()) - .register_value( - "path->extension", - SteelVal::FuncV(FsFunctions::get_extension), - ); - module -} - fn get_environment_variable(var: String) -> Result { std::env::var(var) .map(|x| x.into_steelval().unwrap()) @@ -913,15 +1067,15 @@ fn arity(value: SteelVal) -> UnRecoverableResult { // Ok(SteelVal::IntV(c.arity() as isize)).into() if let Some(SteelVal::CustomStruct(s)) = c.get_contract_information() { - let guard = s.borrow(); - if guard.name.resolve() == "FunctionContract" { + let guard = s; + if guard.name().resolve() == "FunctionContract" { if let SteelVal::ListV(l) = &guard.fields[0] { Ok(SteelVal::IntV(l.len() as isize)).into() } else { steelerr!(TypeMismatch => "Unable to find the arity for the given function") .into() } - } else if guard.name.resolve() == "FlatContract" { + } else if guard.name().resolve() == "FlatContract" { Ok(SteelVal::IntV(1)).into() } else { // This really shouldn't happen @@ -968,6 +1122,152 @@ fn is_multi_arity(value: SteelVal) -> UnRecoverableResult { } } +struct MutableVector { + vector: Vec, +} + +impl MutableVector { + fn new() -> Self { + Self { vector: Vec::new() } + } + + fn vector_push(&mut self, value: SteelVal) { + self.vector.push(value); + } + + fn vector_pop(&mut self) -> Option { + self.vector.pop() + } + + fn vector_set(&mut self, index: usize, value: SteelVal) { + self.vector[index] = value; + } + + fn vector_ref(&self, index: usize) -> SteelVal { + self.vector[index].clone() + } + + fn vector_len(&self) -> usize { + self.vector.len() + } + + fn vector_to_list(&self) -> SteelVal { + SteelVal::ListV(self.vector.clone().into()) + } + + fn vector_is_empty(&self) -> bool { + self.vector.is_empty() + } + + fn vector_from_list(lst: List) -> Self { + Self { + vector: lst.into_iter().collect(), + } + } +} + +impl crate::rvals::Custom for MutableVector { + fn gc_visit_children(&self, context: &mut crate::values::closed::MarkAndSweepContext) { + for value in &self.vector { + context.push_back(value.clone()); + } + } + + fn visit_equality(&self, visitor: &mut crate::rvals::cycles::EqualityVisitor) { + for value in &self.vector { + visitor.push_back(value.clone()); + } + } + + // Compare the two for equality otherwise + fn equality_hint(&self, other: &dyn crate::rvals::CustomType) -> bool { + if let Some(other) = as_underlying_type::(other) { + self.vector.len() == other.vector.len() + } else { + false + } + } +} + +struct MutableHashTable { + table: HashMap, +} + +impl crate::rvals::Custom for MutableHashTable { + fn gc_visit_children(&self, context: &mut crate::values::closed::MarkAndSweepContext) { + for (key, value) in &self.table { + context.push_back(key.clone()); + context.push_back(value.clone()); + } + } +} + +impl MutableHashTable { + pub fn new() -> Self { + Self { + table: HashMap::new(), + } + } + + pub fn insert(&mut self, key: SteelVal, value: SteelVal) { + self.table.insert(key, value); + } + + pub fn get(&self, key: SteelVal) -> Option { + self.table.get(&key).cloned() + } +} + +fn mutable_vector_module() -> BuiltInModule { + let mut module = BuiltInModule::new("#%private/steel/mvector"); + + module + .register_fn("make-mutable-vector", MutableVector::new) + .register_fn("mutable-vector-ref", MutableVector::vector_ref) + .register_fn("mutable-vector-set!", MutableVector::vector_set) + .register_fn("mutable-vector-pop!", MutableVector::vector_pop) + .register_fn("mutable-vector-push!", MutableVector::vector_push) + .register_fn("mutable-vector-len", MutableVector::vector_len) + .register_fn("mutable-vector->list", MutableVector::vector_to_list) + .register_fn("mutable-vector-empty?", MutableVector::vector_is_empty) + .register_fn("mutable-vector-from-list", MutableVector::vector_from_list); + + module +} + +fn mutable_hashmap_module() -> BuiltInModule { + let mut module = BuiltInModule::new("#%private/steel/mhash"); + + module + .register_fn("mhash", MutableHashTable::new) + .register_fn("mhash-set!", MutableHashTable::insert) + .register_fn("mhash-ref", MutableHashTable::get); + + module +} + +#[steel_derive::function(name = "#%unbox")] +fn unbox_mutable(value: &HeapRef) -> SteelVal { + value.get() +} + +#[steel_derive::function(name = "#%set-box!")] +fn set_box_mutable(value: &HeapRef, update: SteelVal) -> SteelVal { + value.set_and_return(update) +} + +// TODO: Handle arity issues!!! +fn make_mutable_box(ctx: &mut VmCore, args: &[SteelVal]) -> Option> { + let allocated_var = ctx.thread.heap.allocate( + args[0].clone(), // TODO: Could actually move off of the stack entirely + ctx.thread.stack.iter(), + ctx.thread.stack_frames.iter().map(|x| x.function.as_ref()), + ctx.thread.global_env.roots(), + ); + + Some(Ok(SteelVal::HeapAllocated(allocated_var))) +} + #[steel_derive::function(name = "unbox")] fn unbox(value: &Gc>) -> SteelVal { value.borrow().clone() @@ -981,12 +1281,19 @@ fn set_box(value: &Gc>, update_to: SteelVal) { fn meta_module() -> BuiltInModule { let mut module = BuiltInModule::new("steel/meta"); module + .register_fn("#%black-box", || {}) .register_value( "#%function-ptr-table", LambdaMetadataTable::new().into_steelval().unwrap(), ) .register_fn("#%function-ptr-table-add", LambdaMetadataTable::add) .register_fn("#%function-ptr-table-get", LambdaMetadataTable::get) + .register_fn("#%private-cycle-collector", SteelCycleCollector::from_root) + .register_fn("#%private-cycle-collector-get", SteelCycleCollector::get) + .register_fn( + "#%private-cycle-collector-values", + SteelCycleCollector::values, + ) .register_value("assert!", MetaOperations::assert_truthy()) .register_value("active-object-count", MetaOperations::active_objects()) .register_value("inspect-bytecode", MetaOperations::inspect_bytecode()) @@ -995,6 +1302,10 @@ fn meta_module() -> BuiltInModule { .register_value("poll!", MetaOperations::poll_value()) .register_value("block-on", MetaOperations::block_on()) .register_value("join!", MetaOperations::join_futures()) + .register_fn( + "#%struct-property-ref", + |value: &UserDefinedStruct, key: SteelVal| UserDefinedStruct::get(value, &key), + ) // .register_value("struct-ref", struct_ref()) // .register_value("struct->list", struct_to_list()) // .register_value("struct->vector", struct_to_vector()) @@ -1012,6 +1323,7 @@ fn meta_module() -> BuiltInModule { "call-with-exception-handler", SteelVal::BuiltIn(super::vm::call_with_exception_handler), ) + .register_value("breakpoint!", SteelVal::BuiltIn(super::vm::breakpoint)) .register_value( "call-with-current-continuation", SteelVal::BuiltIn(super::vm::call_cc), @@ -1032,6 +1344,8 @@ fn meta_module() -> BuiltInModule { // .register_fn("get-value", super::meta::EngineWrapper::get_value) .register_fn("value->iterator", crate::rvals::value_into_iterator) .register_value("iter-next!", SteelVal::FuncV(crate::rvals::iterator_next)) + // Check whether the iterator is done + .register_value("#%iterator-finished", ITERATOR_FINISHED.with(|x| x.clone())) .register_value("%iterator?", gen_pred!(BoxedIterator)) .register_fn("env-var", get_environment_variable) .register_fn("set-env-var!", std::env::set_var::) @@ -1049,6 +1363,10 @@ fn meta_module() -> BuiltInModule { .register_fn("box", SteelVal::boxed) .register_native_fn_definition(UNBOX_DEFINITION) .register_native_fn_definition(SET_BOX_DEFINITION) + .register_value("#%box", SteelVal::BuiltIn(make_mutable_box)) + // TODO: Deprecate these at some point + .register_native_fn_definition(SET_BOX_MUTABLE_DEFINITION) + .register_native_fn_definition(UNBOX_MUTABLE_DEFINITION) // .register_fn("unbox", |value: SteelVal| ) .register_value( "attach-contract-struct!", @@ -1056,6 +1374,10 @@ fn meta_module() -> BuiltInModule { ) .register_value("get-contract-struct", SteelVal::FuncV(get_contract)) .register_fn("current-os!", || std::env::consts::OS); + + #[cfg(feature = "dylibs")] + module.register_native_fn_definition(crate::steel_vm::dylib::LOAD_MODULE_DEFINITION); + module } diff --git a/crates/steel-core/src/steel_vm/register_fn.rs b/crates/steel-core/src/steel_vm/register_fn.rs index 6eda66831..1439330aa 100644 --- a/crates/steel-core/src/steel_vm/register_fn.rs +++ b/crates/steel-core/src/steel_vm/register_fn.rs @@ -6,6 +6,7 @@ use super::{ builtin::{Arity, FunctionSignatureMetadata}, engine::Engine, }; +use crate::values::lists::List; use crate::{ gc::unsafe_erased_pointers::{ BorrowedObject, OpaqueReferenceNursery, ReadOnlyBorrowedObject, ReadOnlyTemporary, @@ -26,7 +27,6 @@ use crate::{ values::functions::BoxedDynFunction, }; use futures_util::FutureExt; -use im_lists::list::List; use crate::containers::RegisterValue; @@ -187,7 +187,7 @@ impl RET + SendS let f = move |args: &[SteelVal]| -> Result { if args.len() != 1 { - stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 0, args.len())); + stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 1, args.len())); } let mut input = ::as_mut_ref(&args[0])?; @@ -219,7 +219,7 @@ impl< let f = move |args: &[SteelVal]| -> Result { if args.len() != 1 { - stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 0, args.len())); + stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 1, args.len())); } let mut input = ::as_mut_ref_from_ref(&args[0])?; @@ -377,7 +377,7 @@ impl< fn register_fn(&mut self, name: &'static str, func: FN) -> &mut Self { let f = move |args: &[SteelVal]| -> Result { if args.len() != 4 { - stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 3, args.len())); + stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 4, args.len())); } let mut input = ::as_mut_ref(&args[0])?; @@ -413,7 +413,7 @@ impl< fn register_fn(&mut self, name: &'static str, func: FN) -> &mut Self { let f = move |args: &[SteelVal]| -> Result { if args.len() != 4 { - stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 3, args.len())); + stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 4, args.len())); } let mut input = ::as_mut_ref(&args[0])?; @@ -523,7 +523,7 @@ impl< let f = move |args: &[SteelVal]| -> Result { if args.len() != 3 { - stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 0, args.len())); + stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 3, args.len())); } let mut input = ::as_mut_ref_from_ref(&args[0])?; @@ -556,7 +556,7 @@ impl< let f = move |args: &[SteelVal]| -> Result { if args.len() != 3 { - stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 0, args.len())); + stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, 3, args.len())); } let mut input = ::as_mut_ref_from_ref(&args[0])?; @@ -2169,5 +2169,5 @@ mod generated_impls { } // TODO: Come up with better MarkerWrapper(PhantomData); -> This is gonna be nasty. - include!(concat!(env!("OUT_DIR"), "/generated.rs")); + // include!(concat!(env!("OUT_DIR"), "/generated.rs")); } diff --git a/crates/steel-core/src/steel_vm/test_util.rs b/crates/steel-core/src/steel_vm/test_util.rs index 540061e1d..95cda4792 100644 --- a/crates/steel-core/src/steel_vm/test_util.rs +++ b/crates/steel-core/src/steel_vm/test_util.rs @@ -1,5 +1,5 @@ use super::engine::Engine; -use crate::stdlib::{CONTRACTS, PRELUDE}; +use crate::stdlib::PRELUDE; #[test] fn prelude_parses() { @@ -7,13 +7,6 @@ fn prelude_parses() { vm.compile_and_run_raw_program(PRELUDE).unwrap(); } -#[test] -fn contract_parses() { - let mut vm = Engine::new(); - vm.compile_and_run_raw_program(PRELUDE).unwrap(); - vm.compile_and_run_raw_program(CONTRACTS).unwrap(); -} - #[cfg(test)] fn generate_asserting_machine() -> Engine { // vm.compile_and_run_raw_program(PRELUDE).unwrap(); diff --git a/crates/steel-core/src/steel_vm/transducers.rs b/crates/steel-core/src/steel_vm/transducers.rs index 129af9448..22a40ab06 100644 --- a/crates/steel-core/src/steel_vm/transducers.rs +++ b/crates/steel-core/src/steel_vm/transducers.rs @@ -1,4 +1,5 @@ -use im_lists::list::List; +// use im_lists::list::List; +use crate::values::lists::List; // use itertools::Itertools; // use super::{evaluation_progress::EvaluationProgress, stack::StackFrame, vm::VmCore}; @@ -207,12 +208,12 @@ impl<'global, 'a> VmCore<'a> { SteelVal::HashSetV(hs) => Ok(Box::new(hs.iter().cloned().map(Ok))), SteelVal::HashMapV(hm) => { Ok(Box::new(hm.iter().map(|x| { - Ok(SteelVal::ListV(im_lists::list![x.0.clone(), x.1.clone()])) + Ok(SteelVal::ListV(vec![x.0.clone(), x.1.clone()].into())) }))) } SteelVal::MutableVector(v) => { // Copy over the mutable vector into the nursery - *nursery = Some(v.borrow().clone()); + *nursery = Some(v.get().clone()); Ok(Box::new(nursery.as_ref().unwrap().iter().cloned().map(Ok))) } @@ -297,7 +298,7 @@ impl<'global, 'a> VmCore<'a> { Ok(x) => { match x { SteelVal::VectorV(v) => { - Box::new(v.unwrap().into_iter().map(Ok)) + Box::new(v.0.unwrap().into_iter().map(Ok)) } // TODO this needs to be fixed SteelVal::StringV(s) => Box::new( @@ -337,7 +338,7 @@ impl<'global, 'a> VmCore<'a> { Ok(x) => { match x { SteelVal::VectorV(v) => { - Box::new(v.unwrap().into_iter().map(Ok)) + Box::new(v.0.unwrap().into_iter().map(Ok)) } // TODO this needs to be fixed SteelVal::StringV(s) => Box::new( @@ -377,7 +378,7 @@ impl<'global, 'a> VmCore<'a> { Transducers::Extend(collection) => { let extender: Box>> = match collection.clone() { - SteelVal::VectorV(v) => Box::new(v.unwrap().into_iter().map(Ok)), + SteelVal::VectorV(v) => Box::new(v.0.unwrap().into_iter().map(Ok)), // TODO this needs to be fixed SteelVal::StringV(s) => Box::new( s.chars() @@ -406,15 +407,14 @@ impl<'global, 'a> VmCore<'a> { Transducers::Take(num) => generate_take!(iter, num, cur_inst_span), Transducers::Drop(num) => generate_drop!(iter, num, cur_inst_span), Transducers::Enumerating => Box::new(iter.enumerate().map(|x| { - Ok(SteelVal::ListV(im_lists::list!( - SteelVal::IntV(x.0 as isize), - x.1? - ))) + Ok(SteelVal::ListV( + vec![SteelVal::IntV(x.0 as isize), x.1?].into(), + )) })), Transducers::Zipping(collection) => { let zipped: Box>> = match collection.clone() { - SteelVal::VectorV(v) => Box::new(v.unwrap().into_iter().map(Ok)), + SteelVal::VectorV(v) => Box::new(v.0.unwrap().into_iter().map(Ok)), // TODO this needs to be fixed SteelVal::StringV(s) => Box::new( s.chars() @@ -436,13 +436,13 @@ impl<'global, 'a> VmCore<'a> { }; Box::new( iter.zip(zipped) - .map(|x| Ok(SteelVal::ListV(im_lists::list!(x.0?, x.1?)))), + .map(|x| Ok(SteelVal::ListV(vec![x.0?, x.1?].into()))), ) } Transducers::Interleaving(collection) => { let other: Box>> = match collection.clone() { - SteelVal::VectorV(v) => Box::new(v.unwrap().into_iter().map(Ok)), + SteelVal::VectorV(v) => Box::new(v.0.unwrap().into_iter().map(Ok)), // TODO this needs to be fixed SteelVal::StringV(s) => Box::new( s.chars() @@ -525,7 +525,7 @@ impl<'global, 'a> VmCore<'a> { } SteelVal::VectorV(l) => { if l.len() != 2 { - stop!(Generic => format!("Hashmap iterator expects an iterable with two elements, found: {l:?}")); + stop!(Generic => format!("Hashmap iterator expects an iterable with two elements, found: {:?}", &l.0)); } else { let mut iter = l.iter(); Ok((iter.next().cloned().unwrap(), iter.next().cloned().unwrap())) @@ -535,9 +535,9 @@ impl<'global, 'a> VmCore<'a> { stop!(TypeMismatch => format!("Unable to convert: {other} to pair that can be used to construct a hashmap")); } } - }).collect::>>().map(|x| SteelVal::HashMapV(Gc::new(x))) + }).collect::>>().map(|x| SteelVal::HashMapV(Gc::new(x).into())) }, - Reducer::HashSet => iter.collect::>>().map(|x| SteelVal::HashSetV(Gc::new(x))), + Reducer::HashSet => iter.collect::>>().map(|x| SteelVal::HashSetV(Gc::new(x).into())), Reducer::String => todo!(), Reducer::Last => iter.last().unwrap_or_else(|| stop!(Generic => "`last` found empty list - `last` requires at least one element in the sequence")), Reducer::ForEach(f) => { diff --git a/crates/steel-core/src/steel_vm/vm.rs b/crates/steel-core/src/steel_vm/vm.rs index fee146e68..7c13763d7 100644 --- a/crates/steel-core/src/steel_vm/vm.rs +++ b/crates/steel-core/src/steel_vm/vm.rs @@ -1,14 +1,16 @@ #![allow(unused)] +use crate::primitives::lists::cons; +use crate::primitives::lists::new as new_list; use crate::primitives::nums::special_add; +use crate::values::closed::Heap; use crate::values::functions::SerializedLambda; use crate::values::structs::UserDefinedStruct; -use crate::values::{closed::Heap, contracts::ContractType}; use crate::{ compiler::constants::ConstantMap, core::{instructions::DenseInstruction, opcode::OpCode}, rvals::FutureResult, - values::contracts::ContractedFunction, + // values::contracts::ContractedFunction, }; use crate::{ compiler::program::Executable, @@ -32,7 +34,7 @@ use std::{cell::RefCell, collections::HashMap, iter::Iterator, rc::Rc}; use super::builtin::DocTemplate; -use im_lists::list::List; +use crate::values::lists::List; #[cfg(feature = "profiling")] use log::{debug, log_enabled}; @@ -77,6 +79,8 @@ pub fn unlikely(b: bool) -> bool { const STACK_LIMIT: usize = 1000000; const _JIT_THRESHOLD: usize = 100; +const USE_SUPER_INSTRUCTIONS: bool = false; + #[repr(C)] #[derive(Clone, Debug, Copy, PartialEq)] pub struct DehydratedCallContext { @@ -253,6 +257,7 @@ pub struct SteelThread { profiler: OpCodeOccurenceProfiler, function_interner: FunctionInterner, super_instructions: Vec>, + pub(crate) heap: Heap, // If contracts are set to off - contract construction results in a no-op, // so we don't need generics on the thread @@ -316,6 +321,7 @@ impl SteelThread { profiler: OpCodeOccurenceProfiler::new(), function_interner: FunctionInterner::default(), super_instructions: Vec::new(), + heap: Heap::new(), runtime_options: RunTimeOptions::new(), stack_frames: Vec::with_capacity(128), @@ -549,6 +555,12 @@ impl SteelThread { // self.profiler.sample_count // ); + // panic!("GETTING HERE") + + // println!("GETTING HERE"); + + // while self.stack.pop().is_some() {} + // Clean up self.stack.clear(); @@ -561,6 +573,8 @@ impl SteelThread { ); }; + // println!("FINISHED"); + return result; } } @@ -579,7 +593,7 @@ impl SteelThread { #[derive(Clone, Debug)] pub struct Continuation { pub(crate) stack: Vec, - current_frame: StackFrame, + pub(crate) current_frame: StackFrame, instructions: Rc<[DenseInstruction]>, pub(crate) stack_frames: Vec, ip: usize, @@ -729,7 +743,7 @@ impl DynamicBlock { let mut header_func = None; - println!("{basic_block:#?}"); + log::debug!(target: "super-instructions", "{basic_block:#?}"); if let Some(first) = handlers.peek() { header_func = op_code_requires_payload(first.0); @@ -829,6 +843,37 @@ impl<'a> VmCore<'a> { }) } + pub fn make_box(&mut self, value: SteelVal) -> SteelVal { + let allocated_var = self.thread.heap.allocate( + value, + self.thread.stack.iter(), + self.thread.stack_frames.iter().map(|x| x.function.as_ref()), + self.thread.global_env.roots(), + ); + + SteelVal::HeapAllocated(allocated_var) + } + + pub fn make_mutable_vector(&mut self, values: Vec) -> SteelVal { + let allocated_var = self.thread.heap.allocate_vector( + values, + self.thread.stack.iter(), + self.thread.stack_frames.iter().map(|x| x.function.as_ref()), + self.thread.global_env.roots(), + ); + + SteelVal::MutableVector(allocated_var) + } + + fn gc_collect(&mut self) { + self.thread.heap.collect( + None, + self.thread.stack.iter(), + self.thread.stack_frames.iter().map(|x| x.function.as_ref()), + self.thread.global_env.roots(), + ); + } + // #[inline(always)] fn new_continuation_from_state(&self) -> Continuation { Continuation { @@ -843,6 +888,19 @@ impl<'a> VmCore<'a> { } } + // Grab the continuation - but this continuation can only be played once + fn new_oneshot_continuation_from_state(&mut self) -> Continuation { + Continuation { + stack: std::mem::take(&mut self.thread.stack), + instructions: Rc::clone(&self.instructions), + current_frame: self.thread.current_frame.clone(), + stack_frames: std::mem::take(&mut self.thread.stack_frames), + ip: self.ip, + sp: self.sp, + pop_count: self.pop_count, + } + } + pub fn snapshot_stack_trace(&self) -> DehydratedStackTrace { DehydratedStackTrace::new( self.thread @@ -880,6 +938,10 @@ impl<'a> VmCore<'a> { SteelVal::ContinuationFunction(Gc::new(captured_continuation)) } + fn construct_oneshot_continuation_function(&self) -> SteelVal { + todo!() + } + // Reset state FULLY fn call_with_instructions_and_reset_state( &mut self, @@ -939,10 +1001,10 @@ impl<'a> VmCore<'a> { let arg_vec = [arg]; func.func()(&arg_vec).map_err(|x| x.set_span_if_none(*cur_inst_span)) } - SteelVal::ContractedFunction(cf) => { - let arg_vec = vec![arg]; - cf.apply(arg_vec, cur_inst_span, self) - } + // SteelVal::ContractedFunction(cf) => { + // let arg_vec = vec![arg]; + // cf.apply(arg_vec, cur_inst_span, self) + // } SteelVal::MutFunc(func) => { let mut arg_vec: Vec<_> = vec![arg]; func(&mut arg_vec).map_err(|x| x.set_span_if_none(*cur_inst_span)) @@ -974,10 +1036,10 @@ impl<'a> VmCore<'a> { let arg_vec = [arg1, arg2]; func.func()(&arg_vec).map_err(|x| x.set_span_if_none(*cur_inst_span)) } - SteelVal::ContractedFunction(cf) => { - let arg_vec = vec![arg1, arg2]; - cf.apply(arg_vec, cur_inst_span, self) - } + // SteelVal::ContractedFunction(cf) => { + // let arg_vec = vec![arg1, arg2]; + // cf.apply(arg_vec, cur_inst_span, self) + // } SteelVal::MutFunc(func) => { let mut arg_vec: Vec<_> = vec![arg1, arg2]; func(&mut arg_vec).map_err(|x| x.set_span_if_none(*cur_inst_span)) @@ -1008,10 +1070,10 @@ impl<'a> VmCore<'a> { let arg_vec: Vec<_> = args.into_iter().collect(); func.func()(&arg_vec).map_err(|x| x.set_span_if_none(*cur_inst_span)) } - SteelVal::ContractedFunction(cf) => { - let arg_vec: Vec<_> = args.into_iter().collect(); - cf.apply(arg_vec, cur_inst_span, self) - } + // SteelVal::ContractedFunction(cf) => { + // let arg_vec: Vec<_> = args.into_iter().collect(); + // cf.apply(arg_vec, cur_inst_span, self) + // } SteelVal::MutFunc(func) => { let mut arg_vec: Vec<_> = args.into_iter().collect(); func(&mut arg_vec).map_err(|x| x.set_span_if_none(*cur_inst_span)) @@ -1235,20 +1297,28 @@ impl<'a> VmCore<'a> { self.thread.stack_frames.last().map(|x| x.function.as_ref()), ) { // if count > 1000 { - println!("Found a hot pattern, creating super instruction..."); + log::debug!(target: "super-instructions", "Found a hot pattern, creating super instruction..."); - // Index of the starting opcode - let start = pat.pattern.start; + log::debug!(target: "super-instructions", "{:#?}", pat); - let id = self.thread.super_instructions.len(); + if USE_SUPER_INSTRUCTIONS { + // Index of the starting opcode + let start = pat.pattern.start; - let guard = self.thread.stack_frames.last_mut().unwrap(); + let id = self.thread.super_instructions.len(); - // Next run should get the new sequence of opcodes - let (head, _) = guard.function.update_to_super_instruction(start, id); + let guard = self.thread.stack_frames.last_mut().unwrap(); - let block = DynamicBlock::construct_basic_block(head, pat); - self.thread.super_instructions.push(Rc::new(block)); + // Next run should get the new sequence of opcodes + let (head, _) = guard.function.update_to_super_instruction(start, id); + + let block = DynamicBlock::construct_basic_block(head, pat); + + self.thread.super_instructions.push(Rc::new(block)); + } + // self.thread.super_instructions.push(Rc::new(|ctx| { + // block.call(ctx); + // })) // let // } @@ -1281,6 +1351,7 @@ impl<'a> VmCore<'a> { } => { self.cut_sequence(); + // TODO: Store in a different spot? So that we can avoid cloning on every iteration? let super_instruction = { self.thread.super_instructions[payload_size as usize].clone() }; @@ -1294,9 +1365,21 @@ impl<'a> VmCore<'a> { } => { let last = self.thread.stack.pop().unwrap(); + // println!("-- POP N: {} -- ", payload_size); + // println!("popping: {}", payload_size); // println!("Stack length: {:?}", self.thread.stack.len()); + // println!("{:#?}", self.thread.stack); + + // if payload_size as usize > self.thread.stack.len() { + // self.thread.stack.clear() + // } else { + // self.thread + // .stack + // .truncate(self.thread.stack.len() - payload_size as usize); + // } + self.thread .stack .truncate(self.thread.stack.len() - payload_size as usize); @@ -1308,10 +1391,20 @@ impl<'a> VmCore<'a> { // todo!() } + DenseInstruction { + op_code: OpCode::POPSINGLE, + .. + } => { + self.thread.stack.pop(); + self.ip += 1; + } + DenseInstruction { op_code: OpCode::POPPURE, .. } => { + // println!("-- POP PURE --"); + if let Some(r) = self.handle_pop_pure() { return r; } @@ -1339,6 +1432,23 @@ impl<'a> VmCore<'a> { self.ip += 2; } + + // Specialization of specific library functions! + DenseInstruction { + op_code: OpCode::CONS, + .. + } => { + cons_handler(self)?; + } + + DenseInstruction { + op_code: OpCode::LIST, + payload_size, + .. + } => { + list_handler(self, payload_size as usize)?; + } + DenseInstruction { op_code: OpCode::ADDREGISTER, .. @@ -1809,6 +1919,11 @@ impl<'a> VmCore<'a> { let last_stack_frame = self.thread.stack_frames.last().unwrap(); + #[cfg(feature = "dynamic")] + { + last_stack_frame.function.increment_call_count(); + } + self.instructions = last_stack_frame.function.body_exp(); // self.spans = last_stack_frame.function.spans(); self.sp = last_stack_frame.sp; @@ -2018,7 +2133,13 @@ impl<'a> VmCore<'a> { // log::warn!("Hitting a pass - this shouldn't happen"); self.ip += 1; } + + // match_dynamic_super_instructions!() _ => { + #[cfg(feature = "dynamic")] + // TODO: Dispatch on the function here for super instructions! + dynamic::vm_match_dynamic_super_instruction(self, instr)?; + crate::core::instructions::pretty_print_dense_instructions(&self.instructions); panic!( "Unhandled opcode: {:?} @ {}", @@ -2108,7 +2229,13 @@ impl<'a> VmCore<'a> { self.thread .stack_frames .last() - .and_then(|frame| self.root_spans.get(frame.ip - 2)) + .and_then(|frame| { + if frame.ip > 2 { + self.root_spans.get(frame.ip - 2) + } else { + None + } + }) .copied() } } @@ -2496,14 +2623,14 @@ impl<'a> VmCore<'a> { .closure_interner .get(&closure_id) { - log::info!("Fetching closure from cache"); + log::trace!("Fetching closure from cache"); let mut prototype = prototype.clone(); prototype.set_captures(captures); prototype.set_heap_allocated(heap_vars); prototype } else { - log::info!("Constructing closure for the first time"); + log::trace!("Constructing closure for the first time"); debug_assert!(self.instructions[forward_index - 1].op_code == OpCode::ECLOSURE); @@ -2736,24 +2863,27 @@ impl<'a> VmCore<'a> { &self.instructions, self.thread.stack_frames.last().map(|x| x.function.as_ref()), ) { - println!("Found a hot pattern, creating super instruction..."); + log::debug!(target: "super-instructions", "Found a hot pattern, creating super instruction..."); + log::debug!(target: "super-instructions", "{:#?}", pat); - // Index of the starting opcode - let start = pat.pattern.start; + if USE_SUPER_INSTRUCTIONS { + // Index of the starting opcode + let start = pat.pattern.start; - let id = self.thread.super_instructions.len(); + let id = self.thread.super_instructions.len(); - let guard = self.thread.stack_frames.last_mut().unwrap(); + let guard = self.thread.stack_frames.last_mut().unwrap(); - // We don't want to repeatedly thrash by calculating hashes for the block pattern, so - // we mark the tail of the block directly on the function itself. - // guard.function.mark_block_tail(self.ip); + // We don't want to repeatedly thrash by calculating hashes for the block pattern, so + // we mark the tail of the block directly on the function itself. + // guard.function.mark_block_tail(self.ip); - // Next run should get the new sequence of opcodes - let (head, _) = guard.function.update_to_super_instruction(start, id); + // Next run should get the new sequence of opcodes + let (head, _) = guard.function.update_to_super_instruction(start, id); - let block = DynamicBlock::construct_basic_block(head, pat); - self.thread.super_instructions.push(Rc::new(block)); + let block = DynamicBlock::construct_basic_block(head, pat); + self.thread.super_instructions.push(Rc::new(block)); + } } } @@ -2764,11 +2894,11 @@ impl<'a> VmCore<'a> { BoxedFunction(f) => self.call_boxed_func(f.func(), payload_size), FuncV(f) => self.call_primitive_func(f, payload_size), MutFunc(f) => self.call_primitive_mut_func(f, payload_size), - ContractedFunction(cf) => self.call_contracted_function_tail_call(&cf, payload_size), + // ContractedFunction(cf) => self.call_contracted_function_tail_call(&cf, payload_size), ContinuationFunction(cc) => self.call_continuation(&cc), Closure(closure) => self.new_handle_tail_call_closure(closure, payload_size), BuiltIn(f) => self.call_builtin_func(f, payload_size), - CustomStruct(s) => self.call_custom_struct(&s.borrow(), payload_size), + CustomStruct(s) => self.call_custom_struct(&s, payload_size), _ => { // println!("{:?}", self.stack); // println!("{:?}", self.stack_index); @@ -2922,7 +3052,11 @@ impl<'a> VmCore<'a> { // TODO: Clean up function calls and create a nice calling convention API? fn call_custom_struct(&mut self, s: &UserDefinedStruct, payload_size: usize) -> Result<()> { if let Some(procedure) = s.maybe_proc() { - self.handle_global_function_call(procedure.clone(), payload_size) + if let SteelVal::HeapAllocated(h) = procedure { + self.handle_global_function_call(h.get(), payload_size) + } else { + self.handle_global_function_call(procedure.clone(), payload_size) + } } else { stop!(Generic => "Attempted to call struct as a function - no procedure found!"); } @@ -2976,60 +3110,60 @@ impl<'a> VmCore<'a> { } // #[inline(always)] - fn call_contracted_function( - &mut self, - cf: &ContractedFunction, - payload_size: usize, - ) -> Result<()> { - if let Some(arity) = cf.arity() { - if arity != payload_size { - stop!(ArityMismatch => format!("function expected {arity} arguments, found {payload_size}"); self.current_span()); - } - } + // fn call_contracted_function( + // &mut self, + // cf: &ContractedFunction, + // payload_size: usize, + // ) -> Result<()> { + // if let Some(arity) = cf.arity() { + // if arity != payload_size { + // stop!(ArityMismatch => format!("function expected {arity} arguments, found {payload_size}"); self.current_span()); + // } + // } - // if A::enforce_contracts() { - let args = self - .thread - .stack - .split_off(self.thread.stack.len() - payload_size); + // // if A::enforce_contracts() { + // let args = self + // .thread + // .stack + // .split_off(self.thread.stack.len() - payload_size); - let result = cf.apply(args, &self.current_span(), self)?; + // let result = cf.apply(args, &self.current_span(), self)?; - self.thread.stack.push(result); - self.ip += 1; - Ok(()) - // } else { - // self.handle_function_call(cf.function.clone(), payload_size) - // } - } + // self.thread.stack.push(result); + // self.ip += 1; + // Ok(()) + // // } else { + // // self.handle_function_call(cf.function.clone(), payload_size) + // // } + // } - // #[inline(always)] - fn call_contracted_function_tail_call( - &mut self, - cf: &ContractedFunction, - payload_size: usize, - ) -> Result<()> { - if let Some(arity) = cf.arity() { - if arity != payload_size { - stop!(ArityMismatch => format!("function expected {arity} arguments, found {payload_size}"); self.current_span()); - } - } + // // #[inline(always)] + // fn call_contracted_function_tail_call( + // &mut self, + // cf: &ContractedFunction, + // payload_size: usize, + // ) -> Result<()> { + // if let Some(arity) = cf.arity() { + // if arity != payload_size { + // stop!(ArityMismatch => format!("function expected {arity} arguments, found {payload_size}"); self.current_span()); + // } + // } - // if A::enforce_contracts() { - let args = self - .thread - .stack - .split_off(self.thread.stack.len() - payload_size); + // // if A::enforce_contracts() { + // let args = self + // .thread + // .stack + // .split_off(self.thread.stack.len() - payload_size); - let result = cf.apply(args, &self.current_span(), self)?; + // let result = cf.apply(args, &self.current_span(), self)?; - self.thread.stack.push(result); - self.ip += 1; - Ok(()) - // } else { - // self.handle_tail_call(cf.function.clone(), payload_size) - // } - } + // self.thread.stack.push(result); + // self.ip += 1; + // Ok(()) + // // } else { + // // self.handle_tail_call(cf.function.clone(), payload_size) + // // } + // } fn call_future_func_on_stack( &mut self, @@ -3221,22 +3355,22 @@ impl<'a> VmCore<'a> { self.thread.stack.push(result); self.ip += 4; } - ContractedFunction(cf) => { - if let Some(arity) = cf.arity() { - if arity != 2 { - stop!(ArityMismatch => format!("function expected {} arguments, found {}", arity, 2); self.current_span()); - } - } + // ContractedFunction(cf) => { + // if let Some(arity) = cf.arity() { + // if arity != 2 { + // stop!(ArityMismatch => format!("function expected {} arguments, found {}", arity, 2); self.current_span()); + // } + // } - // if A::enforce_contracts() { - let result = cf.apply(vec![local, const_value], &self.current_span(), self)?; + // // if A::enforce_contracts() { + // let result = cf.apply(vec![local, const_value], &self.current_span(), self)?; - self.thread.stack.push(result); - self.ip += 4; - // } else { - // self.handle_lazy_function_call(cf.function.clone(), local, const_value)?; - // } - } + // self.thread.stack.push(result); + // self.ip += 4; + // // } else { + // // self.handle_lazy_function_call(cf.function.clone(), local, const_value)?; + // // } + // } // Contract(c) => self.call_contract(c, payload_size, span)?, ContinuationFunction(_cc) => { unimplemented!("calling continuation lazily not yet handled"); @@ -3251,7 +3385,7 @@ impl<'a> VmCore<'a> { self.ip += 4; } CustomStruct(s) => { - if let Some(proc) = s.borrow().maybe_proc() { + if let Some(proc) = s.maybe_proc() { return self.handle_lazy_function_call(proc.clone(), local, const_value); } else { stop!(Generic => "attempted to call struct as function, but the struct does not have a function to call!") @@ -3519,11 +3653,11 @@ impl<'a> VmCore<'a> { BoxedFunction(f) => self.call_boxed_func(f.func(), payload_size)?, MutFunc(f) => self.call_primitive_mut_func(*f, payload_size)?, FutureFunc(f) => self.call_future_func(f.clone(), payload_size)?, - ContractedFunction(cf) => self.call_contracted_function(&cf, payload_size)?, + // ContractedFunction(cf) => self.call_contracted_function(&cf, payload_size)?, ContinuationFunction(cc) => self.call_continuation(&cc)?, // #[cfg(feature = "jit")] // CompiledFunction(function) => self.call_compiled_function(function, payload_size)?, - Contract(c) => self.call_contract(&c, payload_size)?, + // Contract(c) => self.call_contract(&c, payload_size)?, BuiltIn(f) => self.call_builtin_func(*f, payload_size)?, // CustomStruct(s) => self.call_custom_struct_global(&s.borrow(), payload_size)?, _ => { @@ -3551,17 +3685,17 @@ impl<'a> VmCore<'a> { BoxedFunction(f) => self.call_boxed_func(f.func(), payload_size), MutFunc(f) => self.call_primitive_mut_func(f, payload_size), FutureFunc(f) => self.call_future_func(f, payload_size), - ContractedFunction(cf) => self.call_contracted_function(&cf, payload_size), + // ContractedFunction(cf) => self.call_contracted_function(&cf, payload_size), ContinuationFunction(cc) => self.call_continuation(&cc), - Contract(c) => self.call_contract(&c, payload_size), + // Contract(c) => self.call_contract(&c, payload_size), BuiltIn(f) => self.call_builtin_func(f, payload_size), - CustomStruct(s) => self.call_custom_struct(&s.borrow(), payload_size), + CustomStruct(s) => self.call_custom_struct(&s, payload_size), _ => { // Explicitly mark this as unlikely cold(); log::error!("{stack_func:?}"); log::error!("Stack: {:?}", self.thread.stack); - stop!(BadSyntax => "Function application not a procedure or function type not supported"; self.current_span()); + stop!(BadSyntax => format!("Function application not a procedure or function type not supported: {}", stack_func); self.current_span()); } } } @@ -3642,14 +3776,14 @@ impl<'a> VmCore<'a> { } // #[inline(always)] - fn call_contract(&mut self, contract: &Gc, payload_size: usize) -> Result<()> { - match contract.as_ref() { - ContractType::Flat(f) => self.handle_function_call(f.predicate.clone(), payload_size), - _ => { - stop!(BadSyntax => "Function application not a procedure - cannot apply function contract to argument"); - } - } - } + // fn call_contract(&mut self, contract: &Gc, payload_size: usize) -> Result<()> { + // match contract.as_ref() { + // ContractType::Flat(f) => self.handle_function_call(f.predicate.clone(), payload_size), + // _ => { + // stop!(BadSyntax => "Function application not a procedure - cannot apply function contract to argument"); + // } + // } + // } // #[inline(always)] fn handle_function_call(&mut self, stack_func: SteelVal, payload_size: usize) -> Result<()> { @@ -3660,14 +3794,14 @@ impl<'a> VmCore<'a> { FuncV(f) => self.call_primitive_func(f, payload_size), FutureFunc(f) => self.call_future_func(f, payload_size), MutFunc(f) => self.call_primitive_mut_func(f, payload_size), - ContractedFunction(cf) => self.call_contracted_function(&cf, payload_size), + // ContractedFunction(cf) => self.call_contracted_function(&cf, payload_size), ContinuationFunction(cc) => self.call_continuation(&cc), Closure(closure) => self.handle_function_call_closure(closure, payload_size), // #[cfg(feature = "jit")] // CompiledFunction(function) => self.call_compiled_function(function, payload_size)?, - Contract(c) => self.call_contract(&c, payload_size), + // Contract(c) => self.call_contract(&c, payload_size), BuiltIn(f) => self.call_builtin_func(f, payload_size), - CustomStruct(s) => self.call_custom_struct(&s.borrow(), payload_size), + CustomStruct(s) => self.call_custom_struct(&s, payload_size), _ => { log::error!("{stack_func:?}"); log::error!("stack: {:?}", self.thread.stack); @@ -3695,6 +3829,19 @@ pub fn current_function_span(ctx: &mut VmCore, args: &[SteelVal]) -> Option Option> { + let offset = ctx.get_offset(); + + println!("----- Locals -----"); + for (slot, i) in (offset..ctx.thread.stack.len()).enumerate() { + println!("x{} = {:?}", slot, &ctx.thread.stack[i]); + } + + Some(Ok(SteelVal::Void)) +} + pub fn call_with_exception_handler( ctx: &mut VmCore, args: &[SteelVal], @@ -3774,6 +3921,10 @@ pub fn call_with_exception_handler( Some(Ok(SteelVal::Void)) } +pub fn oneshot_call_cc(ctx: &mut VmCore, args: &[SteelVal]) -> Option> { + todo!("Create continuation that can only be used once!") +} + pub fn call_cc(ctx: &mut VmCore, args: &[SteelVal]) -> Option> { /* - Construct the continuation @@ -4081,6 +4232,109 @@ impl OpCodeOccurenceProfiler { self.time.clear(); } + // Process the op code and the associated payload + // TODO: Get this to just use offsets, don't actually clone the instruction set directly + #[cfg(feature = "dynamic")] + pub fn process_opcode( + &mut self, + opcode: &OpCode, + // payload: usize, + index: usize, + instructions: &[DenseInstruction], + function: Option<&ByteCodeLambda>, + ) -> Option { + // *self.occurrences.entry((*opcode, payload)).or_default() += 1; + + let function = function?; + + // Trace once it becomes hot + let call_count = function.call_count(); + // If we're in the special zone, profile, otherwise don't + if call_count < 1000 || call_count > 10000 { + self.starting_index = None; + self.ending_index = None; + return None; + } + + match opcode { + OpCode::SDEF | OpCode::EDEF => return None, + _ => {} + } + + if self.starting_index.is_none() { + self.starting_index = Some(index); + } + + self.ending_index = Some(index); + + match opcode { + OpCode::JMP + | OpCode::IF + // | OpCode::CALLGLOBAL + | OpCode::CALLGLOBALTAIL + | OpCode::TAILCALL + | OpCode::TCOJMP + | OpCode::POPPURE + | OpCode::LTEIMMEDIATEIF + // | OpCode::FUNC + => { + + let block_pattern = BlockPattern { + start: self.starting_index.unwrap(), + end: index + }; + + let mut guard = function.blocks.borrow_mut(); + + + if let Some((_, metadata)) = guard.iter_mut().find(|x| x.0 == block_pattern) { + + // self.sample_count += 1; + // println!("Sampling on op code: {:?}", opcode); + + metadata.count += 1; + metadata.length = index - block_pattern.start; + // self.last_sequence = Some(pattern); + + if metadata.count > 1000 && !metadata.created { + metadata.created = true; + + // println!("{} {}", block_pattern.start, index); + + let sequence = instructions[block_pattern.start..=index] + .iter() + .map(|x| (x.op_code, x.payload_size as usize)) + .filter(|x| !x.0.is_ephemeral_opcode() && x.0 != OpCode::POPPURE) + .collect(); + + self.starting_index = None; + self.ending_index = None; + + + // println!("Pattern finished"); + + return Some(InstructionPattern::new(sequence, block_pattern)); + } + + } else if index - block_pattern.start > 2 { + guard.push((block_pattern, BlockMetadata::default())); + } + + self.starting_index = None; + self.ending_index = None; + + // println!("Pattern finished"); + } + _ => { + // println!("Updating end to be: {}", index); + self.ending_index = Some(index); + // self.sequence.push((*opcode, index)); + } + } + + None + } + #[cfg(feature = "dynamic")] pub fn cut_sequence( &mut self, @@ -4096,6 +4350,7 @@ impl OpCodeOccurenceProfiler { // Trace once it becomes hot let call_count = function.call_count(); + // If we're in the special zone, profile, otherwise don't if !(1000..=10000).contains(&call_count) { self.starting_index = None; @@ -4159,7 +4414,11 @@ impl OpCodeOccurenceProfiler { // pub fn report_basic_blocks(&self) { // println!("--------------- Basic Blocks ---------------"); - // let mut blocks = self.basic_blocks.iter().collect::>(); + // let mut blocks = self + // .super_instructions + // .basic_blocks + // .iter() + // .collect::>(); // blocks.sort_by_key(|x| x.1); // blocks.reverse(); @@ -4291,7 +4550,7 @@ fn op_code_requires_payload( // on the main VM context. In order to construct these sequences, we will need to be able // to grab a basic block from the running sequence, and directly patch an instruction set // on the fly, to transfer context over to that sequence. -static OP_CODE_TABLE: [for<'r> fn(&'r mut VmCore<'_>) -> Result<()>; 58] = [ +static OP_CODE_TABLE: [for<'r> fn(&'r mut VmCore<'_>) -> Result<()>; 66] = [ void_handler, push_handler, if_handler, // If @@ -4303,6 +4562,7 @@ static OP_CODE_TABLE: [for<'r> fn(&'r mut VmCore<'_>) -> Result<()>; 58] = [ dummy, // sdef dummy, // edef dummy, // pop + dummy, // popn dummy, // pass push_const_handler, dummy, // ndefs, @@ -4351,7 +4611,14 @@ static OP_CODE_TABLE: [for<'r> fn(&'r mut VmCore<'_>) -> Result<()>; 58] = [ set_alloc_handler, // dummy, // gimmick // move_read_local_call_global_handler, // movereadlocalcallglobal, - dummy, // dynsuperinstruction + dummy, // dynsuperinstruction, + dummy, + dummy, + dummy, + dummy, + dummy, + binop_add_handler, + dummy, ]; macro_rules! opcode_to_function { @@ -4726,6 +4993,14 @@ fn handle_local_0_no_stack(ctx: &mut VmCore<'_>) -> Result { Ok(value) } +#[inline(always)] +fn handle_local_1_no_stack(ctx: &mut VmCore<'_>) -> Result { + let offset = ctx.get_offset(); + let value = ctx.thread.stack[offset + 1].clone(); + ctx.ip += 1; + Ok(value) +} + // OpCode::VOID fn void_handler(ctx: &mut VmCore<'_>) -> Result<()> { ctx.thread.stack.push(SteelVal::Void); @@ -4779,6 +5054,13 @@ fn push_const_handler(ctx: &mut VmCore<'_>) -> Result<()> { Ok(()) } +fn push_const_handler_no_stack(ctx: &mut VmCore<'_>) -> Result { + let payload_size = ctx.instructions[ctx.ip].payload_size; + let val = ctx.constants.get(payload_size as usize); + ctx.ip += 1; + Ok(val) +} + // OpCode::PUSHCONST fn push_const_handler_with_payload(ctx: &mut VmCore<'_>, payload: usize) -> Result<()> { let val = ctx.constants.get(payload); @@ -5059,6 +5341,54 @@ fn add_handler(ctx: &mut VmCore<'_>) -> Result<()> { Ok(()) } +fn binop_add_handler(ctx: &mut VmCore<'_>) -> Result<()> { + let last_index = ctx.thread.stack.len() - 2; + + let right = ctx.thread.stack.pop().unwrap(); + let left = ctx.thread.stack.last().unwrap(); + + let result = match add_handler_none_none(left, &right) { + Ok(value) => value, + Err(e) => return Err(e.set_span_if_none(ctx.current_span())), + }; + + // let result = match $name(&mut $ctx.thread.stack[last_index..]) { + // Ok(value) => value, + // Err(e) => return Err(e.set_span_if_none($ctx.current_span())), + // }; + + // This is the old way... lets see if the below way improves the speed + // $ctx.thread.stack.truncate(last_index); + // $ctx.thread.stack.push(result); + + // self.thread.stack.truncate(last_index + 1); + // *self.thread.stack.last_mut().unwrap() = result; + + *ctx.thread.stack.last_mut().unwrap() = result; + + ctx.ip += 2; + + Ok(()) +} + +fn cons_handler(ctx: &mut VmCore<'_>) -> Result<()> { + handler_inline_primitive_payload!(ctx, cons, 2); + Ok(()) +} + +fn cons_handler_no_stack(ctx: &mut VmCore<'_>) -> Result<()> { + todo!() +} + +fn list_handler(ctx: &mut VmCore<'_>, payload: usize) -> Result<()> { + handler_inline_primitive_payload!(ctx, new_list, payload); + Ok(()) +} + +fn list_handler_no_stack(ctx: &mut VmCore<'_>, payload: usize) -> Result<()> { + todo!() +} + // OpCode::ADD fn add_handler_payload(ctx: &mut VmCore<'_>, payload: usize) -> Result<()> { handler_inline_primitive_payload!(ctx, special_add, payload); @@ -5569,6 +5899,10 @@ fn add_handler_none_none(l: &SteelVal, r: &SteelVal) -> Result { } } +#[cfg(feature = "dynamic")] +pub(crate) use dynamic::pattern_exists; + +#[macro_use] #[cfg(feature = "dynamic")] mod dynamic { use super::*; @@ -5670,6 +6004,10 @@ mod dynamic { call_global_handler_with_args }; + (PUSHCONST) => { + push_const_handler_no_stack + }; + (MOVEREADLOCAL0) => { handle_move_local_0_no_stack }; @@ -5681,6 +6019,10 @@ mod dynamic { (READLOCAL0) => { handle_local_0_no_stack }; + + (READLOCAL1) => { + handle_local_1_no_stack + }; } // Includes the module as a dependency, that being said - this should diff --git a/crates/steel-core/src/steel_vm/vm/threads.rs b/crates/steel-core/src/steel_vm/vm/threads.rs index 9d1d6877b..77eb1989d 100644 --- a/crates/steel-core/src/steel_vm/vm/threads.rs +++ b/crates/steel-core/src/steel_vm/vm/threads.rs @@ -12,7 +12,7 @@ macro_rules! time { let e = $e; - log::info!(target: "threads", "{}: {:?}", $label, now.elapsed()); + log::debug!(target: "threads", "{}: {:?}", $label, now.elapsed()); e }}; diff --git a/crates/steel-core/src/tests/mod.rs b/crates/steel-core/src/tests/mod.rs index 2c3831feb..cc133a317 100644 --- a/crates/steel-core/src/tests/mod.rs +++ b/crates/steel-core/src/tests/mod.rs @@ -86,6 +86,7 @@ test_harness_success! { maxsubseq, merge_sort, numbers, + ncsubseq, pascals, permutations, quicksort, @@ -111,6 +112,7 @@ test_harness_success! { structs, threads, transducer_over_streams, + tree_traversal, trie_sort, y_combinator, } diff --git a/crates/steel-core/src/tests/success/dfs.scm b/crates/steel-core/src/tests/success/dfs.scm index f3761b8fb..141d4d118 100644 --- a/crates/steel-core/src/tests/success/dfs.scm +++ b/crates/steel-core/src/tests/success/dfs.scm @@ -9,15 +9,11 @@ ;; (get-neighbors 'a graph) => '(b c) ;; (define (get-neighbors node graph) - (define found-neighbors (assoc node graph)) - (if found-neighbors - (cdr found-neighbors) - '())) + (define found-neighbors (assoc node graph)) + (if found-neighbors (cdr found-neighbors) '())) -(define (longest lst) - (foldr (λ (a b) (if (> (length a) (length b)) a b)) - '() - lst)) +(define (longest lst) + (foldr (λ (a b) (if (> (length a) (length b)) a b)) '() lst)) ; (define (reverse ls) ; (define (my-reverse-2 ls acc) @@ -27,73 +23,66 @@ ; (my-reverse-2 ls '())) (define (first-step curr end graph) - (define neighbors (get-neighbors curr graph)) - (longest (map (lambda (x) (dfs x end '() '() graph)) neighbors))) - + (define neighbors (get-neighbors curr graph)) + (longest (map (lambda (x) (dfs x end '() '() graph)) neighbors))) (define (member? x los) - (cond - ((null? los) #f) - ((equal? x (car los)) #t) - (else (member? x (cdr los))))) + (cond + [(null? los) #f] + [(equal? x (car los)) #t] + [else (member? x (cdr los))])) ;; iteratively tries each neighbor ;; quits when the length is worse (define (try-all-neighbors neighbors best-path end new-path graph) - (if (not (empty? neighbors)) - (let* ((next-neighbor (car neighbors)) - (found-path (dfs next-neighbor end new-path best-path graph))) - (if (> (length found-path) (length best-path)) - (try-all-neighbors (cdr neighbors) found-path end new-path graph) - (try-all-neighbors (cdr neighbors) best-path end new-path graph))) - best-path)) + (if (not (empty? neighbors)) + (let* ([next-neighbor (car neighbors)] + [found-path (dfs next-neighbor end new-path best-path graph)]) + (if (> (length found-path) (length best-path)) + (try-all-neighbors (cdr neighbors) found-path end new-path graph) + (try-all-neighbors (cdr neighbors) best-path end new-path graph))) + best-path)) (define (dfs curr end path best-path graph) - (define neighbors (get-neighbors curr graph)) - (define new-path (cons curr path)) - (cond ((equal? curr end) - (cons curr path)) - ((member? curr path) - '()) - (neighbors (try-all-neighbors neighbors best-path end (cons curr path) graph)) - (else '()))) + (define neighbors (get-neighbors curr graph)) + (define new-path (cons curr path)) + (cond + [(equal? curr end) (cons curr path)] + [(member? curr path) '()] + [neighbors (try-all-neighbors neighbors best-path end (cons curr path) graph)] + [else '()])) (define (longest-path start end graph) - (define found-path (reverse (first-step start end graph))) - (cond ((empty? found-path) - (if (equal? start end) - (list start) - '())) - ((and (equal? (car found-path) start) (not (equal? start end))) - found-path) - (else (cons start found-path)))) - + (define found-path (reverse (first-step start end graph))) + (cond + [(empty? found-path) (if (equal? start end) (list start) '())] + [(and (equal? (car found-path) start) (not (equal? start end))) found-path] + [else (cons start found-path)])) (longest-path 'a 'c '((a b) (b c))) ;; '(a b c) (longest-path 'a 'c '((a b) (b a c))) ;; '(a b c) (longest-path 'a 'c '((a d e f g b) (b a c))) ;; '(a b c) (longest-path 'a 'a '((a b) (b a c))) ;; '(a b a) -; (longest-path 'a 'c '((a b) (b a) (c))) ;; '() -; (longest-path 'a 'f '((a b c) (b f) (c d) (d e) (e f))) ;; '(a c d e f) -; (longest-path 'a 'f '((a b c a) (b c d) (c e a) (d e f) (e d f))) ;; '(a b c e d f) -; (longest-path 'a 'a '((a b c a) (b c d) (c e a) (d e f) (e d f))) ;; '(a b c a) -; (longest-path 'a 'a '((a b) (b c))) ;; '(a) -; (longest-path 'a 'a '((a a b) (b c))) ;; '(a a) -; (longest-path 'a 'a '((a b a) (b c))) ;; '(a a) -; (longest-path 'a 'b '((a b) (b c) (c b))) ;; '(a b) -; (longest-path 'a 'b '((a b c) (b c) (c b))) ;; '(a c b) +(longest-path 'a 'c '((a b) (b a) (c))) ;; '() +(longest-path 'a 'f '((a b c) (b f) (c d) (d e) (e f))) ;; '(a c d e f) +(longest-path 'a 'f '((a b c a) (b c d) (c e a) (d e f) (e d f))) ;; '(a b c e d f) +(longest-path 'a 'a '((a b c a) (b c d) (c e a) (d e f) (e d f))) ;; '(a b c a) +(longest-path 'a 'a '((a b) (b c))) ;; '(a) +(longest-path 'a 'a '((a a b) (b c))) ;; '(a a) +(longest-path 'a 'a '((a b a) (b c))) ;; '(a a) +(longest-path 'a 'b '((a b) (b c) (c b))) ;; '(a b) +(longest-path 'a 'b '((a b c) (b c) (c b))) ;; '(a c b) -; (assert! (equal? (longest-path 'a 'c '((a b) (b c))) '(a b c))) -; (assert! (equal? (longest-path 'a 'c '((a b) (b a c))) '(a b c))) -; (assert! (equal? (longest-path 'a 'c '((a d e f g b) (b a c))) '(a b c))) -(assert! (equal? (dbg! (longest-path 'a 'a '((a b) (b a c)))) '(a b a))) -; (assert! (equal? (longest-path 'a 'c '((a b) (b a) (c))) '())) -; (assert! (equal? (longest-path 'a 'f '((a b c) (b f) (c d) (d e) (e f))) '(a c d e f))) -; (assert! (equal? (longest-path 'a 'f '((a b c a) (b c d) (c e a) (d e f) (e d f))) '(a b c e d f))) -; (assert! (equal? (longest-path 'a 'a '((a b c a) (b c d) (c e a) (d e f) (e d f))) '(a b c a))) -; (assert! (equal? (longest-path 'a 'a '((a b) (b c))) '(a))) -; (assert! (equal? (longest-path 'a 'a '((a a b) (b c))) '(a a))) -; (assert! (equal? (longest-path 'a 'a '((a b a) (b c))) '(a a))) -; (assert! (equal? (longest-path 'a 'b '((a b) (b c) (c b))) '(a b))) -; (assert! (equal? (longest-path 'a 'b '((a b c) (b c) (c b))) '(a c b))) - \ No newline at end of file +(assert! (equal? (longest-path 'a 'c '((a b) (b c))) '(a b c))) +(assert! (equal? (longest-path 'a 'c '((a b) (b a c))) '(a b c))) +(assert! (equal? (longest-path 'a 'c '((a d e f g b) (b a c))) '(a b c))) +(assert! (equal? (longest-path 'a 'a '((a b) (b a c))) '(a b a))) +(assert! (equal? (longest-path 'a 'c '((a b) (b a) (c))) '())) +(assert! (equal? (longest-path 'a 'f '((a b c) (b f) (c d) (d e) (e f))) '(a c d e f))) +(assert! (equal? (longest-path 'a 'f '((a b c a) (b c d) (c e a) (d e f) (e d f))) '(a b c e d f))) +(assert! (equal? (longest-path 'a 'a '((a b c a) (b c d) (c e a) (d e f) (e d f))) '(a b c a))) +(assert! (equal? (longest-path 'a 'a '((a b) (b c))) '(a))) +(assert! (equal? (longest-path 'a 'a '((a a b) (b c))) '(a a))) +(assert! (equal? (longest-path 'a 'a '((a b a) (b c))) '(a a))) +(assert! (equal? (longest-path 'a 'b '((a b) (b c) (c b))) '(a b))) +(assert! (equal? (longest-path 'a 'b '((a b c) (b c) (c b))) '(a c b))) diff --git a/crates/steel-core/src/tests/success/ncsubseq.scm b/crates/steel-core/src/tests/success/ncsubseq.scm new file mode 100644 index 000000000..7d01a9b9e --- /dev/null +++ b/crates/steel-core/src/tests/success/ncsubseq.scm @@ -0,0 +1,27 @@ +(define (ncsubseq lst) + (let recurse ([s 0] [lst lst]) + (if (null? lst) + (if (>= s 3) '(()) '()) + (let ([x (car lst)] [xs (cdr lst)]) + (if (even? s) + (append (map (lambda (ys) (cons x ys)) (recurse (+ s 1) xs)) (recurse s xs)) + (append (map (lambda (ys) (cons x ys)) (recurse s xs)) (recurse (+ s 1) xs))))))) + +(assert! (equal? (ncsubseq '(1 2 3)) '((1 3)))) +(assert! (equal? (ncsubseq '(1 2 3 4)) '((1 2 4) (1 3 4) (1 3) (1 4) (2 4)))) +(assert! (equal? (ncsubseq '(1 2 3 4 5)) + '((1 2 3 5) (1 2 4 5) + (1 2 4) + (1 2 5) + (1 3 4 5) + (1 3 4) + (1 3 5) + (1 3) + (1 4 5) + (1 4) + (1 5) + (2 3 5) + (2 4 5) + (2 4) + (2 5) + (3 5)))) diff --git a/crates/steel-core/src/tests/success/tree_traversal.scm b/crates/steel-core/src/tests/success/tree_traversal.scm new file mode 100644 index 000000000..ea85178ed --- /dev/null +++ b/crates/steel-core/src/tests/success/tree_traversal.scm @@ -0,0 +1,54 @@ +(define (preorder tree) + (if (null? tree) '() (append (list (car tree)) (preorder (cadr tree)) (preorder (caddr tree))))) + +(define (inorder tree) + (if (null? tree) '() (append (inorder (cadr tree)) (list (car tree)) (inorder (caddr tree))))) + +(define (postorder tree) + (if (null? tree) '() (append (postorder (cadr tree)) (postorder (caddr tree)) (list (car tree))))) + +(define (level-order tree) + (define lst '()) + (define (traverse nodes) + (when (pair? nodes) + (let ([next-nodes '()]) + (let loop ([p nodes]) + (when (not (null? p)) + + (set! lst (cons (caar p) lst)) + (let* ([n '()] + [n (if (null? (cadar p)) n (cons (cadar p) n))] + [n (if (null? (caddar p)) n (cons (caddar p) n))]) + (set! next-nodes (append n next-nodes))) + + (loop (cdr p)))) + + (traverse (reverse next-nodes))))) + (if (null? tree) + '() + (begin + (traverse (list tree)) + (reverse lst)))) + +(define (demonstration tree) + (define (display-values lst) + (let loop ([p lst]) + (when (not (null? p)) + (display (car p)) + (when (pair? (cdr p)) + (display " ")) + + (loop (cdr p)))) + (newline)) + (display "preorder: ") + (display-values (preorder tree)) + (display "inorder: ") + (display-values (inorder tree)) + (display "postorder: ") + (display-values (postorder tree)) + (display "level-order: ") + (display-values (level-order tree))) + +(define the-task-tree '(1 (2 (4 (7 () ()) ()) (5 () ())) (3 (6 (8 () ()) (9 () ())) ()))) + +(demonstration the-task-tree) diff --git a/crates/steel-core/src/values/closed.rs b/crates/steel-core/src/values/closed.rs index 73159847c..261ea7d0e 100644 --- a/crates/steel-core/src/values/closed.rs +++ b/crates/steel-core/src/values/closed.rs @@ -1,34 +1,129 @@ use std::{ cell::RefCell, + collections::VecDeque, rc::{Rc, Weak}, }; use crate::{ - gc::Gc, - values::{ - contracts::{ContractType, FunctionKind}, - functions::ByteCodeLambda, + rvals::{OpaqueIterator, SteelVector}, + values::lists::List, +}; +use num::BigInt; + +use crate::{ + gc::{unsafe_erased_pointers::OpaqueReference, Gc}, + rvals::{ + cycles::BreadthFirstSearchSteelValVisitor, BoxedAsyncFunctionSignature, CustomType, + FunctionSignature, FutureResult, MutFunctionSignature, SteelHashMap, SteelHashSet, + SteelString, Syntax, }, + steel_vm::vm::{BuiltInSignature, Continuation}, + values::functions::ByteCodeLambda, SteelVal, }; +use super::{ + functions::BoxedDynFunction, + lazy_stream::LazyStream, + port::SteelPort, + structs::UserDefinedStruct, + transducers::{Reducer, Transducer}, +}; + const GC_THRESHOLD: usize = 256; const GC_GROW_FACTOR: usize = 2; -const _RESET_LIMIT: usize = 5; +const RESET_LIMIT: usize = 5; + +thread_local! { + static ROOTS: RefCell = RefCell::new(Roots::default()); +} + +#[derive(Default)] +pub struct Roots { + generation: usize, + offset: usize, + roots: fxhash::FxHashMap<(usize, usize), SteelVal>, +} + +#[derive(Debug, PartialEq, Eq, Hash)] +pub struct RootToken { + generation: usize, + offset: usize, +} + +impl Drop for RootToken { + fn drop(&mut self) { + ROOTS.with(|x| x.borrow_mut().free(self)) + } +} + +#[derive(Debug)] +pub struct RootedSteelVal { + value: SteelVal, + token: RootToken, +} + +impl RootedSteelVal { + pub fn value(&self) -> &SteelVal { + &self.value + } +} + +impl Roots { + fn root(&mut self, value: SteelVal) -> RootToken { + let generation = self.generation; + let offset = self.offset; + + self.offset += 1; + + self.roots.insert((generation, offset), value); + + RootToken { generation, offset } + } + + fn free(&mut self, token: &RootToken) { + self.roots.remove(&(token.generation, token.offset)); + } + + fn increment_generation(&mut self) { + self.generation += 1; + } +} + +impl SteelVal { + pub fn mark_rooted(&self) -> RootToken { + ROOTS.with(|x| x.borrow_mut().root(self.clone())) + } + + // If we're storing in an external struct that could escape + // the runtime, we probably want to be marked as rooted + pub fn as_rooted(&self) -> RootedSteelVal { + let token = self.mark_rooted(); + + RootedSteelVal { + token, + value: self.clone(), + } + } +} #[derive(Clone)] pub struct Heap { - memory: Vec>>, + memory: Vec>>>, + vectors: Vec>>>>, count: usize, threshold: usize, + mark_and_sweep_queue: VecDeque, } impl Heap { pub fn new() -> Self { Heap { memory: Vec::with_capacity(256), + vectors: Vec::with_capacity(256), count: 0, threshold: GC_THRESHOLD, + mark_and_sweep_queue: VecDeque::with_capacity(256), } } @@ -41,8 +136,8 @@ impl Heap { roots: impl Iterator, live_functions: impl Iterator, globals: impl Iterator, - ) -> HeapRef { - self.collect(roots, live_functions, globals); + ) -> HeapRef { + self.collect(Some(value.clone()), roots, live_functions, globals); let pointer = Rc::new(RefCell::new(HeapAllocated::new(value))); let weak_ptr = Rc::downgrade(&pointer); @@ -52,58 +147,137 @@ impl Heap { HeapRef { inner: weak_ptr } } + // Allocate a vector explicitly onto the heap + pub fn allocate_vector<'a>( + &mut self, + values: Vec, + roots: impl Iterator, + live_functions: impl Iterator, + globals: impl Iterator, + ) -> HeapRef> { + self.collect(None, roots, live_functions, globals); + + let pointer = Rc::new(RefCell::new(HeapAllocated::new(values))); + let weak_ptr = Rc::downgrade(&pointer); + + self.vectors.push(pointer); + + HeapRef { inner: weak_ptr } + } + + // TODO: Call this in more areas in the VM to attempt to free memory more carefully + // Also - come up with generational scheme if possible pub fn collect<'a>( &mut self, + root_value: Option, roots: impl Iterator, live_functions: impl Iterator, globals: impl Iterator, ) { - if self.memory.len() > self.threshold { - log::info!(target: "gc", "Freeing memory"); + let memory_size = self.memory.len() + self.vectors.len(); + + if memory_size > self.threshold { + log::debug!(target: "gc", "Freeing memory"); + let original_length = memory_size; + + // Do at least one small collection, where we immediately drop + // anything that has weak counts of 0, meaning there are no alive + // references and we can avoid doing a full collection + // + // In the event that the collection does not yield a substantial + // change in the heap size, we should also enqueue a larger mark and + // sweep collection. let mut changed = true; while changed { - log::info!(target: "gc", "Small collection"); - let prior_len = self.memory.len(); - log::info!(target: "gc", "Previous length: {:?}", prior_len); + log::debug!(target: "gc", "Small collection"); + let prior_len = self.memory.len() + self.vectors.len(); + log::debug!(target: "gc", "Previous length: {:?}", prior_len); self.memory.retain(|x| Rc::weak_count(x) > 0); - let after = self.memory.len(); - log::info!(target: "gc", "Objects freed: {:?}", prior_len - after); + self.vectors.retain(|x| Rc::weak_count(x) > 0); + let after = self.memory.len() + self.vectors.len(); + log::debug!(target: "gc", "Objects freed: {:?}", prior_len - after); changed = prior_len != after; } - // TODO fix the garbage collector - self.mark_and_sweep(roots, live_functions, globals); + let post_small_collection_size = self.memory.len() + self.vectors.len(); - self.threshold = (self.threshold + self.memory.len()) * GC_GROW_FACTOR; + // Mark + Sweep! + if post_small_collection_size as f64 > (0.25 * original_length as f64) { + log::debug!(target: "gc", "---- Post small collection, running mark and sweep - heap size filled: {:?} ----", post_small_collection_size as f64 / original_length as f64); + + // TODO fix the garbage collector + self.mark_and_sweep(root_value, roots, live_functions, globals); + } else { + log::debug!(target: "gc", "---- Skipping mark and sweep - heap size filled: {:?} ----", post_small_collection_size as f64 / original_length as f64); + } + + // self.mark_and_sweep(roots, live_functions, globals); + + self.threshold = + (self.threshold + self.memory.len() + self.vectors.len()) * GC_GROW_FACTOR; self.count += 1; + + // Drive it down! + if self.count > RESET_LIMIT { + log::debug!(target: "gc", "Shrinking the heap"); + + self.threshold = GC_THRESHOLD; + self.count = 0; + + self.memory.shrink_to(GC_THRESHOLD); + self.vectors.shrink_to(GC_THRESHOLD); + } } } fn mark_and_sweep<'a>( &mut self, + root_value: Option, roots: impl Iterator, function_stack: impl Iterator, globals: impl Iterator, ) { - log::info!(target: "gc", "Marking the heap"); + log::debug!(target: "gc", "Marking the heap"); + + let mut context = MarkAndSweepContext { + queue: &mut self.mark_and_sweep_queue, + }; + + if let Some(root_value) = root_value { + context.push_back(root_value); + } - // mark for root in roots { - traverse(root); + context.push_back(root.clone()); } + context.visit(); + for root in globals { - traverse(root); + context.push_back(root.clone()); } + context.visit(); + for function in function_stack { for heap_ref in function.heap_allocated.borrow().iter() { - mark_heap_ref(&heap_ref.strong_ptr()) + context.mark_heap_reference(&heap_ref.strong_ptr()) } } + context.visit(); + + ROOTS.with(|x| { + x.borrow() + .roots + .values() + .for_each(|value| context.push_back(value.clone())) + }); + + context.visit(); + // println!("Freeing heap"); // TODO -> move destructors to another thread? @@ -118,34 +292,46 @@ impl Heap { // .collect::>() // ); - log::info!(target: "gc", "Sweeping"); - let prior_len = self.memory.len(); + log::debug!(target: "gc", "--- Sweeping ---"); + let prior_len = self.memory.len() + self.vectors.len(); // sweep self.memory.retain(|x| x.borrow().is_reachable()); + self.vectors.retain(|x| x.borrow().is_reachable()); let after_len = self.memory.len(); let amount_freed = prior_len - after_len; - log::info!(target: "gc", "Freed objects: {:?}", amount_freed); + log::debug!(target: "gc", "Freed objects: {:?}", amount_freed); + log::debug!(target: "gc", "Objects alive: {:?}", after_len); // put them back as unreachable self.memory.iter().for_each(|x| x.borrow_mut().reset()); + + ROOTS.with(|x| x.borrow_mut().increment_generation()); } } +pub trait HeapAble: Clone + std::fmt::Debug + PartialEq + Eq {} +impl HeapAble for SteelVal {} +impl HeapAble for Vec {} + #[derive(Clone, Debug)] -pub struct HeapRef { - inner: Weak>, +pub struct HeapRef { + inner: Weak>>, } -impl HeapRef { - pub fn get(&self) -> SteelVal { +impl HeapRef { + pub fn get(&self) -> T { self.inner.upgrade().unwrap().borrow().value.clone() } - pub fn set(&mut self, value: SteelVal) -> SteelVal { + pub fn as_ptr_usize(&self) -> usize { + self.inner.as_ptr() as usize + } + + pub fn set(&mut self, value: T) -> T { let inner = self.inner.upgrade().unwrap(); let ret = { inner.borrow().value.clone() }; @@ -154,7 +340,14 @@ impl HeapRef { ret } - pub(crate) fn set_interior_mut(&self, value: SteelVal) -> SteelVal { + pub fn set_and_return(&self, value: T) -> T { + let inner = self.inner.upgrade().unwrap(); + + let mut guard = inner.borrow_mut(); + std::mem::replace(&mut guard.value, value) + } + + pub(crate) fn set_interior_mut(&self, value: T) -> T { let inner = self.inner.upgrade().unwrap(); let ret = { inner.borrow().value.clone() }; @@ -163,34 +356,23 @@ impl HeapRef { ret } - fn strong_ptr(&self) -> Rc> { + pub(crate) fn strong_ptr(&self) -> Rc>> { self.inner.upgrade().unwrap() } -} -// impl AsRefSteelVal for HeapRef { -// type Nursery = (); - -// fn as_ref<'b, 'a: 'b>( -// val: &'a SteelVal, -// _nursery: &mut Self::Nursery, -// ) -> crate::rvals::Result> { -// if let SteelVal::Boxed(s) = val { -// Ok(SRef::Temporary(s)) -// } else { -// stop!(TypeMismatch => "Value cannot be referenced as a syntax object") -// } -// } -// } + pub(crate) fn ptr_eq(&self, other: &Self) -> bool { + Weak::ptr_eq(&self.inner, &other.inner) + } +} #[derive(Clone, Debug, PartialEq, Eq)] -pub struct HeapAllocated { +pub struct HeapAllocated { pub(crate) reachable: bool, - pub(crate) value: SteelVal, + pub(crate) value: T, } -impl HeapAllocated { - pub fn new(value: SteelVal) -> Self { +impl HeapAllocated { + pub fn new(value: T) -> Self { Self { reachable: false, value, @@ -210,118 +392,203 @@ impl HeapAllocated { } } -// Use this function to traverse and find all reachable things -// 'reachable' should be values living in the heap, stack, and in the -fn traverse(val: &SteelVal) { - match val { - // SteelVal::Pair(_) => {} - SteelVal::VectorV(v) => { - for value in v.iter() { - traverse(value) - } +pub struct MarkAndSweepContext<'a> { + queue: &'a mut VecDeque, +} + +impl<'a> MarkAndSweepContext<'a> { + fn mark_heap_reference(&mut self, heap_ref: &Rc>>) { + if heap_ref.borrow().is_reachable() { + return; } - SteelVal::ListV(v) => { - for value in v { - traverse(value) - } + + { + heap_ref.borrow_mut().mark_reachable(); } - SteelVal::MutableVector(v) => { - for value in v.borrow().iter() { - traverse(value) - } + + self.push_back(heap_ref.borrow().value.clone()); + } + + // Visit the heap vector, mark it as visited! + fn mark_heap_vector(&mut self, heap_vector: &Rc>>>) { + if heap_vector.borrow().is_reachable() { + return; } - // SteelVal::HashMapV(_) => {} - // SteelVal::HashSetV(_) => {} - // SteelVal::StructV(_) => {} - // SteelVal::PortV(_) => {} - SteelVal::Closure(c) => { - for heap_ref in c.heap_allocated.borrow().iter() { - mark_heap_ref(&heap_ref.strong_ptr()) - } - for capture in c.captures() { - traverse(capture); - } + { + heap_vector.borrow_mut().mark_reachable(); } - // SteelVal::IterV(_) => {} - // SteelVal::FutureV(_) => {} - SteelVal::StreamV(s) => { - traverse(&s.initial_value); - traverse(&s.stream_thunk); + + for value in heap_vector.borrow().value.iter() { + self.push_back(value.clone()); } - // SteelVal::BoxV(_) => {} - SteelVal::Contract(c) => visit_contract_type(c), - SteelVal::ContractedFunction(c) => { - visit_function_contract(&c.contract); - if let SteelVal::Closure(func) = &c.function { - visit_closure(func); - } - // visit_closure(&c.function); + } +} + +impl<'a> BreadthFirstSearchSteelValVisitor for MarkAndSweepContext<'a> { + type Output = (); + + fn default_output(&mut self) -> Self::Output {} + + fn pop_front(&mut self) -> Option { + self.queue.pop_front() + } + + fn push_back(&mut self, value: SteelVal) { + self.queue.push_back(value); + } + + fn visit_closure(&mut self, closure: Gc) -> Self::Output { + for heap_ref in closure.heap_allocated.borrow().iter() { + self.mark_heap_reference(&heap_ref.strong_ptr()) } - SteelVal::ContinuationFunction(c) => { - for root in c.stack.iter() { - traverse(root); - } - for function in c.stack_frames.iter().map(|x| &x.function) { - for heap_ref in function.heap_allocated.borrow().iter() { - mark_heap_ref(&heap_ref.strong_ptr()) - } + for capture in closure.captures() { + self.push_back(capture.clone()); + } - for capture in function.captures() { - traverse(capture); - } - } + if let Some(contract) = closure.get_contract_information().as_ref() { + self.push_back(contract.clone()); } - _ => { - // println!("Traverse bottoming out on: {}", val); + } + + fn visit_bool(&mut self, _boolean: bool) -> Self::Output {} + fn visit_float(&mut self, _float: f64) -> Self::Output {} + fn visit_int(&mut self, _int: isize) -> Self::Output {} + fn visit_char(&mut self, _c: char) -> Self::Output {} + + fn visit_immutable_vector(&mut self, vector: SteelVector) -> Self::Output { + for value in vector.iter() { + self.push_back(value.clone()); } } -} -fn visit_function_contract(f: &FunctionKind) { - match f { - FunctionKind::Basic(f) => { - for pre_condition in f.pre_conditions() { - visit_contract_type(pre_condition) + fn visit_void(&mut self) -> Self::Output {} + fn visit_string(&mut self, _string: SteelString) -> Self::Output {} + fn visit_function_pointer(&mut self, _ptr: FunctionSignature) -> Self::Output {} + fn visit_symbol(&mut self, _symbol: SteelString) -> Self::Output {} + + // TODO: Come back to this + fn visit_custom_type(&mut self, custom_type: Gc>>) -> Self::Output { + custom_type.borrow().visit_children(self); + } + + fn visit_hash_map(&mut self, hashmap: SteelHashMap) -> Self::Output { + for (key, value) in hashmap.iter() { + self.push_back(key.clone()); + self.push_back(value.clone()); + } + } + + fn visit_hash_set(&mut self, hashset: SteelHashSet) -> Self::Output { + for value in hashset.iter() { + self.push_back(value.clone()); + } + } + + fn visit_steel_struct(&mut self, steel_struct: Gc) -> Self::Output { + for field in steel_struct.fields.iter() { + self.push_back(field.clone()); + } + } + + fn visit_port(&mut self, _port: Gc) -> Self::Output {} + + fn visit_transducer(&mut self, transducer: Gc) -> Self::Output { + for transducer in transducer.ops.iter() { + match transducer.clone() { + crate::values::transducers::Transducers::Map(m) => self.push_back(m), + crate::values::transducers::Transducers::Filter(v) => self.push_back(v), + crate::values::transducers::Transducers::Take(t) => self.push_back(t), + crate::values::transducers::Transducers::Drop(d) => self.push_back(d), + crate::values::transducers::Transducers::FlatMap(fm) => self.push_back(fm), + crate::values::transducers::Transducers::Flatten => {} + crate::values::transducers::Transducers::Window(w) => self.push_back(w), + crate::values::transducers::Transducers::TakeWhile(tw) => self.push_back(tw), + crate::values::transducers::Transducers::DropWhile(dw) => self.push_back(dw), + crate::values::transducers::Transducers::Extend(e) => self.push_back(e), + crate::values::transducers::Transducers::Cycle => {} + crate::values::transducers::Transducers::Enumerating => {} + crate::values::transducers::Transducers::Zipping(z) => self.push_back(z), + crate::values::transducers::Transducers::Interleaving(i) => self.push_back(i), } - visit_contract_type(f.post_condition()); } - FunctionKind::Dependent(_dc) => { - unimplemented!() + } + + fn visit_reducer(&mut self, reducer: Gc) -> Self::Output { + match reducer.as_ref().clone() { + Reducer::ForEach(f) => self.push_back(f), + Reducer::Generic(rf) => { + self.push_back(rf.initial_value); + self.push_back(rf.function); + } + _ => {} } } -} -fn visit_contract_type(contract: &ContractType) { - match contract { - ContractType::Flat(f) => { - traverse(f.predicate()); + fn visit_future_function(&mut self, _function: BoxedAsyncFunctionSignature) -> Self::Output {} + fn visit_future(&mut self, _future: Gc) -> Self::Output {} + + fn visit_stream(&mut self, stream: Gc) -> Self::Output { + self.push_back(stream.initial_value.clone()); + self.push_back(stream.stream_thunk.clone()); + } + + fn visit_boxed_function(&mut self, _function: Rc) -> Self::Output {} + + fn visit_continuation(&mut self, continuation: Gc) -> Self::Output { + for value in &continuation.stack { + self.push_back(value.clone()); + } + + for value in &continuation.current_frame.function.captures { + self.push_back(value.clone()); } - ContractType::Function(f) => { - visit_function_contract(f); + + for frame in &continuation.stack_frames { + for value in &frame.function.captures { + self.push_back(value.clone()); + } } } -} -fn visit_closure(c: &Gc) { - for heap_ref in c.heap_allocated.borrow().iter() { - mark_heap_ref(&heap_ref.strong_ptr()); + fn visit_list(&mut self, list: List) -> Self::Output { + for value in list { + self.push_back(value); + } } - for capture in c.captures() { - traverse(capture); + fn visit_mutable_function(&mut self, _function: MutFunctionSignature) -> Self::Output {} + + fn visit_mutable_vector(&mut self, vector: HeapRef>) -> Self::Output { + self.mark_heap_vector(&vector.strong_ptr()) } -} -fn mark_heap_ref(heap_ref: &Rc>) { - if heap_ref.borrow().is_reachable() { - return; + fn visit_builtin_function(&mut self, _function: BuiltInSignature) -> Self::Output {} + + // TODO: Revisit this when the boxed iterator is cleaned up + fn visit_boxed_iterator(&mut self, iterator: Gc>) -> Self::Output { + self.push_back(iterator.borrow().root.clone()); + } + + fn visit_syntax_object(&mut self, syntax_object: Gc) -> Self::Output { + if let Some(raw) = syntax_object.raw.clone() { + self.push_back(raw); + } + + self.push_back(syntax_object.syntax.clone()); } - { - heap_ref.borrow_mut().mark_reachable(); + fn visit_boxed_value(&mut self, boxed_value: Gc>) -> Self::Output { + self.push_back(boxed_value.borrow().clone()); } - traverse(&heap_ref.borrow().value); + // TODO: Revisit this + fn visit_reference_value(&mut self, _reference: Rc>) -> Self::Output {} + + fn visit_bignum(&mut self, _bignum: Gc) -> Self::Output {} + + fn visit_heap_allocated(&mut self, heap_ref: HeapRef) -> Self::Output { + self.mark_heap_reference(&heap_ref.strong_ptr()); + } } diff --git a/crates/steel-core/src/values/contracts.rs b/crates/steel-core/src/values/contracts.rs index 1cf8df3b9..9131d935d 100644 --- a/crates/steel-core/src/values/contracts.rs +++ b/crates/steel-core/src/values/contracts.rs @@ -1,478 +1,477 @@ -use crate::gc::Gc; -use crate::rvals::{Result, SteelVal}; -// use itertools::Itertools; -use std::collections::HashMap; -use std::fmt; - -use crate::parser::ast::IteratorExtensions; - -use super::functions::ByteCodeLambda; - -/// Flat contracts are simply predicates to apply to a value. These can be immediately applied -/// at attachment to a value. -#[derive(Clone, PartialEq)] -pub struct FlatContract { - /// Steel Function of any kind - pub(crate) predicate: SteelVal, - /// Name of the function for blaming purposes - pub(crate) name: String, -} - -impl fmt::Display for FlatContract { - fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { - write!(f, "{}", self.name) - } -} - -impl FlatContract { - #[inline(always)] - pub fn new_from_steelval(predicate: SteelVal, name: String) -> Result { - if predicate.is_contract() { - Ok(predicate) - } else if predicate.is_function() { - Ok(FlatContract::new(predicate, name).into()) - } else { - stop!(TypeMismatch => format!("flat contracts require a function argument, found {predicate}")); - } - } - - pub fn new(predicate: SteelVal, name: String) -> Self { - FlatContract { predicate, name } - } - - pub fn predicate(&self) -> &SteelVal { - &self.predicate - } -} - -impl From for SteelVal { - fn from(val: FlatContract) -> SteelVal { - SteelVal::Contract(Gc::new(ContractType::Flat(val))) - } -} - -// (x) (>= x) -- contains a vector of the arguments and then the contract -#[derive(Clone, PartialEq)] -pub(crate) struct DependentPair { - pub(crate) argument_name: String, - pub(crate) arguments: Vec, - pub(crate) thunk: Gc, - pub(crate) thunk_name: String, -} - -impl DependentPair { - fn new( - argument_name: String, - arguments: Vec, - thunk: Gc, - thunk_name: String, - ) -> Self { - DependentPair { - argument_name, - arguments, - thunk, - thunk_name, - } - } -} - -impl fmt::Display for DependentPair { - fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { - write!( - f, - "[{} ({}) {}]", - self.argument_name, - self.arguments.iter().join(" "), - self.thunk_name - ) - } -} - -// The arg positions -> which argument maps to which index in the input -// the pre-conditions - array of dependent pairs -// post-condition - dependent pair -// the rest is the same -#[derive(Clone, PartialEq)] -pub struct DependentContract { - pub(crate) arg_positions: HashMap, - pub(crate) pre_conditions: Box<[DependentPair]>, - pub(crate) post_condition: DependentPair, - pub(crate) contract_attachment_location: Option, - parent: Option>, -} - -fn parse_list(lst: SteelVal) -> Result<(String, Vec, Gc, String)> { - if let SteelVal::ListV(l) = lst { - let mut iter = l.into_iter(); - - let ident = iter - .next() - .ok_or_else(throw!(ArityMismatch => "make-dependent-function/c expected a symbol in the first position"))? - .symbol_or_else(throw!(TypeMismatch => "make-dependent-function/c expected a symbol in the first position"))? - .to_string(); - - let raw_arguments = iter.next().ok_or_else(throw!(ArityMismatch => "make-dependent-function/c expected a list in the second position"))?; - - let arguments = match &raw_arguments { - SteelVal::ListV(l) => { - l.iter() - .map(|x| x.clone_symbol_or_else(throw!(TypeMismatch => "make-dependent-function/c expected a symbol in the list of arguments"))) - .collect::>>() - } - _ => stop!(TypeMismatch => format!("make-dependent-function/c expected a list of symbols, found: {raw_arguments}")), - }?; - - let contract = iter - .next() - .ok_or_else(throw!(ArityMismatch => "make-dependent-function/c expected a contract in the third position"))? - .closure_or_else(throw!(TypeMismatch => "make-dependent-function/c expected a contract in the third position"))?; - - let thunk_name = iter - .next() - .ok_or_else(throw!(ArityMismatch => "make-dependent-function/c expected a name in the fourth position"))? - .to_string(); - - if iter.next().is_some() { - stop!(ArityMismatch => "make-dependent-function/c condition expects 4 arguments, found (at least) 5"); - } - - Ok((ident, arguments, contract, thunk_name)) - } else { - stop!(TypeMismatch => "make-dependent-function/c expects a list"); - } -} - -impl DependentContract { - pub(crate) fn new_from_steelvals( - pre_condition_lists: &[SteelVal], - post_condition_list: SteelVal, - ) -> Result { - let mut arg_positions = HashMap::new(); - let mut pre_conditions = Vec::new(); - - for (index, pre_condition) in pre_condition_lists.iter().enumerate() { - let (ident, arguments, contract, thunk_name) = parse_list(pre_condition.clone())?; - - // Insert the index of the name in order - arg_positions.insert(ident.clone(), index); - - if index == 0 && !arguments.is_empty() { - stop!(ArityMismatch => "dependent contract depends on values not present!"); - } - - if index != 0 { - for argument in &arguments { - if !arg_positions.contains_key(argument) { - stop!(Generic => "dependent contract must depend on variable in scope!"); - } - } - } - - let pre_condition = DependentPair::new(ident, arguments, contract, thunk_name); - pre_conditions.push(pre_condition); - } - - let post_condition = { - let (ident, arguments, contract, thunk_name) = parse_list(post_condition_list)?; - - for argument in &arguments { - if !arg_positions.contains_key(argument) { - stop!(Generic => "dependent contract result (range) condition must depend on one of arguments (domain)"); - } - } - - DependentPair::new(ident, arguments, contract, thunk_name) - }; - - let pre_conditions = pre_conditions.into_boxed_slice(); - let dep_contract = DependentContract { - arg_positions, - pre_conditions, - post_condition, - contract_attachment_location: None, - parent: None, - }; - - Ok(SteelVal::Contract(Gc::new(ContractType::Function( - FunctionKind::Dependent(dep_contract), - )))) - } -} - -impl Contract for DependentContract { - fn arity(&self) -> usize { - self.pre_conditions.len() - } - - fn set_parent(&mut self, p: Gc) { - self.parent = Some(p); - } - - fn parent(&self) -> Option> { - self.parent.as_ref().map(Gc::clone) - } - - fn set_attachment_location(&mut self, loc: Option) { - self.contract_attachment_location = loc - } -} - -pub trait Contract { - fn set_parent(&mut self, p: Gc); - fn parent(&self) -> Option>; - fn set_attachment_location(&mut self, loc: Option); - fn arity(&self) -> usize; -} - -impl fmt::Display for DependentContract { - fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { - write!( - f, - "(->i ({}) {})", - self.pre_conditions.iter().map(|x| x.to_string()).join(" "), - self.post_condition - ) - } -} - -/// Struct for function contracts. Contains all of the necessary information -/// for contract evaluation and blaming, including the pre and post conditions, the contract -/// attachment location, and the parent contract from which this contract was derived (if any) -#[derive(Clone, PartialEq)] -pub struct FunctionContract { - /// List of pre conditions, required to be list of ContractType - pre_conditions: Box<[Gc]>, - /// Post condition, required to be a contract type - post_condition: Gc, - /// Location/Name of contract attachment - pub(crate) contract_attachment_location: Option, - /// Stack of function contracts to also abide by, checked at application - parent: Option>, -} - -impl Contract for FunctionContract { - fn arity(&self) -> usize { - self.pre_conditions.len() - } - - fn set_parent(&mut self, p: Gc) { - self.parent = Some(p); - } - - fn parent(&self) -> Option> { - self.parent.as_ref().map(Gc::clone) - } - - fn set_attachment_location(&mut self, loc: Option) { - self.contract_attachment_location = loc - } -} - -impl fmt::Display for FunctionContract { - fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { - write!( - f, - "(-> {} {})", - self.pre_conditions.iter().map(|x| x.to_string()).join(" "), - *self.post_condition - ) - } -} - -impl FunctionContract { - #[inline(always)] - pub fn new_from_steelval( - pre_conditions: &[SteelVal], - post_condition: SteelVal, - ) -> Result { - let pre_conditions = pre_conditions - .iter() - .map(|x| { - if let SteelVal::Contract(c) = x { - Ok(c.clone()) // TODO find out how to remove this clone - } else { - stop!(TypeMismatch => "Function contract domain requires a list of contracts") - } - }) - .collect::>>()?; - - let post_condition = if let SteelVal::Contract(c) = post_condition { - c - } else { - stop!(TypeMismatch => "function contract range expected a contract, found: {}", post_condition) - }; - - Ok(FunctionContract::new(pre_conditions, post_condition, None, None).into()) - } - - pub fn pre_conditions(&self) -> &[Gc] { - &self.pre_conditions - } - - pub fn post_condition(&self) -> &Gc { - &self.post_condition - } - - pub fn new( - pre_conditions: Box<[Gc]>, - post_condition: Gc, - contract_attachment_location: Option, - parent: Option>, - ) -> Self { - FunctionContract { - pre_conditions, - post_condition, - contract_attachment_location, - parent, - } - } -} - -impl From for SteelVal { - fn from(val: FunctionContract) -> SteelVal { - SteelVal::Contract(Gc::new(ContractType::Function(FunctionKind::Basic(val)))) - } -} - -/// The contract type. `Flat` contracts apply to reified values (non functions) -/// `Function` contracts apply to exactly that - functions. -#[derive(Clone, PartialEq)] -pub enum ContractType { - Flat(FlatContract), - Function(FunctionKind), -} - -#[derive(Clone, PartialEq)] -pub enum FunctionKind { - Basic(FunctionContract), - Dependent(DependentContract), -} - -impl Contract for FunctionKind { - fn arity(&self) -> usize { - match self { - Self::Basic(fc) => fc.arity(), - Self::Dependent(dc) => dc.arity(), - } - } - - fn set_parent(&mut self, p: Gc) { - match self { - Self::Basic(fc) => fc.set_parent(p), - Self::Dependent(dc) => dc.set_parent(p), - } - } - - fn parent(&self) -> Option> { - match self { - Self::Basic(fc) => fc.parent(), - Self::Dependent(dc) => dc.parent(), - } - } - - fn set_attachment_location(&mut self, loc: Option) { - match self { - Self::Basic(fc) => fc.set_attachment_location(loc), - Self::Dependent(dc) => dc.set_attachment_location(loc), - } - } -} - -impl fmt::Display for FunctionKind { - fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { - match self { - Self::Basic(fc) => write!(f, "{fc}"), - Self::Dependent(dc) => write!(f, "{dc}"), - } - } -} - -impl fmt::Display for ContractType { - fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { - match self { - Self::Flat(flat) => write!(f, "{flat}"), - Self::Function(fc) => write!(f, "{fc}"), - } - } -} - -/// Represents a Steel function wrapped with a contract -/// Contains the contract, the function, and the name of the contract (for blaming) -#[derive(Clone)] -pub struct ContractedFunction { - pub contract: FunctionKind, - pub function: SteelVal, - pub name: Option, -} - -impl PartialEq for ContractedFunction { - fn eq(&self, other: &Self) -> bool { - self.contract == other.contract - } -} - -impl ContractedFunction { - pub fn new(contract: FunctionKind, function: SteelVal, name: Option) -> Self { - ContractedFunction { - contract, - function, - name, - } - } - - pub fn arity(&self) -> Option { - if let SteelVal::Closure(func) = &self.function { - Some(func.arity()) - } else { - None - } - } - - #[inline(always)] - pub fn new_from_steelvals( - contract: SteelVal, - function: SteelVal, - name: Option, - ) -> Result { - let name = match name { - Some(SteelVal::SymbolV(s)) => Some(s.to_string()), - Some(_) => stop!(TypeMismatch => "bind/c expected a symbol in the first position"), - None => None, - }; - - let contract = if let SteelVal::Contract(fc) = contract { - if let ContractType::Function(fc) = fc.as_ref() { - fc.clone() - } else { - stop!(TypeMismatch => "bind/c requires a function contract") - } - } else { - stop!(TypeMismatch => "bind/c requires a function contract") - }; - - if !function.is_function() { - stop!(TypeMismatch => "bind/c requires a function"); - } - - // let function = if let SteelVal::Closure(b) = function { - // b.clone() - // } else { - // stop!(TypeMismatch => "bind/c requires a bytecode function, not a primitive") - // }; - - // Check the arity only if we have it - if let SteelVal::Closure(function) = &function { - if contract.arity() != function.arity() { - stop!(TypeMismatch => format!("contract did not match function arity: function has arity: {}, contract has arity: {}", function.arity(), contract.arity())); - } - } - - Ok(ContractedFunction::new(contract, function, name).into()) - } -} - -impl From for SteelVal { - fn from(val: ContractedFunction) -> Self { - SteelVal::ContractedFunction(Gc::new(val)) - } -} +// use crate::gc::Gc; +// use crate::rvals::{Result, SteelVal}; +// use std::collections::HashMap; +// use std::fmt; + +// use crate::parser::ast::IteratorExtensions; + +// use super::functions::ByteCodeLambda; + +// /// Flat contracts are simply predicates to apply to a value. These can be immediately applied +// /// at attachment to a value. +// #[derive(Clone, PartialEq)] +// pub struct FlatContract { +// /// Steel Function of any kind +// pub(crate) predicate: SteelVal, +// /// Name of the function for blaming purposes +// pub(crate) name: String, +// } + +// impl fmt::Display for FlatContract { +// fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { +// write!(f, "{}", self.name) +// } +// } + +// impl FlatContract { +// #[inline(always)] +// pub fn new_from_steelval(predicate: SteelVal, name: String) -> Result { +// if predicate.is_contract() { +// Ok(predicate) +// } else if predicate.is_function() { +// Ok(FlatContract::new(predicate, name).into()) +// } else { +// stop!(TypeMismatch => format!("flat contracts require a function argument, found {predicate}")); +// } +// } + +// pub fn new(predicate: SteelVal, name: String) -> Self { +// FlatContract { predicate, name } +// } + +// pub fn predicate(&self) -> &SteelVal { +// &self.predicate +// } +// } + +// impl From for SteelVal { +// fn from(val: FlatContract) -> SteelVal { +// SteelVal::Contract(Gc::new(ContractType::Flat(val))) +// } +// } + +// // (x) (>= x) -- contains a vector of the arguments and then the contract +// #[derive(Clone, PartialEq)] +// pub(crate) struct DependentPair { +// pub(crate) argument_name: String, +// pub(crate) arguments: Vec, +// pub(crate) thunk: Gc, +// pub(crate) thunk_name: String, +// } + +// impl DependentPair { +// fn new( +// argument_name: String, +// arguments: Vec, +// thunk: Gc, +// thunk_name: String, +// ) -> Self { +// DependentPair { +// argument_name, +// arguments, +// thunk, +// thunk_name, +// } +// } +// } + +// impl fmt::Display for DependentPair { +// fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { +// write!( +// f, +// "[{} ({}) {}]", +// self.argument_name, +// self.arguments.iter().join(" "), +// self.thunk_name +// ) +// } +// } + +// // The arg positions -> which argument maps to which index in the input +// // the pre-conditions - array of dependent pairs +// // post-condition - dependent pair +// // the rest is the same +// #[derive(Clone, PartialEq)] +// pub struct DependentContract { +// pub(crate) arg_positions: HashMap, +// pub(crate) pre_conditions: Box<[DependentPair]>, +// pub(crate) post_condition: DependentPair, +// pub(crate) contract_attachment_location: Option, +// parent: Option>, +// } + +// fn parse_list(lst: SteelVal) -> Result<(String, Vec, Gc, String)> { +// if let SteelVal::ListV(l) = lst { +// let mut iter = l.into_iter(); + +// let ident = iter +// .next() +// .ok_or_else(throw!(ArityMismatch => "make-dependent-function/c expected a symbol in the first position"))? +// .symbol_or_else(throw!(TypeMismatch => "make-dependent-function/c expected a symbol in the first position"))? +// .to_string(); + +// let raw_arguments = iter.next().ok_or_else(throw!(ArityMismatch => "make-dependent-function/c expected a list in the second position"))?; + +// let arguments = match &raw_arguments { +// SteelVal::ListV(l) => { +// l.iter() +// .map(|x| x.clone_symbol_or_else(throw!(TypeMismatch => "make-dependent-function/c expected a symbol in the list of arguments"))) +// .collect::>>() +// } +// _ => stop!(TypeMismatch => format!("make-dependent-function/c expected a list of symbols, found: {raw_arguments}")), +// }?; + +// let contract = iter +// .next() +// .ok_or_else(throw!(ArityMismatch => "make-dependent-function/c expected a contract in the third position"))? +// .closure_or_else(throw!(TypeMismatch => "make-dependent-function/c expected a contract in the third position"))?; + +// let thunk_name = iter +// .next() +// .ok_or_else(throw!(ArityMismatch => "make-dependent-function/c expected a name in the fourth position"))? +// .to_string(); + +// if iter.next().is_some() { +// stop!(ArityMismatch => "make-dependent-function/c condition expects 4 arguments, found (at least) 5"); +// } + +// Ok((ident, arguments, contract, thunk_name)) +// } else { +// stop!(TypeMismatch => "make-dependent-function/c expects a list"); +// } +// } + +// impl DependentContract { +// pub(crate) fn new_from_steelvals( +// pre_condition_lists: &[SteelVal], +// post_condition_list: SteelVal, +// ) -> Result { +// let mut arg_positions = HashMap::new(); +// let mut pre_conditions = Vec::new(); + +// for (index, pre_condition) in pre_condition_lists.iter().enumerate() { +// let (ident, arguments, contract, thunk_name) = parse_list(pre_condition.clone())?; + +// // Insert the index of the name in order +// arg_positions.insert(ident.clone(), index); + +// if index == 0 && !arguments.is_empty() { +// stop!(ArityMismatch => "dependent contract depends on values not present!"); +// } + +// if index != 0 { +// for argument in &arguments { +// if !arg_positions.contains_key(argument) { +// stop!(Generic => "dependent contract must depend on variable in scope!"); +// } +// } +// } + +// let pre_condition = DependentPair::new(ident, arguments, contract, thunk_name); +// pre_conditions.push(pre_condition); +// } + +// let post_condition = { +// let (ident, arguments, contract, thunk_name) = parse_list(post_condition_list)?; + +// for argument in &arguments { +// if !arg_positions.contains_key(argument) { +// stop!(Generic => "dependent contract result (range) condition must depend on one of arguments (domain)"); +// } +// } + +// DependentPair::new(ident, arguments, contract, thunk_name) +// }; + +// let pre_conditions = pre_conditions.into_boxed_slice(); +// let dep_contract = DependentContract { +// arg_positions, +// pre_conditions, +// post_condition, +// contract_attachment_location: None, +// parent: None, +// }; + +// Ok(SteelVal::Contract(Gc::new(ContractType::Function( +// FunctionKind::Dependent(dep_contract), +// )))) +// } +// } + +// impl Contract for DependentContract { +// fn arity(&self) -> usize { +// self.pre_conditions.len() +// } + +// fn set_parent(&mut self, p: Gc) { +// self.parent = Some(p); +// } + +// fn parent(&self) -> Option> { +// self.parent.as_ref().map(Gc::clone) +// } + +// fn set_attachment_location(&mut self, loc: Option) { +// self.contract_attachment_location = loc +// } +// } + +// pub trait Contract { +// fn set_parent(&mut self, p: Gc); +// fn parent(&self) -> Option>; +// fn set_attachment_location(&mut self, loc: Option); +// fn arity(&self) -> usize; +// } + +// impl fmt::Display for DependentContract { +// fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { +// write!( +// f, +// "(->i ({}) {})", +// self.pre_conditions.iter().map(|x| x.to_string()).join(" "), +// self.post_condition +// ) +// } +// } + +// /// Struct for function contracts. Contains all of the necessary information +// /// for contract evaluation and blaming, including the pre and post conditions, the contract +// /// attachment location, and the parent contract from which this contract was derived (if any) +// #[derive(Clone, PartialEq)] +// pub struct FunctionContract { +// /// List of pre conditions, required to be list of ContractType +// pre_conditions: Box<[Gc]>, +// /// Post condition, required to be a contract type +// post_condition: Gc, +// /// Location/Name of contract attachment +// pub(crate) contract_attachment_location: Option, +// /// Stack of function contracts to also abide by, checked at application +// parent: Option>, +// } + +// impl Contract for FunctionContract { +// fn arity(&self) -> usize { +// self.pre_conditions.len() +// } + +// fn set_parent(&mut self, p: Gc) { +// self.parent = Some(p); +// } + +// fn parent(&self) -> Option> { +// self.parent.as_ref().map(Gc::clone) +// } + +// fn set_attachment_location(&mut self, loc: Option) { +// self.contract_attachment_location = loc +// } +// } + +// impl fmt::Display for FunctionContract { +// fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { +// write!( +// f, +// "(-> {} {})", +// self.pre_conditions.iter().map(|x| x.to_string()).join(" "), +// *self.post_condition +// ) +// } +// } + +// impl FunctionContract { +// #[inline(always)] +// pub fn new_from_steelval( +// pre_conditions: &[SteelVal], +// post_condition: SteelVal, +// ) -> Result { +// let pre_conditions = pre_conditions +// .iter() +// .map(|x| { +// if let SteelVal::Contract(c) = x { +// Ok(c.clone()) // TODO find out how to remove this clone +// } else { +// stop!(TypeMismatch => "Function contract domain requires a list of contracts") +// } +// }) +// .collect::>>()?; + +// let post_condition = if let SteelVal::Contract(c) = post_condition { +// c +// } else { +// stop!(TypeMismatch => "function contract range expected a contract, found: {}", post_condition) +// }; + +// Ok(FunctionContract::new(pre_conditions, post_condition, None, None).into()) +// } + +// pub fn pre_conditions(&self) -> &[Gc] { +// &self.pre_conditions +// } + +// pub fn post_condition(&self) -> &Gc { +// &self.post_condition +// } + +// pub fn new( +// pre_conditions: Box<[Gc]>, +// post_condition: Gc, +// contract_attachment_location: Option, +// parent: Option>, +// ) -> Self { +// FunctionContract { +// pre_conditions, +// post_condition, +// contract_attachment_location, +// parent, +// } +// } +// } + +// impl From for SteelVal { +// fn from(val: FunctionContract) -> SteelVal { +// SteelVal::Contract(Gc::new(ContractType::Function(FunctionKind::Basic(val)))) +// } +// } + +// /// The contract type. `Flat` contracts apply to reified values (non functions) +// /// `Function` contracts apply to exactly that - functions. +// #[derive(Clone, PartialEq)] +// pub enum ContractType { +// Flat(FlatContract), +// Function(FunctionKind), +// } + +// #[derive(Clone, PartialEq)] +// pub enum FunctionKind { +// Basic(FunctionContract), +// Dependent(DependentContract), +// } + +// impl Contract for FunctionKind { +// fn arity(&self) -> usize { +// match self { +// Self::Basic(fc) => fc.arity(), +// Self::Dependent(dc) => dc.arity(), +// } +// } + +// fn set_parent(&mut self, p: Gc) { +// match self { +// Self::Basic(fc) => fc.set_parent(p), +// Self::Dependent(dc) => dc.set_parent(p), +// } +// } + +// fn parent(&self) -> Option> { +// match self { +// Self::Basic(fc) => fc.parent(), +// Self::Dependent(dc) => dc.parent(), +// } +// } + +// fn set_attachment_location(&mut self, loc: Option) { +// match self { +// Self::Basic(fc) => fc.set_attachment_location(loc), +// Self::Dependent(dc) => dc.set_attachment_location(loc), +// } +// } +// } + +// impl fmt::Display for FunctionKind { +// fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { +// match self { +// Self::Basic(fc) => write!(f, "{fc}"), +// Self::Dependent(dc) => write!(f, "{dc}"), +// } +// } +// } + +// impl fmt::Display for ContractType { +// fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { +// match self { +// Self::Flat(flat) => write!(f, "{flat}"), +// Self::Function(fc) => write!(f, "{fc}"), +// } +// } +// } + +// /// Represents a Steel function wrapped with a contract +// /// Contains the contract, the function, and the name of the contract (for blaming) +// #[derive(Clone)] +// pub struct ContractedFunction { +// pub contract: FunctionKind, +// pub function: SteelVal, +// pub name: Option, +// } + +// impl PartialEq for ContractedFunction { +// fn eq(&self, other: &Self) -> bool { +// self.contract == other.contract +// } +// } + +// impl ContractedFunction { +// pub fn new(contract: FunctionKind, function: SteelVal, name: Option) -> Self { +// ContractedFunction { +// contract, +// function, +// name, +// } +// } + +// pub fn arity(&self) -> Option { +// if let SteelVal::Closure(func) = &self.function { +// Some(func.arity()) +// } else { +// None +// } +// } + +// #[inline(always)] +// pub fn new_from_steelvals( +// contract: SteelVal, +// function: SteelVal, +// name: Option, +// ) -> Result { +// let name = match name { +// Some(SteelVal::SymbolV(s)) => Some(s.to_string()), +// Some(_) => stop!(TypeMismatch => "bind/c expected a symbol in the first position"), +// None => None, +// }; + +// let contract = if let SteelVal::Contract(fc) = contract { +// if let ContractType::Function(fc) = fc.as_ref() { +// fc.clone() +// } else { +// stop!(TypeMismatch => "bind/c requires a function contract") +// } +// } else { +// stop!(TypeMismatch => "bind/c requires a function contract") +// }; + +// if !function.is_function() { +// stop!(TypeMismatch => "bind/c requires a function"); +// } + +// // let function = if let SteelVal::Closure(b) = function { +// // b.clone() +// // } else { +// // stop!(TypeMismatch => "bind/c requires a bytecode function, not a primitive") +// // }; + +// // Check the arity only if we have it +// if let SteelVal::Closure(function) = &function { +// if contract.arity() != function.arity() { +// stop!(TypeMismatch => format!("contract did not match function arity: function has arity: {}, contract has arity: {}", function.arity(), contract.arity())); +// } +// } + +// Ok(ContractedFunction::new(contract, function, name).into()) +// } +// } + +// impl From for SteelVal { +// fn from(val: ContractedFunction) -> Self { +// SteelVal::ContractedFunction(Gc::new(val)) +// } +// } diff --git a/crates/steel-core/src/values/functions.rs b/crates/steel-core/src/values/functions.rs index 3e0e5747e..073294124 100644 --- a/crates/steel-core/src/values/functions.rs +++ b/crates/steel-core/src/values/functions.rs @@ -24,8 +24,9 @@ use crate::{ register_fn::SendSyncStatic, vm::{BlockMetadata, BlockPattern, BuiltInSignature}, }, - values::contracts::ContractedFunction, - SteelErr, SteelVal, + // values::contracts::ContractedFunction, + SteelErr, + SteelVal, }; use super::{closed::HeapRef, structs::UserDefinedStruct}; @@ -99,14 +100,14 @@ pub struct ByteCodeLambda { call_count: Cell, pub(crate) is_multi_arity: bool, - captures: Vec, - pub(crate) heap_allocated: RefCell>, + pub(crate) captures: Vec, + pub(crate) heap_allocated: RefCell>>, // pub(crate) spans: Rc<[Span]>, #[cfg(feature = "dynamic")] pub(crate) blocks: RefCell>, // This is a little suspicious, but it should give us the necessary information to attach a struct of metadata - contract: RefCell>>>, + contract: RefCell>>, } impl PartialEq for ByteCodeLambda { @@ -123,6 +124,7 @@ impl std::hash::Hash for ByteCodeLambda { self.id.hash(state); // self.body_exp.as_ptr().hash(state); self.arity.hash(state); + // self.sub_expression_env.as_ptr().hash(state); } } @@ -142,14 +144,19 @@ pub struct SerializedLambda { impl TryFrom for SerializedLambda { type Error = SteelErr; - fn try_from(value: ByteCodeLambda) -> Result { + fn try_from(mut value: ByteCodeLambda) -> Result { Ok(SerializedLambda { id: value.id, + + #[cfg(not(feature = "dynamic"))] body_exp: value.body_exp.into_iter().cloned().collect(), + + #[cfg(feature = "dynamic")] + body_exp: value.body_exp.borrow().iter().cloned().collect(), + arity: value.arity, is_multi_arity: value.is_multi_arity, - captures: value - .captures + captures: std::mem::take(&mut value.captures) .into_iter() .map(into_serializable_value) .collect::>()?, @@ -185,7 +192,7 @@ impl ByteCodeLambda { arity: usize, is_multi_arity: bool, captures: Vec, - heap_allocated: Vec, + heap_allocated: Vec>, ) -> ByteCodeLambda { // debug_assert_eq!(body_exp.len(), spans.len()); @@ -236,7 +243,7 @@ impl ByteCodeLambda { self.captures = captures; } - pub fn set_heap_allocated(&mut self, heap_allocated: Vec) { + pub fn set_heap_allocated(&mut self, heap_allocated: Vec>) { self.heap_allocated = RefCell::new(heap_allocated); } @@ -288,7 +295,7 @@ impl ByteCodeLambda { self.arity } - pub fn heap_allocated(&self) -> &RefCell> { + pub fn heap_allocated(&self) -> &RefCell>> { &self.heap_allocated } @@ -316,7 +323,7 @@ impl ByteCodeLambda { // self.cant_be_compiled.get() // } - pub fn attach_contract_information(&self, steel_struct: Gc>) { + pub fn attach_contract_information(&self, steel_struct: Gc) { let mut guard = self.contract.borrow_mut(); *guard = Some(steel_struct); diff --git a/crates/steel-core/src/values/json_vals.rs b/crates/steel-core/src/values/json_vals.rs index 0cfbe3ec2..b3ea128e7 100644 --- a/crates/steel-core/src/values/json_vals.rs +++ b/crates/steel-core/src/values/json_vals.rs @@ -1,16 +1,14 @@ +use crate::values::lists::List; use crate::{ gc::Gc, rerrs::SteelErr, rvals::{FromSteelVal, IntoSteelVal, Result, SteelVal}, throw, }; -use im_lists::list::List; use im_rc::HashMap; use serde_json::{Map, Number, Value}; use std::convert::{TryFrom, TryInto}; -// use list - pub fn string_to_jsexpr() -> SteelVal { SteelVal::FuncV(|args: &[SteelVal]| -> Result { if args.len() != 1 { @@ -79,7 +77,7 @@ impl TryFrom> for SteelVal { for (key, value) in map { hm.insert(SteelVal::SymbolV(key.into()), value.try_into()?); } - Ok(SteelVal::HashMapV(Gc::new(hm))) + Ok(SteelVal::HashMapV(Gc::new(hm).into())) } } @@ -202,10 +200,13 @@ mod json_tests { let result = apply_function(string_to_jsexpr(), args); - let expected = SteelVal::HashMapV(Gc::new(hashmap! { - SymbolV("a".into()) => StringV("applesauce".into()), - SymbolV("b".into()) => StringV("bananas".into()) - })); + let expected = SteelVal::HashMapV( + Gc::new(hashmap! { + SymbolV("a".into()) => StringV("applesauce".into()), + SymbolV("b".into()) => StringV("bananas".into()) + }) + .into(), + ); assert_eq!(result.unwrap(), expected); } diff --git a/crates/steel-core/src/values/lists.rs b/crates/steel-core/src/values/lists.rs new file mode 100644 index 000000000..ee809d933 --- /dev/null +++ b/crates/steel-core/src/values/lists.rs @@ -0,0 +1,93 @@ +use std::cell::Cell; + +use im_lists::handler::DropHandler; + +use crate::SteelVal; + +#[cfg(feature = "without-drop-protection")] +type DropHandlerChoice = im_lists::handler::DefaultDropHandler; +#[cfg(not(feature = "without-drop-protection"))] +type DropHandlerChoice = list_drop_handler::ListDropHandler; + +thread_local! { + pub static DEPTH: Cell = Cell::new(0); +} + +#[cfg(not(feature = "without-drop-protection"))] +mod list_drop_handler { + + use std::collections::VecDeque; + + use super::*; + + pub struct ListDropHandler; + + use crate::rvals::cycles::{drop_impls::DROP_BUFFER, IterativeDropHandler}; + + impl + DropHandler< + im_lists::list::GenericList, + > for ListDropHandler + { + fn drop_handler( + obj: &mut im_lists::list::GenericList< + SteelVal, + im_lists::shared::RcPointer, + 256, + 1, + Self, + >, + ) { + // println!("CALLING DROP HANDLER: {}", obj.strong_count()); + // DEPTH.with(|x| x.set(x.get() + 1)); + // println!("Current depth: {}", DEPTH.with(|x| x.get())); + + if obj.strong_count() == 1 { + if obj.len() == 0 { + // println!("Early returning"); + // DEPTH.with(|x| x.set(x.get() - 1)); + return; + } + + // println!("Doing stuff..."); + + if DROP_BUFFER + .try_with(|drop_buffer| { + if let Ok(mut drop_buffer) = drop_buffer.try_borrow_mut() { + for value in std::mem::take(obj).draining_iterator() { + drop_buffer.push_back(value); + } + + IterativeDropHandler::bfs(&mut drop_buffer); + } else { + let mut drop_buffer = VecDeque::new(); + + for value in std::mem::take(obj) { + drop_buffer.push_back(value); + } + + IterativeDropHandler::bfs(&mut drop_buffer); + } + }) + .is_err() + { + let mut drop_buffer = VecDeque::new(); + for value in std::mem::take(obj).draining_iterator() { + drop_buffer.push_back(value); + } + + IterativeDropHandler::bfs(&mut drop_buffer); + } + } + + // DEPTH.with(|x| x.set(x.get() - 1)); + } + } +} + +// TODO: Change this to just be something like `SteelList` +pub type List = + im_lists::list::GenericList; + +pub type ConsumingIterator = + im_lists::list::ConsumingIter; diff --git a/crates/steel-core/src/values/mod.rs b/crates/steel-core/src/values/mod.rs index b01bfbf3d..5d7cea4c7 100644 --- a/crates/steel-core/src/values/mod.rs +++ b/crates/steel-core/src/values/mod.rs @@ -4,7 +4,12 @@ pub(crate) mod contracts; pub(crate) mod functions; pub(crate) mod json_vals; pub(crate) mod lazy_stream; +pub(crate) mod lists; pub(crate) mod port; pub(crate) mod structs; pub(crate) mod transducers; + +pub use closed::RootToken; +pub use closed::RootedSteelVal; + // pub(crate) mod upvalue; diff --git a/crates/steel-core/src/values/structs.rs b/crates/steel-core/src/values/structs.rs index 983c269a6..6141610a0 100644 --- a/crates/steel-core/src/values/structs.rs +++ b/crates/steel-core/src/values/structs.rs @@ -6,7 +6,7 @@ use once_cell::sync::Lazy; use crate::compiler::map::SymbolMap; use crate::parser::interner::InternedString; -use crate::rvals::Custom; +use crate::rvals::{Custom, SteelHashMap}; use crate::steel_vm::register_fn::RegisterFn; use crate::throw; use crate::{ @@ -22,6 +22,7 @@ use crate::{ SteelErr, }; use crate::{steel_vm::builtin::BuiltInModule, stop}; +use std::collections::VecDeque; use std::sync::Arc; use std::{ cell::{Ref, RefCell}, @@ -79,9 +80,15 @@ pub struct StructTypeDescriptor(usize); impl Custom for StructTypeDescriptor {} +impl StructTypeDescriptor { + fn name(&self) -> InternedString { + VTABLE.with(|x| x.borrow().entries[self.0].name) + } +} + #[derive(Clone, Debug, Hash)] pub struct UserDefinedStruct { - pub(crate) name: InternedString, + // pub(crate) name: InternedString, // TODO: Consider using... just a vec here. #[cfg(feature = "smallvec")] @@ -94,13 +101,22 @@ pub struct UserDefinedStruct { pub(crate) type_descriptor: StructTypeDescriptor, } +impl UserDefinedStruct { + pub fn name(&self) -> InternedString { + self.type_descriptor.name() + } + + pub fn is_transparent(&self) -> bool { + self.get(&TRANSPARENT_KEY.with(|x| x.clone())) + .and_then(|x| x.as_bool()) + .unwrap_or_default() + } +} + // TODO: This could blow the stack for big trees... impl PartialEq for UserDefinedStruct { fn eq(&self, other: &Self) -> bool { - self.type_descriptor == other.type_descriptor - && self.name == other.name - && self.fields == other.fields - // && Properties::ptr_eq(&self.properties, &other.properties) + self.type_descriptor == other.type_descriptor && self.fields == other.fields } } @@ -110,18 +126,18 @@ impl std::fmt::Display for UserDefinedStruct { .get(&SteelVal::SymbolV(SteelString::from("#:transparent"))) .is_some() { - write!(f, "({}", self.name)?; + write!(f, "({}", self.type_descriptor.name())?; // for i in 0..self.len - 1 { // write!(f, " {}", self.fields[i])?; // } - for i in &self.fields { + for i in self.fields.iter() { write!(f, " {}", i)?; } write!(f, ")") } else { - write!(f, "({})", self.name) + write!(f, "({})", self.name()) } } } @@ -286,7 +302,7 @@ impl ImmutableMaybeHeapVec { impl UserDefinedStruct { fn new( - name: InternedString, + // name: InternedString, type_descriptor: StructTypeDescriptor, fields: &[SteelVal], ) -> Self { @@ -301,8 +317,8 @@ impl UserDefinedStruct { // todo!() Self { - name, - fields: fields.into(), + // name, + fields: fields.to_vec(), // properties: Properties::BuiltIn, // proc: None, type_descriptor, @@ -365,7 +381,7 @@ impl UserDefinedStruct { #[inline(always)] fn is_ok(&self) -> bool { // todo!() - self.name == *OK_RESULT_LABEL + self.type_descriptor.name() == *OK_RESULT_LABEL // Arc::ptr_eq(&self.name, &OK_RESULT_LABEL.with(|x| Rc::clone(x))) // || self.name == OK_RESULT_LABEL.with(|x| Rc::clone(x)) } @@ -373,7 +389,7 @@ impl UserDefinedStruct { #[inline(always)] fn is_err(&self) -> bool { // todo!() - self.name == *ERR_RESULT_LABEL + self.type_descriptor.name() == *ERR_RESULT_LABEL // Arc::ptr_eq(&self.name, &ERR_RESULT_LABEL.with(|x| Rc::clone(x))) // || self.name == ERR_RESULT_LABEL.with(|x| Rc::clone(x)) } @@ -390,14 +406,14 @@ impl UserDefinedStruct { } fn new_with_options( - name: InternedString, + // name: InternedString, properties: Properties, type_descriptor: StructTypeDescriptor, rest: &[SteelVal], ) -> Self { Self { - name, - fields: rest.into(), + // name, + fields: rest.to_vec(), // len: rest.len() + 1, // properties, // proc: None, @@ -406,7 +422,6 @@ impl UserDefinedStruct { } fn constructor_thunk( - name: InternedString, // options: Properties, len: usize, descriptor: StructTypeDescriptor, @@ -415,7 +430,7 @@ impl UserDefinedStruct { if args.len() != len { let error_message = format!( "{} expected {} arguments, found {}", - name.clone(), + descriptor.name(), args.len(), len ); @@ -423,14 +438,13 @@ impl UserDefinedStruct { } let new_struct = - UserDefinedStruct::new_with_options(name, Properties::BuiltIn, descriptor, args); + UserDefinedStruct::new_with_options(Properties::BuiltIn, descriptor, args); - Ok(SteelVal::CustomStruct(Gc::new(RefCell::new(new_struct)))) + Ok(SteelVal::CustomStruct(Gc::new(new_struct))) } } fn constructor_with_options( - name: InternedString, // options: Gc>, // options: Properties, len: usize, @@ -442,7 +456,7 @@ impl UserDefinedStruct { if args.len() != len { let error_message = format!( "{} expected {} arguments, found {}", - name.clone(), + descriptor.name().clone(), args.len(), len ); @@ -450,14 +464,14 @@ impl UserDefinedStruct { } let new_struct = - UserDefinedStruct::new_with_options(name, Properties::BuiltIn, descriptor, args); + UserDefinedStruct::new_with_options(Properties::BuiltIn, descriptor, args); - Ok(SteelVal::CustomStruct(Gc::new(RefCell::new(new_struct)))) + Ok(SteelVal::CustomStruct(Gc::new(new_struct))) }; SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( Arc::new(f), - Some(name.resolve().to_string().into()), + Some(descriptor.name().resolve().to_string().into()), Some(len), ))) } @@ -482,9 +496,9 @@ impl UserDefinedStruct { // Definitely use interned symbols for these. Otherwise we're going to be doing A LOT of // arc cloning, and we don't want that. - let new_struct = UserDefinedStruct::new(name, type_descriptor, args); + let new_struct = UserDefinedStruct::new(type_descriptor, args); - Ok(SteelVal::CustomStruct(Gc::new(RefCell::new(new_struct)))) + Ok(SteelVal::CustomStruct(Gc::new(new_struct))) }; SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( @@ -495,17 +509,22 @@ impl UserDefinedStruct { ))) } - fn predicate(name: InternedString) -> SteelVal { + fn predicate(descriptor: StructTypeDescriptor) -> SteelVal { // let out_name = Arc::clone(&name); let f = move |args: &[SteelVal]| -> Result { if args.len() != 1 { - let error_message = - format!("{}? expected one argument, found {}", name, args.len()); + let error_message = format!( + "{}? expected one argument, found {}", + descriptor.name(), + args.len() + ); stop!(ArityMismatch => error_message); } Ok(SteelVal::BoolV(match &args[0] { - SteelVal::CustomStruct(my_struct) if my_struct.borrow().name == name => true, + SteelVal::CustomStruct(my_struct) if my_struct.type_descriptor == descriptor => { + true + } // SteelVal::CustomStruct(my_struct) if my_struct.name == name => true, _ => false, })) @@ -514,17 +533,17 @@ impl UserDefinedStruct { SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( Arc::new(f), // Some(out_name), - Some(name.resolve().to_string().into()), + Some(descriptor.name().resolve().to_string().into()), Some(1), ))) } - fn getter_prototype(name: InternedString) -> SteelVal { + fn getter_prototype(descriptor: StructTypeDescriptor) -> SteelVal { // let out_name = Arc::clone(&name); let f = move |args: &[SteelVal]| -> Result { if args.len() != 2 { - stop!(ArityMismatch => format!("{} expected two arguments", name)); + stop!(ArityMismatch => format!("{} expected two arguments", descriptor.name())); } let steel_struct = &args[0].clone(); @@ -532,25 +551,27 @@ impl UserDefinedStruct { match (&steel_struct, &idx) { (SteelVal::CustomStruct(s), SteelVal::IntV(idx)) => { - if s.borrow().name != name { + if s.type_descriptor != descriptor { // println!("{}, {}", s.borrow().name.resolve(), name.resolve()); - stop!(TypeMismatch => format!("Struct getter expected {}, found {:?}, {:?}", name, &s, &steel_struct)); + stop!(TypeMismatch => format!("Struct getter expected {}, found {:?}, {:?}", descriptor.name(), &s, &steel_struct)); } if *idx < 0 { stop!(Generic => "struct-ref expected a non negative index"); } - s.borrow() - .fields + s.fields .get(*idx as usize) .cloned() .ok_or_else(throw!(Generic => "struct-ref: index out of bounds")) } _ => { let error_message = format!( - "{name} expected a struct and an int, found: {steel_struct} and {idx}" + "{} expected a struct and an int, found: {} and {}", + descriptor.name(), + steel_struct, + idx ); stop!(TypeMismatch => error_message) } @@ -560,12 +581,12 @@ impl UserDefinedStruct { SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( Arc::new(f), // Some(out_name), - Some(name.resolve().to_string().into()), + Some(descriptor.name().resolve().to_string().into()), Some(2), ))) } - fn getter_prototype_index(name: InternedString, index: usize) -> SteelVal { + fn getter_prototype_index(descriptor: StructTypeDescriptor, index: usize) -> SteelVal { // let out_name = Arc::clone(&name); let f = move |args: &[SteelVal]| -> Result { @@ -579,19 +600,21 @@ impl UserDefinedStruct { SteelVal::CustomStruct(s) => { // println!("{}, {}", s.borrow().name.resolve(), name.resolve()); - if s.borrow().name != name { - stop!(TypeMismatch => format!("Struct getter expected {}, found {:?}, {:?}", name, &s, &steel_struct)); + if s.type_descriptor != descriptor { + stop!(TypeMismatch => format!("Struct getter expected {}, found {:?}, {:?}", descriptor.name(), &s, &steel_struct)); } - s.borrow() - .fields + s.fields .get(index) .cloned() .ok_or_else(throw!(Generic => "struct-ref: index out of bounds")) } _ => { let error_message = format!( - "{name} expected a struct and an int, found: {steel_struct} and {index}" + "{} expected a struct and an int, found: {} and {}", + descriptor.name(), + steel_struct, + index ); stop!(TypeMismatch => error_message) } @@ -600,62 +623,11 @@ impl UserDefinedStruct { SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( Arc::new(f), - // Some(out_name), - Some(name.resolve().to_string().into()), + Some(descriptor.name().resolve().to_string().into()), Some(1), ))) } - fn setter_prototype(name: InternedString) -> SteelVal { - // let out_name = Arc::clone(&name); - - let f = move |args: &[SteelVal]| -> Result { - if args.len() != 3 { - stop!(ArityMismatch => "struct-ref expected 3 arguments"); - } - - let steel_struct = &args[0].clone(); - let idx = &args[1].clone(); - let arg = &args[2].clone(); - - match (&steel_struct, &idx) { - (SteelVal::CustomStruct(s), SteelVal::IntV(idx)) => { - if s.borrow().name != name { - stop!(TypeMismatch => format!("Struct setter expected {}, found {}", name, &s.borrow().name)); - } - - if *idx < 0 { - stop!(Generic => "struct-ref expected a non negative index"); - } - if *idx as usize >= s.borrow().fields.len() { - stop!(Generic => "struct-ref: index out of bounds"); - } - - let mut guard = s.borrow_mut(); - - let old = guard.fields[*idx as usize].clone(); - - guard.fields[*idx as usize] = arg.clone(); - - Ok(old) - } - _ => { - let error_message = format!( - "struct-ref expected a struct and an int, found: {steel_struct} and {idx}" - ); - stop!(TypeMismatch => error_message) - } - } - }; - - SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( - Arc::new(f), - // Some(out_name), - Some(name.resolve().to_string().into()), - Some(3), - ))) - } - // pub fn properties(&self) -> SteelVal { // SteelVal::HashMapV(self.properties.clone()) // } @@ -686,23 +658,24 @@ pub fn make_struct_type(args: &[SteelVal]) -> Result { // Build out the constructor and the predicate let struct_constructor = UserDefinedStruct::constructor(name, *field_count as usize, struct_type_descriptor); - let struct_predicate = UserDefinedStruct::predicate(name); + let struct_predicate = UserDefinedStruct::predicate(struct_type_descriptor); - let getter_prototype = UserDefinedStruct::getter_prototype(name); - let setter_prototype = UserDefinedStruct::setter_prototype(name); + let getter_prototype = UserDefinedStruct::getter_prototype(struct_type_descriptor); // We do not have the properties yet. Should probably intern the // let struct_type_id = new_type_id(name, address_or_name) - Ok(SteelVal::ListV(im_lists::list![ - // Convert this into a descriptor before we're done - struct_type_descriptor.into_steelval().unwrap(), - struct_constructor, - struct_predicate, - getter_prototype, - setter_prototype, - // struct_type_descriptor, - ])) + Ok(SteelVal::ListV( + vec![ + // Convert this into a descriptor before we're done + struct_type_descriptor.into_steelval().unwrap(), + struct_constructor, + struct_predicate, + getter_prototype, + // struct_type_descriptor, + ] + .into(), + )) } /* @@ -894,8 +867,6 @@ thread_local! { // }); pub static OK_CONSTRUCTOR: Rc Result>> = { Rc::new(Box::new(UserDefinedStruct::constructor_thunk( - *OK_RESULT_LABEL, - // RESULT_OPTIONS.with(|x| Gc::clone(x)), 1, OK_DESCRIPTOR.with(|x| *x), ))) @@ -904,9 +875,6 @@ thread_local! { pub static ERR_CONSTRUCTOR: Rc Result>> = { // let name = ERR_RESULT_LABEL.with(|x| Rc::clone(x)); Rc::new(Box::new(UserDefinedStruct::constructor_thunk( - // Rc::clone(&name), - *ERR_RESULT_LABEL, - // RESULT_OPTIONS.with(|x| Gc::clone(x)), 1, ERR_DESCRIPTOR.with(|x| *x), ))) @@ -920,9 +888,6 @@ thread_local! { pub static SOME_CONSTRUCTOR: Rc Result>> = { // let name = SOME_OPTION_LABEL.with(|x| Rc::clone(x)); Rc::new(Box::new(UserDefinedStruct::constructor_thunk( - // Rc::clone(&name), - *SOME_OPTION_LABEL, - // OPTION_OPTIONS.with(|x| Gc::clone(x)), 1, SOME_DESCRIPTOR.with(|x| *x), ))) @@ -931,9 +896,6 @@ thread_local! { pub static NONE_CONSTRUCTOR: Rc Result>> = { // let name = NONE_LABEL.with(|x| Rc::clone(x)); Rc::new(Box::new(UserDefinedStruct::constructor_thunk( - // Rc::clone(&name), - *NONE_OPTION_LABEL, - // OPTION_OPTIONS.with(|x| Gc::clone(x)), 0, NONE_DESCRIPTOR.with(|x| *x), ))) @@ -948,14 +910,10 @@ pub(crate) fn build_type_id_module() -> BuiltInModule { let type_descriptor = VTable::new_entry(name, None); // Build the getter for the first index - let getter = UserDefinedStruct::getter_prototype_index(name, 0); - let predicate = UserDefinedStruct::predicate(name); + let getter = UserDefinedStruct::getter_prototype_index(type_descriptor, 0); + let predicate = UserDefinedStruct::predicate(type_descriptor); - let constructor = Arc::new(UserDefinedStruct::constructor_thunk( - name, - 2, - type_descriptor, - )); + let constructor = Arc::new(UserDefinedStruct::constructor_thunk(2, type_descriptor)); module .register_fn("#%vtable-update-entry!", VTable::set_entry) @@ -980,9 +938,11 @@ pub(crate) fn build_result_structs() -> BuiltInModule { { let name = *OK_RESULT_LABEL; + let type_descriptor = OK_DESCRIPTOR.with(|x| *x); + // Build the getter for the first index - let getter = UserDefinedStruct::getter_prototype_index(name, 0); - let predicate = UserDefinedStruct::predicate(name); + let getter = UserDefinedStruct::getter_prototype_index(type_descriptor, 0); + let predicate = UserDefinedStruct::predicate(type_descriptor); VTable::set_entry( &OK_DESCRIPTOR.with(|x| *x), @@ -995,7 +955,6 @@ pub(crate) fn build_result_structs() -> BuiltInModule { None, STANDARD_OPTIONS.with(|x| x.clone()), ); - // VTable::set_entry(OK_DESCRIPTOR, None, ) module .register_value( @@ -1003,7 +962,6 @@ pub(crate) fn build_result_structs() -> BuiltInModule { SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( Arc::new(UserDefinedStruct::constructor_thunk( // Rc::clone(&name), - name, // RESULT_OPTIONS.with(|x| Gc::clone(x)), 1, OK_DESCRIPTOR.with(|x| *x), )), @@ -1019,11 +977,14 @@ pub(crate) fn build_result_structs() -> BuiltInModule { { // let name = ERR_RESULT_LABEL.with(|x| Rc::clone(x)); let name = *ERR_RESULT_LABEL; + + let type_descriptor = ERR_DESCRIPTOR.with(|x| *x); + // let constructor = UserDefinedStruct::constructor(Rc::clone(&name), 1); - let predicate = UserDefinedStruct::predicate(name); + let predicate = UserDefinedStruct::predicate(type_descriptor); // Build the getter for the first index - let getter = UserDefinedStruct::getter_prototype_index(name, 0); + let getter = UserDefinedStruct::getter_prototype_index(type_descriptor, 0); module .register_value( @@ -1031,7 +992,6 @@ pub(crate) fn build_result_structs() -> BuiltInModule { SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( Arc::new(UserDefinedStruct::constructor_thunk( // Rc::clone(&name), - name, // RESULT_OPTIONS.with(|x| Gc::clone(x)), 1, ERR_DESCRIPTOR.with(|x| *x), )), @@ -1065,10 +1025,11 @@ pub(crate) fn build_option_structs() -> BuiltInModule { { // let name = SOME_OPTION_LABEL.with(|x| Rc::clone(x)); let name = *SOME_OPTION_LABEL; + let type_descriptor = SOME_DESCRIPTOR.with(|x| *x); // Build the getter for the first index - let getter = UserDefinedStruct::getter_prototype_index(name, 0); - let predicate = UserDefinedStruct::predicate(name); + let getter = UserDefinedStruct::getter_prototype_index(type_descriptor, 0); + let predicate = UserDefinedStruct::predicate(type_descriptor); module .register_value( @@ -1076,7 +1037,6 @@ pub(crate) fn build_option_structs() -> BuiltInModule { SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( Arc::new(UserDefinedStruct::constructor_thunk( // Rc::clone(&name), - name, // OPTION_OPTIONS.with(|x| Gc::clone(x)), 1, SOME_DESCRIPTOR.with(|x| *x), )), @@ -1091,15 +1051,14 @@ pub(crate) fn build_option_structs() -> BuiltInModule { { // let name = NONE_LABEL.with(|x| Rc::clone(x)); let name = *NONE_OPTION_LABEL; - // let constructor = UserDefinedStruct::constructor(Rc::clone(&name), 1); - let predicate = UserDefinedStruct::predicate(name); + let type_descriptor = NONE_DESCRIPTOR.with(|x| *x); + let predicate = UserDefinedStruct::predicate(type_descriptor); module .register_value( "None", SteelVal::BoxedFunction(Rc::new(BoxedDynFunction::new_owned( Arc::new(UserDefinedStruct::constructor_thunk( - name, // OPTION_OPTIONS.with(|x| Gc::clone(x)), 0, NONE_DESCRIPTOR.with(|x| *x), )), @@ -1142,10 +1101,10 @@ impl IntoSteelVal for std::result::Result FromSteelVal for std::result::Result { fn from_steelval(val: &SteelVal) -> Result { if let SteelVal::CustomStruct(s) = val { - if s.borrow().is_ok() { - Ok(Ok(T::from_steelval(s.borrow().fields.get(0).unwrap())?)) - } else if s.borrow().is_err() { - Ok(Err(E::from_steelval(s.borrow().fields.get(0).unwrap())?)) + if s.is_ok() { + Ok(Ok(T::from_steelval(s.fields.get(0).unwrap())?)) + } else if s.is_err() { + Ok(Err(E::from_steelval(s.fields.get(0).unwrap())?)) } else { stop!(ConversionError => format!("Failed attempting to convert an instance of a steelval into a result type: {val:?}")) } diff --git a/crates/steel-gen/src/lib.rs b/crates/steel-gen/src/lib.rs index d2eba5e8b..c6718252d 100644 --- a/crates/steel-gen/src/lib.rs +++ b/crates/steel-gen/src/lib.rs @@ -22,7 +22,7 @@ enum TypeHint { None, } -#[derive(Clone, Debug)] +#[derive(PartialEq, Clone, Debug)] struct LocalVariable { id: u16, type_hint: TypeHint, @@ -144,12 +144,18 @@ impl StackToSSAConverter { .map(|x| format!("{x}").to_lowercase()) .join("_"), ); + + function.vis("pub(crate)"); + function.arg("ctx", codegen::Type::new("&mut VmCore<'_>")); function.arg("payload", codegen::Type::new("usize")); function.ret(codegen::Type::new("Result<()>")); let mut lines = FunctionLines::default(); + lines.line("use OpCode::*;"); + lines.line("use steel_gen::Pattern::*;"); + let mut max_local_offset_read = 0; let mut max_ip_read = 0; @@ -176,6 +182,14 @@ impl StackToSSAConverter { self.local_offset = Some(*n); lines.line("ctx.ip += 1;"); } + + Single(PUSHCONST) => { + let local = self.push(); + lines.line(format!( + "let {local} = opcode_to_ssa_handler!(PUSHCONST)(ctx)?;" + )); + } + // Single(LetVar) => { // let local = self.pop(); // function.line(format!("ctx.stack.push({}.into());", local)); @@ -282,7 +296,16 @@ impl StackToSSAConverter { } else { let local = self.push(); let var = self.stack.get(0).unwrap(); - lines.line(format!("let {local} = {var}.clone();")); + + if &local == var { + lines.line(format!( + "let {} = {}(ctx)?;", + local, + op_code_to_handler(*op) + )); + } else { + lines.line(format!("let {local} = {var}.clone();")); + } } } Single(READLOCAL1) => { @@ -300,7 +323,25 @@ impl StackToSSAConverter { } else { let local = self.push(); let var = self.stack.get(1).unwrap(); - lines.line(format!("let {local} = {var}.clone();")); + + if &local == var { + // let local = self.pop(); + + let var = self.stack.get(0).unwrap(); + + lines.line(format!("let {local} = {var}.clone();")); + lines.line("ctx.ip += 1;") + + // lines.line(format!( + // "let {} = {}(ctx)?;", + // local, + // op_code_to_handler(*op) + // )); + } else { + lines.line(format!("let {local} = {var}.clone();")); + } + + // lines.line(format!("let {local} = {var}.clone();")); } } Single(READLOCAL2) => { @@ -484,7 +525,8 @@ impl StackToSSAConverter { let local = self.push_with_hint(TypeHint::Bool); lines.line(format!("let {local} = {left} == {right};")); - lines.line("ctx.ip += 1;"); + // TODO: This is going to need to be + // lines.line("ctx.ip += 1;"); max_ip_read += 1; } (TypeHint::Int, TypeHint::Int) => { @@ -558,6 +600,20 @@ impl StackToSSAConverter { } } + Double(ADDIMMEDIATE, imm) => { + let right = self.pop(); + + lines.line("ctx.ip += 2;"); + + match right.type_hint { + TypeHint::Int => todo!(), + TypeHint::Bool => todo!(), + TypeHint::Float => todo!(), + TypeHint::Void => todo!(), + TypeHint::None => todo!(), + } + } + // TODO: Need to handle the actual op code as well // READLOCAL0, LOADINT2, LTE, IF Double(ADD | MUL | SUB | DIV, 2) => { @@ -661,9 +717,9 @@ impl StackToSSAConverter { // Emit the assert for bounds checking purposes if max_local_offset_read > 0 { - function.line(format!( - "assert!(ctx.sp + {max_local_offset_read} < ctx.thread.stack.len());" - )); + // function.line(format!( + // "assert!(ctx.sp + {max_local_offset_read} < ctx.thread.stack.len());" + // )); } if max_ip_read > 0 { @@ -735,24 +791,48 @@ impl<'a> std::fmt::Display for Call<'a> { // READCAPTURED, TAILCALL +// TODO: + +// Code Gen the match statement on the instruction that we will use to do a sliding window opt +// pub fn identify_pattern(instructions: &mut [Instruction], pattern: &[(OpCode, usize)]) { +// todo!() +// } + impl Pattern { pub fn from_opcodes(op_codes: &[(OpCode, usize)]) -> Vec { + let mut buffer: Vec = Vec::new(); + + Self::from_opcodes_with_buffer(op_codes, &mut buffer); + + buffer + } + + pub fn from_opcodes_with_buffer(op_codes: &[(OpCode, usize)], patterns: &mut Vec) { use OpCode::*; - let mut patterns: Vec = Vec::new(); + patterns.clear(); + let iter = op_codes.iter(); for op in iter { match op { ( LOADINT0 | LOADINT1 | LOADINT2 | READLOCAL0 | READLOCAL1 | READLOCAL2 - | READLOCAL3 | MOVEREADLOCAL0 | MOVEREADLOCAL1 | MOVEREADLOCAL2 + | READLOCAL3 | MOVEREADLOCAL0 | MOVEREADLOCAL1 | MOVEREADLOCAL2 | PUSHCONST | MOVEREADLOCAL3 | IF | PUSH | READCAPTURED | TAILCALL, _, ) => patterns.push(Pattern::Single(op.0)), - (READLOCAL | MOVEREADLOCAL, n) => patterns.push(Pattern::Double(op.0, *n)), + (READLOCAL | MOVEREADLOCAL | ADDIMMEDIATE, n) => { + patterns.push(Pattern::Double(op.0, *n)) + } (ADD | SUB | MUL | DIV | EQUAL | LTE, 2) => patterns.push(Pattern::Double(op.0, 2)), (BEGINSCOPE, n) => patterns.push(Pattern::Double(op.0, *n)), + // TODO: Need to introduce a hint to say that these are builtins - these _must_ be builtins + // or else this hint will fail! If it isn't a primitive function, we're violating the conditions + // for these op codes, since our basic block will switch. + // + // Even better - this can be speculative! We attempt to call a builtin, but if its not, + // we just fall through to the normal calling behavior! (CALLGLOBAL, n) => { // let arity = iter.next().unwrap(); patterns.push(Pattern::Double(CALLGLOBAL, *n)) @@ -762,8 +842,6 @@ impl Pattern { } } } - - patterns } } @@ -795,74 +873,128 @@ impl IteratorExtensions for T where T: Iterator {} // map: std::collections::HashMap, for<'r> fn (&'r mut VmCore<'_>, usize) -> Result<()>> // } -pub fn generate_opcode_map(patterns: Vec>) -> String { +pub fn generate_opcode_map() -> String { + let patterns = opcode::PATTERNS; + let mut global_scope = Scope::new(); - let mut generate = codegen::Function::new("generate_dynamic_op_codes"); - generate.ret(codegen::Type::new("SuperInstructionMap")); - generate.vis("pub(crate)"); + // let mut generate = codegen::Function::new("generate_dynamic_op_codes"); + // generate.ret(codegen::Type::new("SuperInstructionMap")); + // generate.vis("pub(crate)"); - generate.line("use OpCode::*;"); - generate.line("use steel_gen::Pattern::*;"); + // generate.line("use OpCode::*;"); + // generate.line("use steel_gen::Pattern::*;"); - generate.line("let mut map = SuperInstructionMap::new();"); + // generate.line("let mut map = SuperInstructionMap::new();"); let mut converter = StackToSSAConverter::new(); + let mut pattern_exists_function = codegen::Function::new("pattern_exists"); + pattern_exists_function.ret(codegen::Type::new("bool")); + pattern_exists_function.vis("pub(crate)"); + + pattern_exists_function.arg("pattern", codegen::Type::new("&[steel_gen::Pattern]")); + + pattern_exists_function.line("use OpCode::*;"); + pattern_exists_function.line("use steel_gen::Pattern::*;"); + + pattern_exists_function.line("match pattern {"); + + let mut vm_match_loop_function = codegen::Function::new("vm_match_dynamic_super_instruction"); + + vm_match_loop_function.vis("pub(crate)"); + + vm_match_loop_function.arg("ctx", codegen::Type::new("&mut VmCore<'_>")); + vm_match_loop_function.ret(codegen::Type::new("Result<()>")); + vm_match_loop_function.arg("instr", codegen::Type::new("DenseInstruction")); + + vm_match_loop_function.line("match instr {"); + for pattern in patterns { + let original_pattern = pattern; let pattern = Pattern::from_opcodes(&pattern); + + if pattern.is_empty() { + dbg!("Pattern produced empty result: {:?}", original_pattern); + continue; + } + let generated_name = pattern .iter() .map(|x| format!("{x}").to_lowercase()) .join("_"); let generated_function = converter.process_sequence(&pattern); - let mut scope = Scope::new(); + // let mut scope = Scope::new(); - scope.push_fn(generated_function); + global_scope.push_fn(generated_function); - generate.line(scope.to_string()); - generate.line(format!("map.insert(vec!{pattern:?}, {generated_name});")); + // generate.line(scope.to_string()); + // generate.line(format!("map.insert(vec!{pattern:?}, {generated_name});")); converter.reset(); - // let block = Block::new(before) + pattern_exists_function.line(format!("&{pattern:?} => true,")); + + if let Some(op_code) = opcode::sequence_to_opcode(original_pattern) { + dbg!(&original_pattern); - // generate.push_block(block) + vm_match_loop_function.line(format!( + "DenseInstruction {{ op_code: OpCode::{:?}, payload_size, .. }} => dynamic::{}(ctx, payload_size as usize),", + op_code, generated_name + )); + }; } + pattern_exists_function.line("_ => false,"); + pattern_exists_function.line("}"); + + vm_match_loop_function.line("_ => {"); + vm_match_loop_function + .line("crate::core::instructions::pretty_print_dense_instructions(&ctx.instructions);"); + vm_match_loop_function + .line(r#"panic!("Unhandled opcode: {:?} @ {}", ctx.instructions[ctx.ip], ctx.ip);"#); + + vm_match_loop_function.line("}"); + vm_match_loop_function.line("}"); + + global_scope.push_fn(pattern_exists_function); + global_scope.push_fn(vm_match_loop_function); + // Return the map now - generate.line("map"); + // generate.line("map"); // This gives me the interface to the super instruction stuff let top_level_definition = r#" - pub(crate) struct SuperInstructionMap { - map: std::collections::HashMap, for<'r> fn (&'r mut VmCore<'_>, usize) -> Result<()>> - } - - impl SuperInstructionMap { - pub(crate) fn new() -> Self { - Self { map: std::collections::HashMap::new() } - } +pub(crate) struct SuperInstructionMap { + map: std::collections::HashMap, for<'r> fn (&'r mut VmCore<'_>, usize) -> Result<()>> +} - pub(crate) fn insert(&mut self, pattern: Vec, func: for<'r> fn (&'r mut VmCore<'_>, usize) -> Result<()>) { - self.map.insert(pattern, func); - } +impl SuperInstructionMap { + pub(crate) fn new() -> Self { + Self { map: std::collections::HashMap::new() } + } - pub(crate) fn get(&self, op_codes: &[(OpCode, usize)]) -> Option fn (&'r mut VmCore<'_>, usize) -> Result<()>> { - let pattern = steel_gen::Pattern::from_opcodes(&op_codes); - self.map.get(&pattern).copied() - } + pub(crate) fn insert(&mut self, pattern: Vec, func: for<'r> fn (&'r mut VmCore<'_>, usize) -> Result<()>) { + self.map.insert(pattern, func); } - - lazy_static! { - pub(crate) static ref DYNAMIC_SUPER_PATTERNS: SuperInstructionMap = generate_dynamic_op_codes(); + + pub(crate) fn get(&self, op_codes: &[(OpCode, usize)]) -> Option fn (&'r mut VmCore<'_>, usize) -> Result<()>> { + let pattern = steel_gen::Pattern::from_opcodes(&op_codes); + self.map.get(&pattern).copied() } +} + +pub(crate) static DYNAMIC_SUPER_PATTERNS: once_cell::sync::Lazy = once_cell::sync::Lazy::new(|| generate_dynamic_op_codes()); + +pub(crate) fn generate_dynamic_op_codes() -> SuperInstructionMap { + SuperInstructionMap::new() +} "#; - global_scope.push_fn(generate); + // global_scope.push_fn(generate); format!("{}\n{}", top_level_definition, global_scope.to_string()) } @@ -918,12 +1050,12 @@ fn test_generation() { use OpCode::*; // TODO: Come up with better way for this to make it in - let patterns: Vec> = vec![vec![ - (MOVEREADLOCAL0, 0), - (LOADINT2, 225), - (SUB, 2), - (CALLGLOBAL, 1), - ]]; - - println!("{}", generate_opcode_map(patterns)); + // let patterns: &'static [&'static [(OpCode, usize)]] = &[&[ + // (MOVEREADLOCAL0, 0), + // (LOADINT2, 225), + // (SUB, 2), + // (CALLGLOBAL, 1), + // ]]; + + println!("{}", generate_opcode_map()); } diff --git a/crates/steel-gen/src/opcode.rs b/crates/steel-gen/src/opcode.rs index 4074d083c..d4cabc8b4 100644 --- a/crates/steel-gen/src/opcode.rs +++ b/crates/steel-gen/src/opcode.rs @@ -1,77 +1,194 @@ use serde::{Deserialize, Serialize}; -#[repr(u8)] -#[derive(Copy, Clone, Debug, Hash, PartialEq, Serialize, Deserialize, Eq, PartialOrd, Ord)] -pub enum OpCode { - VOID = 0, - PUSH = 1, - IF = 2, - JMP = 3, - FUNC = 4, - SCLOSURE = 5, - ECLOSURE = 6, - BIND, - SDEF, - EDEF, - POPPURE, - POPN, - PASS, - PUSHCONST, - NDEFS, - PANIC, - TAILCALL, - SET, - READLOCAL, - READLOCAL0, - READLOCAL1, - READLOCAL2, - READLOCAL3, - SETLOCAL, - COPYCAPTURESTACK, - COPYCAPTURECLOSURE, - COPYHEAPCAPTURECLOSURE, - FIRSTCOPYHEAPCAPTURECLOSURE, - TCOJMP, - CALLGLOBAL, - CALLGLOBALTAIL, - LOADINT0, // Load const 0 - LOADINT1, - LOADINT2, - CGLOCALCONST, - MOVEREADLOCAL, - MOVEREADLOCAL0, - MOVEREADLOCAL1, - MOVEREADLOCAL2, - MOVEREADLOCAL3, - READCAPTURED, - BEGINSCOPE, - LETENDSCOPE, - PUREFUNC, - ADD, - SUB, - MUL, - DIV, - EQUAL, - LTE, - NEWSCLOSURE, - ADDREGISTER, - SUBREGISTER, - LTEREGISTER, - SUBREGISTER1, - ALLOC, - READALLOC, - SETALLOC, - DynSuperInstruction, - Arity, - LetVar, - ADDIMMEDIATE, - SUBIMMEDIATE, - LTEIMMEDIATE, - BINOPADD, - LTEIMMEDIATEIF, +macro_rules! declare_opcodes { + + ( { $($variant:tt);* } { $( [ $super:tt => $(($k:path, $v:expr),)* ] );* } ) => { + #[repr(u8)] + #[derive(Copy, Clone, Debug, Hash, PartialEq, Serialize, Deserialize, Eq, PartialOrd, Ord)] + pub enum OpCode { + $($variant),* + + , + + $($super),* + } + + // $( const $super: &'static [(TestOpCode, usize)] = &[ $($v),* ]; )* + + pub const fn op_code_to_super_instruction_pattern(op_code: OpCode) -> Option<&'static [(OpCode, usize)]> { + match op_code { + $(OpCode::$super => Some( &[ $(($k, $v)),* ]) ),* , + _ => None + } + } + + pub const fn sequence_to_opcode(pattern: &[(OpCode, usize)]) -> Option { + match pattern { + $(&[ $(($k, _)),* ] => Some(OpCode::$super) ),* , + _ => None + } + } + + pub static PATTERNS: &'static [&'static [(OpCode, usize)]] = &[ + $( &[ $(($k, $v)),* ] ),* , + ]; + } + +} + +declare_opcodes! { + { + VOID; + PUSH; + IF; + JMP; + FUNC; + SCLOSURE; + ECLOSURE; + BIND; + SDEF; + EDEF; + POPPURE; + POPN; + POPSINGLE; + PASS; + PUSHCONST; + NDEFS; + PANIC; + TAILCALL; + SET; + READLOCAL; + READLOCAL0; + READLOCAL1; + READLOCAL2; + READLOCAL3; + SETLOCAL; + COPYCAPTURESTACK; + COPYCAPTURECLOSURE; + COPYHEAPCAPTURECLOSURE; + FIRSTCOPYHEAPCAPTURECLOSURE; + TCOJMP; + CALLGLOBAL; + CALLGLOBALTAIL; + LOADINT0; // Load const 0 + LOADINT1; + LOADINT2; + CGLOCALCONST; + MOVEREADLOCAL; + MOVEREADLOCAL0; + MOVEREADLOCAL1; + MOVEREADLOCAL2; + MOVEREADLOCAL3; + READCAPTURED; + BEGINSCOPE; + LETENDSCOPE; + PUREFUNC; + ADD; + SUB; + MUL; + DIV; + EQUAL; + LTE; + CONS; // Cons should be... probably specialized + LIST; + NEWSCLOSURE; + ADDREGISTER; + SUBREGISTER; + LTEREGISTER; + SUBREGISTER1; + ALLOC; + READALLOC; + SETALLOC; + DynSuperInstruction; + Arity; + LetVar; + ADDIMMEDIATE; + SUBIMMEDIATE; + LTEIMMEDIATE; + BINOPADD; + LTEIMMEDIATEIF + } + + // Super instructions + { + + + [ + CaseLambdaDispatch => + (OpCode::BEGINSCOPE, 0), + (OpCode::READLOCAL0, 0), + (OpCode::CALLGLOBAL, 1), + (OpCode::Arity, 92), + (OpCode::READLOCAL1, 1), + (OpCode::LOADINT0, 0), + (OpCode::CALLGLOBAL, 2), + (OpCode::Arity, 181), + (OpCode::IF, 22), + ]; + + [ + ReadLocal1PushConstEqualIf => (OpCode::READLOCAL1, 1), + (OpCode::PUSHCONST, 335), + (OpCode::EQUAL, 2), + (OpCode::PASS, 0), + (OpCode::IF, 8), + ] + + // 16 READLOCAL0 : 0 ##args + // 17 CALLGLOBAL : 1 length + // 18 Arity : 82 length + // 19 READLOCAL1 : 1 l + // 20 LOADINT0 : 274 0 + // 21 CALLGLOBAL : 2 = + // 22 Arity : 180 = + // 23 IF : 22 + + // [ + // CaseLambdaDispatch => (OpCode::READLOCAL0, 0), + // (OpCode::CALLGLOBAL, 1), + // (OpCode::Arity, 92), + // (OpCode::READLOCAL1, 1), + // (OpCode::LOADINT0, 0), + // (OpCode::CALLGLOBAL, 2), + // (OpCode::Arity, 181), + // (OpCode::IF, 22), + // ] + + // [ MOVERLLIS2CG => (OpCode::MOVEREADLOCAL, 0), (OpCode::LOADINT2, 225), (OpCode::SUB, 2), (OpCode::CALLGLOBAL, 1), ]; + + // [ MOVERLLIS2CGFOO => (OpCode::MOVEREADLOCAL, 1), (OpCode::LOADINT2, 225), (OpCode::SUB, 2), (OpCode::CALLGLOBAL, 1), ] + + + // (MOVEREADLOCAL0, 0), + // (LOADINT2, 225), + // (SUB, 2), + // (CALLGLOBAL, 1), + + } } +// // expansion +// enum EntryPoints { +// SomeLibCallback(u64), + +// A(), +// B(), +// } + impl OpCode { + /// Is this op code created as part of the aggregation of multiple op codes? + pub fn is_super_instruction(&self) -> bool { + // TODO: Check where super instructions start! + + return *self as u32 > Self::LTEIMMEDIATEIF as u32; + } + + /// Statically create the mapping we need for super instruction. Also, as part of the op code map generating, + /// the macro used for calling super instructions should also be generated. + pub fn super_instructions(&self) -> &'static [&'static [(OpCode, usize)]] { + todo!() + } + pub fn is_ephemeral_opcode(&self) -> bool { use OpCode::*; diff --git a/crates/steel-repl/src/repl.rs b/crates/steel-repl/src/repl.rs index bf0a1162e..047d09669 100644 --- a/crates/steel-repl/src/repl.rs +++ b/crates/steel-repl/src/repl.rs @@ -36,14 +36,19 @@ fn finish_load_or_interrupt(vm: &mut Engine, exprs: String, path: PathBuf) { let res = vm.compile_and_run_raw_program_with_path(exprs.as_str(), path); match res { - Ok(r) => r.iter().for_each(|x| match x { + Ok(r) => r.into_iter().for_each(|x| match x { SteelVal::Void => {} - _ => println!("{} {}", "=>".bright_blue().bold(), x), + SteelVal::StringV(s) => { + println!("{} {:?}", "=>".bright_blue().bold(), s); + } + _ => { + print!("{} ", "=>".bright_blue().bold()); + vm.call_function_by_name_with_args("displayln", vec![x]) + .unwrap(); + } }), Err(e) => { vm.raise_error(e); - // e.emit_result(file_name.as_str(), exprs.as_str()); - // eprintln!("{}", e.to_string().bright_red()); } } } @@ -54,9 +59,16 @@ fn finish_or_interrupt(vm: &mut Engine, line: String, print_time: bool) { let res = vm.compile_and_run_raw_program(&line); match res { - Ok(r) => r.iter().for_each(|x| match x { + Ok(r) => r.into_iter().for_each(|x| match x { SteelVal::Void => {} - _ => println!("{} {}", "=>".bright_blue().bold(), x), + SteelVal::StringV(s) => { + println!("{} {:?}", "=>".bright_blue().bold(), s); + } + _ => { + print!("{} ", "=>".bright_blue().bold()); + vm.call_function_by_name_with_args("displayln", vec![x]) + .unwrap(); + } }), Err(e) => { vm.raise_error(e); diff --git a/crates/steel-sys-info/sys-info.scm b/crates/steel-sys-info/sys-info.scm index b78f1fba0..6a87c6bfe 100644 --- a/crates/steel-sys-info/sys-info.scm +++ b/crates/steel-sys-info/sys-info.scm @@ -1,4 +1,12 @@ -(require-builtin steel/sys-info) +(#%require-dylib "libsteel_sys_info" + (only-in mem-info + MemoryInfo-total + MemoryInfo-avail + MemoryInfo-free + MemoryInfo-buffers + MemoryInfo-cached + MemoryInfo-swap-total + MemoryInfo-swap-free)) (define (current-memory-usage #:memory-info (memory-info (mem-info))) (- (MemoryInfo-total memory-info) (MemoryInfo-free memory-info) (MemoryInfo-cached memory-info))) diff --git a/src/lib.rs b/src/lib.rs index 6ad34f6df..da90543ea 100644 --- a/src/lib.rs +++ b/src/lib.rs @@ -48,6 +48,11 @@ enum EmitAction { pub fn run(clap_args: Args) -> Result<(), Box> { let mut vm = Engine::new(); + // let mut vm = Engine::top_level_load_from_bootstrap(include_bytes!(concat!( + // env!("OUT_DIR"), + // "/bootstrap.bin" + // ))); + vm.register_value("std::env::args", steel::SteelVal::ListV(vec![].into())); match clap_args { @@ -165,11 +170,7 @@ pub fn run(clap_args: Args) -> Result<(), Box> { }), .. } => { - let core_libraries = &[ - steel::stdlib::PRELUDE, - steel::stdlib::DISPLAY, - steel::stdlib::CONTRACTS, - ]; + let core_libraries = &[steel::stdlib::PRELUDE, steel::stdlib::DISPLAY]; for core in core_libraries { let res = vm.compile_and_run_raw_program(core); @@ -235,3 +236,14 @@ fn r5rs_test_suite() { run(args).unwrap() } + +#[test] +fn r7rs_test_suite() { + let args = Args { + action: None, + default_file: Some(PathBuf::from("cogs/r7rs.scm")), + arguments: vec![], + }; + + run(args).unwrap() +} diff --git a/src/main.rs b/src/main.rs index 2616c127d..4e0c7acdc 100644 --- a/src/main.rs +++ b/src/main.rs @@ -4,14 +4,22 @@ use clap::Parser; use steel_interpreter::Args; fn main() -> Result<(), Box> { - // env_logger::init(); + env_logger::init(); // let mut builder = env_logger::Builder::new(); - // let log_targets = ["steel::steel_vm::const_evaluation"]; + // let log_targets = [ + // "requires", + // "modules", + // "gc", + // "kernel", + // "super-instructions", + // "lambda-lifting", + // "dylibs", + // ]; // for target in log_targets { - // builder.filter(Some(target), log::LevelFilter::Trace); + // builder.filter(Some(target), log::LevelFilter::Trace); // } // builder.init();