From 8bf3bfba586beefe7b6cea9f059e54b7052e87ad Mon Sep 17 00:00:00 2001 From: Matthew Paras <34500476+mattwparas@users.noreply.github.com> Date: Mon, 13 Nov 2023 22:15:21 -0800 Subject: [PATCH] Fix panics in parser (#96) * There were some issues with the parser - this should fix those obvious panics * Tests against some of the r7rs benchmarks * Adds some more built ins, fixes some issues with the garbage collector * Remove the dependency on the `colored` crate - that is now a steel library * Mutable local variables are now expanded to calls to `box`, `unbox`, and `set-box!` --- Cargo.lock | 7 +- Cargo.toml | 2 +- cogs/colors/cog.scm | 5 + cogs/colors/colors.scm | 49 + cogs/installer/package.scm | 2 +- cogs/logging/log.scm | 48 +- cogs/srfi/cog.scm | 5 + cogs/srfi/srfi-28/format.scm | 56 + cogs/tests/unit-test.scm | 16 +- cogs/threads/test-threads.scm | 2 +- cogs/threads/threads.scm | 16 +- crates/steel-core/Cargo.toml | 10 +- crates/steel-core/src/compiler/compiler.rs | 144 +-- crates/steel-core/src/compiler/modules.rs | 78 +- .../src/compiler/passes/analysis.rs | 129 ++ crates/steel-core/src/parser/parser.rs | 59 +- crates/steel-core/src/primitives.rs | 2 - crates/steel-core/src/primitives/colors.rs | 90 -- crates/steel-core/src/primitives/nums.rs | 19 +- crates/steel-core/src/primitives/ports.rs | 83 +- crates/steel-core/src/primitives/strings.rs | 8 +- crates/steel-core/src/primitives/time.rs | 50 +- crates/steel-core/src/primitives/vectors.rs | 29 +- crates/steel-core/src/rvals.rs | 31 +- crates/steel-core/src/rvals/cycles.rs | 306 ++++- crates/steel-core/src/scheme/kernel.scm | 2 +- .../steel-core/src/scheme/modules/mvector.scm | 18 +- .../src/scheme/modules/parameters.scm | 141 +- .../steel-core/src/scheme/modules/reader.scm | 40 + .../steel-core/src/scheme/modules/result.scm | 7 +- crates/steel-core/src/scheme/print.scm | 43 +- crates/steel-core/src/scheme/stdlib.scm | 17 +- crates/steel-core/src/stdlib.rs | 4 - crates/steel-core/src/steel_vm/engine.rs | 22 +- crates/steel-core/src/steel_vm/primitives.rs | 114 +- crates/steel-core/src/steel_vm/register_fn.rs | 45 +- crates/steel-core/src/steel_vm/vm.rs | 63 +- crates/steel-core/src/tests/mod.rs | 1 + .../tests/success/letrec_simple_recursion.scm | 10 +- .../steel-core/src/tests/success/matcher.scm | 4 +- .../steel-core/src/tests/success/threads.scm | 11 +- crates/steel-core/src/values/closed.rs | 203 ++- crates/steel-core/src/values/port.rs | 73 +- crates/steel-core/src/values/structs.rs | 8 +- crates/steel-derive/src/lib.rs | 32 +- crates/steel-parser/src/lexer.rs | 6 + crates/steel-parser/src/tokens.rs | 67 +- r7rs-benchmarks/ack.scm | 44 + r7rs-benchmarks/array1.scm | 64 + r7rs-benchmarks/common.scm | 86 ++ r7rs-benchmarks/equal.scm | 239 ++++ r7rs-benchmarks/inputs/equal.input | 7 + r7rs-benchmarks/scheme.scm | 1135 +++++++++++++++++ r7rs-benchmarks/simplex.scm | 262 ++++ r7rs-benchmarks/triangl.scm | 107 ++ src/lib.rs | 22 +- 56 files changed, 3504 insertions(+), 639 deletions(-) create mode 100644 cogs/colors/cog.scm create mode 100644 cogs/colors/colors.scm create mode 100644 cogs/srfi/cog.scm create mode 100644 cogs/srfi/srfi-28/format.scm delete mode 100644 crates/steel-core/src/primitives/colors.rs create mode 100644 crates/steel-core/src/scheme/modules/reader.scm create mode 100644 r7rs-benchmarks/ack.scm create mode 100644 r7rs-benchmarks/array1.scm create mode 100644 r7rs-benchmarks/common.scm create mode 100644 r7rs-benchmarks/equal.scm create mode 100644 r7rs-benchmarks/inputs/equal.input create mode 100644 r7rs-benchmarks/scheme.scm create mode 100644 r7rs-benchmarks/simplex.scm create mode 100644 r7rs-benchmarks/triangl.scm diff --git a/Cargo.lock b/Cargo.lock index e43cbd900..7ee6535a0 100644 --- a/Cargo.lock +++ b/Cargo.lock @@ -1470,9 +1470,9 @@ dependencies = [ [[package]] name = "im-lists" -version = "0.5.0" +version = "0.6.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "dbe1ea6399f751563e6f5d88bff90a5c7418f8e7abbdd34708412be793a73949" +checksum = "280cfba4e434565a1275d357b3561ca98265e3715de9406eabd6198f7137fd21" [[package]] name = "im-rc" @@ -3083,7 +3083,6 @@ dependencies = [ "bincode", "chrono", "codespan-reporting", - "colored", "cranelift", "cranelift-jit", "cranelift-module", @@ -3096,7 +3095,6 @@ dependencies = [ "im-rc", "lasso", "log", - "logos", "num", "once_cell", "pretty", @@ -3111,7 +3109,6 @@ dependencies = [ "serde_json", "slotmap", "smallvec", - "steel-core", "steel-derive", "steel-gen", "steel-parser", diff --git a/Cargo.toml b/Cargo.toml index b4d976edf..2e9af5b02 100644 --- a/Cargo.toml +++ b/Cargo.toml @@ -19,7 +19,7 @@ path = "src/main.rs" [workspace.dependencies] # This has to line up with the workspace version above -steel-core = { path = "./crates/steel-core", version = "0.5.0", features = ["web", "sqlite", "blocking_requests", "dylibs", "markdown", "colors"] } +steel-core = { path = "./crates/steel-core", version = "0.5.0", features = ["web", "sqlite", "blocking_requests", "dylibs", "markdown"] } [dependencies] once_cell = "1.17.0" diff --git a/cogs/colors/cog.scm b/cogs/colors/cog.scm new file mode 100644 index 000000000..a4690e92f --- /dev/null +++ b/cogs/colors/cog.scm @@ -0,0 +1,5 @@ +(define package-name 'steel/colors) +(define version "0.1.0") + +;; Core library, requires no dependencies +(define dependencies '()) diff --git a/cogs/colors/colors.scm b/cogs/colors/colors.scm new file mode 100644 index 000000000..34ff79ba3 --- /dev/null +++ b/cogs/colors/colors.scm @@ -0,0 +1,49 @@ +(require "srfi/srfi-28/format.scm") + +(provide display-color + displayln-color) + +(define (terminal-command command) + (format "~a~a" #\u001B command)) + +(define (terminal-reset) + (terminal-command "[0m")) + +(define (terminal-colors bg fg bold? underline?) + (terminal-command (format "[~a;~a~a~am" + (case bg + [(black) "40"] + [(red) "41"] + [(green) "42"] + [(yellow) "43"] + [(blue) "44"] + [(magenta) "45"] + [(cyan) "46"] + [(white) "47"] + [(default) "49"]) + (case fg + [(black) "30"] + [(red) "31"] + [(green) "32"] + [(yellow) "33"] + [(blue) "34"] + [(magenta) "35"] + [(cyan) "36"] + [(white) "37"] + [(default) "39"]) + (if bold? ";1" "") + (if underline? ";4" "")))) + +(define (output-color output-method datum #:fg fg #:bg bg) + (terminal-colors bg fg #f #f) + (output-method datum) + (display (terminal-reset))) + +(define (display-color datum #:fg [fg 'default] #:bg [bg 'default]) + (output-color display datum #:fg fg #:bg bg)) + +(define (displayln-color datum #:fg [fg 'default] #:bg [bg 'default]) + (display (terminal-colors bg fg #f #f)) + (display datum) + (display (terminal-reset)) + (newline)) diff --git a/cogs/installer/package.scm b/cogs/installer/package.scm index 1a2fe967b..b57325e15 100644 --- a/cogs/installer/package.scm +++ b/cogs/installer/package.scm @@ -64,7 +64,7 @@ (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) + (display "✅ Installed package to: ") (displayln output-dir) (newline))) diff --git a/cogs/logging/log.scm b/cogs/logging/log.scm index 38c6f8749..666fb709e 100644 --- a/cogs/logging/log.scm +++ b/cogs/logging/log.scm @@ -1,59 +1,43 @@ (require-builtin steel/time) -(require-builtin steel/strings/colors as colors.) -(provide log! log/info! log/warn! log/debug! log/error!) +(provide log! + log/info! + log/warn! + log/debug! + log/error!) -(define *info* (colors.green "INFO")) -(define *warn* (colors.yellow "WARN")) -(define *debug* (colors.blue "DEBUG")) -(define *error* (colors.red "ERROR")) -(define *trace* (colors.purple "TRACE")) - -; (displayln "LOADING MODULE") - -; (define (log! level target arg-list) -; (apply displayln (append -; (list -; (local-time/now! "%Y-%m-%dT%H:%M:%S") -; " [" -; level -; " " -; target -; "] - ") -; arg-list))) +(define *info* "INFO") +(define *warn* "WARN") +(define *debug* "DEBUG") +(define *error* "ERROR") +(define *trace* "TRACE") ;;@doc ;; Log directly on the specified level the with arguments, as a list (define (log! level arg-list) - (apply displayln (append - (list - (local-time/now! "%Y-%m-%dT%H:%M:%S") - " [" - level - "] - ") - arg-list))) + (apply displayln (append (list (local-time/now! "%Y-%m-%dT%H:%M:%S") " [" level "] - ") arg-list))) ;;@doc ;; Log the arguments using the *info* target, i.e. log on INFO (define (log/info! . args) - (log! *info* args)) + (log! *info* args)) ;;@doc ;; Log the arguments using the *warn* target, i.e. log on WARN (define (log/warn! . args) - (log! *warn* args)) + (log! *warn* args)) ;;@doc ;; Log the arguments using the *debug* target, i.e. log on DEBUG (define (log/debug! . args) - (log! *debug* args)) + (log! *debug* args)) ;;@doc ;; Log the arguments using the *error* target, i.e. log on ERROR (define (log/error! . args) - (log! *error* args)) + (log! *error* args)) ;;@doc ;; Log the arguments using the *trace* target, i.e. log on TRACE (define (log/trace! . args) - (log! *trace* args)) \ No newline at end of file + (log! *trace* args)) diff --git a/cogs/srfi/cog.scm b/cogs/srfi/cog.scm new file mode 100644 index 000000000..88d3a4ce6 --- /dev/null +++ b/cogs/srfi/cog.scm @@ -0,0 +1,5 @@ +(define package-name 'srfi) +(define version "0.1.0") + +;; Core library, requires no dependencies +(define dependencies '()) diff --git a/cogs/srfi/srfi-28/format.scm b/cogs/srfi/srfi-28/format.scm new file mode 100644 index 000000000..00e8c2c8d --- /dev/null +++ b/cogs/srfi/srfi-28/format.scm @@ -0,0 +1,56 @@ +; Copyright (C) Scott G. Miller (2002). All Rights Reserved. +; +; Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files +; the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge +; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to +; do so, subject to the following conditions: +; +; The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +; +; Modified for use within Steel by Matthew Paras (2023). + +(provide format) + +(define format + (lambda (format-string . objects) + (let ([buffer (open-output-string)]) + (let loop ([format-list (string->list format-string)] [objects objects]) + (cond + [(null? format-list) (get-output-string buffer)] + [(char=? (car format-list) #\~) + (if (null? (cdr format-list)) + (error 'format "Incomplete escape sequence") + (case (cadr format-list) + [(#\a) + (if (null? objects) + (error 'format "No value for escape sequence") + (begin + (display (car objects) buffer) + (loop (cddr format-list) (cdr objects))))] + [(#\s) + (if (null? objects) + (error 'format "No value for escape sequence") + (begin + (write (car objects) buffer) + (loop (cddr format-list) (cdr objects))))] + [(#\%) + (newline buffer) + (loop (cddr format-list) objects)] + [(#\~) + (write-char #\~ buffer) + (loop (cddr format-list) objects)] + [else (error 'format "Unrecognized escape sequence")]))] + [else + (write-char (car format-list) buffer) + (loop (cdr format-list) objects)]))))) + +; (displayln (format "Hello, ~a" "World!")) +; ; => "Hello, World!" + +; (displayln (format "Error, list is too short: ~s~%" '(one "two" 3))) +; ; => "Error, list is too short: (one \"two\" 3))" diff --git a/cogs/tests/unit-test.scm b/cogs/tests/unit-test.scm index ad7b8157b..99258e121 100644 --- a/cogs/tests/unit-test.scm +++ b/cogs/tests/unit-test.scm @@ -1,3 +1,5 @@ +(require "steel/colors/colors.scm") + (provide test (for-syntax check-equal?) (for-syntax check-err?) @@ -25,14 +27,16 @@ (set! *FAILED-TO-COMPILE* (+ *FAILED-TO-COMPILE* 1))) (define (print-success name) - (simple-display "test > " name " ... ") - (display-color "Ok" 'green) - (newline)) + (display "test > ") + (display name) + (display " ... ") + (displayln-color "Ok" #:fg 'green)) (define (print-failure name) - (simple-display "test > " name " ... ") - (display-color "FAILED" 'red) - (newline)) + (display "test > ") + (display name) + (display " ... ") + (displayln-color "FAILED" #:fg 'red)) (define-syntax check-equal? (syntax-rules () diff --git a/cogs/threads/test-threads.scm b/cogs/threads/test-threads.scm index f54da2025..71923989d 100644 --- a/cogs/threads/test-threads.scm +++ b/cogs/threads/test-threads.scm @@ -14,7 +14,7 @@ (let ([tasks (map (lambda (_) (spawn-thread! (lambda () (time/sleep-ms 2000) - (displayln (thread::current/id))))) + (stdout-simple-displayln (thread::current/id))))) (range 0 10))]) (map (lambda (x) (unwrap-ok (thread-join! x))) tasks))) diff --git a/cogs/threads/threads.scm b/cogs/threads/threads.scm index 504afda88..9b44443b7 100644 --- a/cogs/threads/threads.scm +++ b/cogs/threads/threads.scm @@ -34,14 +34,14 @@ (define sender (list-ref channels 0)) (define receiver (list-ref channels 1)) - (CancellableThreadHandle - sender - (spawn-thread! (lambda () - (while (not (~> (channel->try-recv receiver) (unwrap-ok))) - (begin - (func) - (time/sleep-ms delay-ms))) - (displayln "Shutting down thread: " (thread::current/id)))))) + (CancellableThreadHandle sender + (spawn-thread! (lambda () + (while (not (~> (channel->try-recv receiver) (unwrap-ok))) + (begin + (func) + (time/sleep-ms delay-ms))) + (stdout-simple-displayln "Shutting down thread: " + (thread::current/id)))))) ; (let ([tasks (map (lambda (_) ; (spawn-thread! (lambda () diff --git a/crates/steel-core/Cargo.toml b/crates/steel-core/Cargo.toml index cbadec0ff..c39f15156 100644 --- a/crates/steel-core/Cargo.toml +++ b/crates/steel-core/Cargo.toml @@ -16,7 +16,7 @@ name = "steel" [dependencies] im-rc = "15.1.0" codespan-reporting = "0.11.1" -logos = "0.12.1" +# logos = "0.12.1" log = "0.4.17" futures-util = "0.3.28" @@ -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.5.0" +im-lists = "0.6.0" quickscope = "0.2.0" lasso = { version = "0.6.0", features = ["multi-threaded", "serialize"] } once_cell = "1.17.0" @@ -49,8 +49,6 @@ radix_fmt = "1.0.0" # For structs smallvec = { version = "1.10.0", optional = true } -colored = { version = "2.0.0", optional = true } - # Pretty printing documentation termimad = { version = "0.21.0", optional = true } @@ -73,7 +71,6 @@ ureq = { version = "2.6.2", features = ["json"], optional = true } [dev-dependencies] proptest = "1.1.0" criterion = "0.5.1" -steel-core = { path = ".", features = ["modules"] } env_logger = "0.10.0" [build-dependencies] @@ -81,7 +78,6 @@ steel-gen = { path = "../steel-gen", version = "0.2.0" } [features] default = ["modules"] -colors = ["dep:colored"] modules = [] jit = ["dep:cranelift", "dep:cranelift-module", "dep:cranelift-jit"] dynamic = [] @@ -100,5 +96,3 @@ without-drop-protection = [] 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/src/compiler/compiler.rs b/crates/steel-core/src/compiler/compiler.rs index 62928b758..dd49ecaec 100644 --- a/crates/steel-core/src/compiler/compiler.rs +++ b/crates/steel-core/src/compiler/compiler.rs @@ -271,7 +271,6 @@ pub struct SerializableCompiler { pub(crate) macro_env: HashMap, pub(crate) opt_level: OptLevel, pub(crate) module_manager: ModuleManager, - // pub(crate) mangled_identifiers: } impl SerializableCompiler { @@ -444,84 +443,7 @@ impl Compiler { let parsed = parsed?; - let mut expanded_statements = - self.expand_expressions(parsed, path, sources, builtin_modules.clone())?; - - if log_enabled!(log::Level::Debug) { - debug!( - "Generating instructions for the expression: {:?}", - expanded_statements - .iter() - .map(|x| x.to_string()) - .collect::>() - ); - } - - expanded_statements = expanded_statements - .into_iter() - .map(|x| expand_kernel(x, self.kernel.as_mut(), builtin_modules.clone())) - .collect::>>()?; - - let mut expanded_statements = - self.apply_const_evaluation(constants.clone(), expanded_statements, false)?; - - RenameShadowedVariables::rename_shadowed_vars(&mut expanded_statements); - - let mut analysis = Analysis::from_exprs(&expanded_statements); - analysis.populate_captures(&expanded_statements); - - let mut semantic = SemanticAnalysis::from_analysis(&mut expanded_statements, analysis); - - // let mut table = HashSet::new(); - - // This is definitely broken still - semantic - .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); - - let mut analysis = Analysis::from_exprs(&expanded_statements); - analysis.populate_captures(&expanded_statements); - - let mut semantic = SemanticAnalysis::from_analysis(&mut expanded_statements, analysis); - semantic.refresh_variables(); - - semantic.flatten_anonymous_functions(); - - semantic.refresh_variables(); - - if log_enabled!(log::Level::Debug) { - debug!( - "Successfully expanded defines: {:?}", - expanded_statements - .iter() - .map(|x| x.to_string()) - .collect::>() - ); - } - - // TODO - make sure I want to keep this - let expanded_statements = - MultipleArityFunctions::expand_multiple_arity_functions(expanded_statements); - - let mut expanded_statements = - self.apply_const_evaluation(constants, expanded_statements, true)?; - - Ok(expanded_statements) + self.lower_expressions_impl(parsed, constants, builtin_modules, path, sources) } pub fn compile_module( @@ -601,19 +523,14 @@ impl Compiler { Ok(results) } - // TODO - // figure out how the symbols will work so that a raw program with symbols - // can be later pulled in and symbols can be interned correctly - fn compile_raw_program( + fn lower_expressions_impl( &mut self, exprs: Vec, constants: ImmutableHashMap, builtin_modules: ModuleContainer, path: Option, sources: &mut Sources, - ) -> Result { - log::debug!(target: "expansion-phase", "Expanding macros -> phase 0"); - + ) -> Result> { let mut expanded_statements = self.expand_expressions(exprs, path, sources, builtin_modules.clone())?; @@ -646,8 +563,6 @@ impl Compiler { let mut semantic = SemanticAnalysis::from_analysis(&mut expanded_statements, analysis); - // let mut table = HashSet::new(); - // This is definitely broken still semantic .elide_single_argument_lambda_applications() @@ -670,9 +585,6 @@ impl Compiler { 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); @@ -683,6 +595,12 @@ impl Compiler { semantic.refresh_variables(); + // Replace mutation with boxes + semantic.populate_captures(); + semantic.populate_captures(); + + semantic.replace_mutable_captured_variables_with_boxes(); + if log_enabled!(log::Level::Debug) { debug!( "Successfully expanded defines: {:?}", @@ -701,34 +619,24 @@ 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(); + self.apply_const_evaluation(constants, expanded_statements, true) + } - 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: + // TODO + // figure out how the symbols will work so that a raw program with symbols + // can be later pulled in and symbols can be interned correctly + fn compile_raw_program( + &mut self, + exprs: Vec, + constants: ImmutableHashMap, + builtin_modules: ModuleContainer, + path: Option, + sources: &mut Sources, + ) -> Result { + log::debug!(target: "expansion-phase", "Expanding macros -> phase 0"); + + let mut expanded_statements = + self.lower_expressions_impl(exprs, constants, builtin_modules, path, sources)?; log::debug!(target: "expansion-phase", "Generating instructions"); diff --git a/crates/steel-core/src/compiler/modules.rs b/crates/steel-core/src/compiler/modules.rs index 7805813fb..c70c80379 100644 --- a/crates/steel-core/src/compiler/modules.rs +++ b/crates/steel-core/src/compiler/modules.rs @@ -44,38 +44,54 @@ use super::{ program::{CONTRACT_OUT, FOR_SYNTAX, ONLY_IN, PREFIX_IN, REQUIRE_IDENT_SPEC}, }; -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"; +macro_rules! declare_builtins { + ( $( $name:expr => $path:expr ), *) => { + static BUILT_INS: &[(&str, &str)] = &[ + $( ($name, include_str!($path)), )* + ]; + }; +} -static MUTABLE_VECTORS: &str = include_str!("../scheme/modules/mvector.scm"); -static MUTABLE_VECTORS_NAME: &str = "steel/mutable-vectors"; +pub(crate) const MANGLER_SEPARATOR: &str = "__%#__"; -static PRINTING: &str = include_str!("../scheme/print.scm"); -static PRINTING_NAME: &str = "#%private/steel/print"; +macro_rules! create_prelude { + ( + $( $module:literal, )* + $( for_syntax $module_for_syntax:literal ),* + ) => { -static DYNAMIC_WIND_NAME: &str = "#%private/steel/control"; -static DYNAMIC_WIND: &str = include_str!("../scheme/modules/parameters.scm"); + pub static PRELUDE_WITHOUT_BASE: &str = concat!( + $( "(require \"", $module, "\")\n", )* + $( "(require (for-syntax \"", $module_for_syntax, "\"))\n", )* + ); -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 static PRELUDE_STRING: &str = concat!( + "(require-builtin steel/base)\n", + $( "(require \"", $module, "\")\n", )* + $( "(require (for-syntax \"", $module_for_syntax, "\"))\n", )* + ); + } +} -pub(crate) const MANGLER_SEPARATOR: &str = "__%#__"; +declare_builtins!( + "steel/option" => "../scheme/modules/option.scm", + "steel/result" => "../scheme/modules/result.scm", + "steel/iterators" => "../scheme/modules/iterators.scm", + "steel/mutable-vectors" => "../scheme/modules/mvector.scm", + "#%private/steel/contract" => "../scheme/modules/contracts.scm", + "#%private/steel/print" => "../scheme/print.scm", + "#%private/steel/control" => "../scheme/modules/parameters.scm", + "#%private/steel/reader" => "../scheme/modules/reader.scm" +); + +create_prelude!( + "#%private/steel/control", + "#%private/steel/contract", + "#%private/steel/print", + "#%private/steel/reader", + for_syntax "#%private/steel/control", + for_syntax "#%private/steel/contract" +); /// Manages the modules /// keeps some visited state on the manager for traversal @@ -2052,11 +2068,3 @@ impl<'a> ModuleBuilder<'a> { Ok(self) } } - -// 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 4e8f4c148..9a05ebc11 100644 --- a/crates/steel-core/src/compiler/passes/analysis.rs +++ b/crates/steel-core/src/compiler/passes/analysis.rs @@ -2398,6 +2398,123 @@ impl<'a> VisitorMutRefUnit for ElideSingleArgumentLambdaApplications<'a> { } } +fn box_argument(ident: ExprKind) -> ExprKind { + ExprKind::List(List::new(vec![ExprKind::atom("#%box"), ident])) +} + +fn unbox_argument(ident: ExprKind) -> ExprKind { + ExprKind::List(List::new(vec![ExprKind::atom("#%unbox"), ident])) +} + +fn setbox_argument(ident: ExprKind, expr: ExprKind) -> ExprKind { + ExprKind::List(List::new(vec![ExprKind::atom("#%set-box!"), ident, expr])) +} + +struct ReplaceSetOperationsWithBoxes<'a> { + analysis: &'a Analysis, +} + +impl<'a> VisitorMutRefUnit for ReplaceSetOperationsWithBoxes<'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) => { + if let Some(analysis) = self.analysis.get(&a.syn) { + if analysis.kind == IdentifierStatus::HeapAllocated { + let mut dummy = ExprKind::List(List::new(Vec::new())); + std::mem::swap(&mut dummy, expr); + + *expr = unbox_argument(dummy); + } + } + } + ExprKind::List(l) => self.visit_list(l), + ExprKind::SyntaxRules(s) => self.visit_syntax_rules(s), + ExprKind::Set(s) => { + if let Some(analysis) = self.analysis.get(s.variable.atom_syntax_object().unwrap()) + { + if analysis.kind != IdentifierStatus::HeapAllocated { + self.visit(&mut s.expr); + + return; + } + } + + // Go ahead and drop down the expression + self.visit(&mut s.expr); + + let mut set_expr = ExprKind::List(List::new(Vec::new())); + std::mem::swap(&mut s.expr, &mut set_expr); + + let mut dummy_ident = ExprKind::List(List::new(Vec::new())); + std::mem::swap(&mut dummy_ident, &mut s.variable); + + let new_set_expr = setbox_argument(dummy_ident, set_expr); + + *expr = new_set_expr; + } + ExprKind::Require(r) => self.visit_require(r), + ExprKind::Let(l) => self.visit_let(l), + } + } + + fn visit_define(&mut self, define: &mut Define) { + self.visit(&mut define.body); + } + + fn visit_lambda_function(&mut self, lambda_function: &mut LambdaFunction) { + // Visit the body first, unwind the recursion on the way up + self.visit(&mut lambda_function.body); + + let function_info = self + .analysis + .function_info + .get(&lambda_function.syntax_object_id); + + if let Some(function_info) = function_info { + let mut mutable_variables = Vec::new(); + + // Which arguments do we need to wrap up + for var in &lambda_function.args { + if let Some(ident) = var.atom_identifier() { + if let Some(arg) = function_info.arguments().get(ident) { + if arg.captured && arg.mutated { + mutable_variables.push(var.clone()); + } + } + } else { + unreachable!() + } + } + + if !mutable_variables.is_empty() { + let mut body = ExprKind::List(List::new(Vec::new())); + + std::mem::swap(&mut lambda_function.body, &mut body); + + let wrapped_lambda = LambdaFunction::new( + mutable_variables.clone(), + body, + lambda_function.location.clone(), + ); + + // Box the values! + let mut mutable_variables: Vec<_> = + mutable_variables.into_iter().map(box_argument).collect(); + + mutable_variables.insert(0, ExprKind::LambdaFunction(Box::new(wrapped_lambda))); + lambda_function.body = ExprKind::List(List::new(mutable_variables)); + } + } + } +} + struct LiftLocallyDefinedFunctions<'a> { analysis: &'a Analysis, lifted_functions: Vec, @@ -2962,6 +3079,18 @@ impl<'a> SemanticAnalysis<'a> { } } + pub fn replace_mutable_captured_variables_with_boxes(&mut self) -> &mut Self { + let mut replacer = ReplaceSetOperationsWithBoxes { + analysis: &self.analysis, + }; + + for expr in self.exprs.iter_mut() { + replacer.visit(expr); + } + + self + } + /// Find all local pure functions, except those defined already at the top level and those defined with 'define', /// and replace them with a globally defined function. This means we're not going to be recreating /// the function _on every instance_ and instead can just grab them each time. diff --git a/crates/steel-core/src/parser/parser.rs b/crates/steel-core/src/parser/parser.rs index fb739519b..54000a29b 100644 --- a/crates/steel-core/src/parser/parser.rs +++ b/crates/steel-core/src/parser/parser.rs @@ -450,7 +450,7 @@ pub struct Parser<'a> { collecting_comments: bool, } -#[derive(Debug, Copy, Clone)] +#[derive(Debug, Copy, Clone, PartialEq)] enum ParsingContext { // Inside of a quote. Expressions should be parsed without being coerced into a typed variant of the AST Quote(usize), @@ -475,6 +475,10 @@ impl<'a> Parser<'a> { pub fn parse(expr: &str) -> Result> { Parser::new(expr, None).collect() } + + pub fn offset(&self) -> usize { + self.tokenizer.offset() + } } pub type Result = result::Result; @@ -668,7 +672,7 @@ impl<'a> Parser<'a> { TokenType::QuoteTick => { // quote_count += 1; // self.quote_stack.push(current_frame.len()); - self.shorthand_quote_stack.push(current_frame.len()); + self.shorthand_quote_stack.push(stack.len()); let last_context = self.quote_context; @@ -678,8 +682,7 @@ impl<'a> Parser<'a> { // println!("Entering context: Quote Tick in read from tokens"); - self.context - .push(ParsingContext::QuoteTick(current_frame.len())); + self.context.push(ParsingContext::QuoteTick(stack.len())); let quote_inner = self .next() @@ -706,6 +709,7 @@ impl<'a> Parser<'a> { let popped_value = self.context.pop(); if let Some(popped) = popped_value { + // dbg!(&popped); debug_assert!(matches!(popped, ParsingContext::QuoteTick(_))) } @@ -717,8 +721,7 @@ impl<'a> Parser<'a> { // This could underflow and panic - if its negative then we have a problem. Maybe just use an isize and let it underflow? self.decrement_quasiquote_context_if_not_in_quote_context(); - self.context - .push(ParsingContext::UnquoteTick(current_frame.len())); + self.context.push(ParsingContext::UnquoteTick(stack.len())); let quote_inner = self .next() @@ -749,7 +752,7 @@ impl<'a> Parser<'a> { self.increment_quasiquote_context_if_not_in_quote_context(); self.context - .push(ParsingContext::QuasiquoteTick(current_frame.len())); + .push(ParsingContext::QuasiquoteTick(stack.len())); let quote_inner = self .next() @@ -779,7 +782,7 @@ impl<'a> Parser<'a> { self.decrement_quasiquote_context_if_not_in_quote_context(); self.context - .push(ParsingContext::UnquoteSplicingTick(current_frame.len())); + .push(ParsingContext::UnquoteSplicingTick(stack.len())); let quote_inner = self .next() @@ -839,6 +842,7 @@ impl<'a> Parser<'a> { // let last_quote_index = *last_quote_index; if stack.len() <= last_quote_index { + // println!("{} - {}", stack.len(), last_quote_index); self.context.pop(); // println!("Exiting Context: {:?}", self.context.pop()); } @@ -952,6 +956,7 @@ impl<'a> Parser<'a> { // ); if stack.len() <= last_quote_index { + // println!("{} - {}", stack.len(), last_quote_index); // println!("Exiting Context: {:?}", self.context.pop()); self.context.pop(); } @@ -976,11 +981,26 @@ impl<'a> Parser<'a> { // println!("Else case: {:?}", current_frame); // println!("Context: {:?}", self.context); + // dbg!(&self.quote_stack); + // dbg!(&self.context); + // dbg!(&self.shorthand_quote_stack); match self.context.last() { Some(ParsingContext::QuoteTick(_)) | Some(ParsingContext::QuasiquoteTick(_)) => { + // | Some(ParsingContext::Quote(d)) && d > 0 => { return Ok(ExprKind::List(List::new(current_frame))); } + Some(ParsingContext::Quote(x)) if *x > 0 => { + self.context.pop(); + + return Ok(ExprKind::List(List::new(current_frame))); + } + Some(ParsingContext::Quote(0)) => { + self.context.pop(); + + return ExprKind::try_from(current_frame) + .map_err(|x| x.set_source(self.source_name.clone())); + } _ => { // dbg!(self.quasiquote_depth); // println!("=> {}", List::new(current_frame.clone())); @@ -1017,12 +1037,20 @@ impl<'a> Parser<'a> { self.quote_stack.push(stack.len()); } + // dbg!(&self.context); + // Mark what context we're inside with the context stack: // This only works when its the first argument - check the function call in open paren? if current_frame.is_empty() { match &token.ty { TokenType::Quote => { - self.context.push(ParsingContext::Quote(stack.len())) + if self.context == &[ParsingContext::QuoteTick(0)] { + self.context.push(ParsingContext::Quote(1)) + } else { + self.context.push(ParsingContext::Quote(stack.len())) + } + + // self.context.push(ParsingContext::Quote(stack.len())) } TokenType::Identifier(ident) if *ident == *UNQUOTE => { self.context.push(ParsingContext::Unquote(stack.len())); @@ -1135,6 +1163,7 @@ impl<'a> Parser<'a> { let popped_value = self.context.pop(); if let Some(popped) = popped_value { + // dbg!(&popped); debug_assert!(matches!(popped, ParsingContext::QuoteTick(_))) } @@ -1143,8 +1172,14 @@ impl<'a> Parser<'a> { // println!("Exiting context: {:?}", self.context.pop()); // println!("Result: {:?}", value); + // println!("{}", List::new(value.clone().unwrap())); + return Some(match value { - Ok(v) => ExprKind::try_from(v), + Ok(v) => { + // Ok(ExprKind::List(List::new(v))) + + ExprKind::try_from(v) + } Err(e) => Err(e), }); } @@ -1580,12 +1615,12 @@ mod parser_tests { #[test] fn parse_unicode() { assert_parse("#\\¡", &[character('¡')]); - assert_parse("#\\\\u{b}", &[character('\u{b}')]); + assert_parse("#\\u{b}", &[character('\u{b}')]); } #[test] fn parse_more_unicode() { - assert_parse("#\\\\u{a0}", &[character('\u{a0}')]); + assert_parse("#\\u{a0}", &[character('\u{a0}')]); } #[test] diff --git a/crates/steel-core/src/primitives.rs b/crates/steel-core/src/primitives.rs index 8104c7341..8197954d8 100644 --- a/crates/steel-core/src/primitives.rs +++ b/crates/steel-core/src/primitives.rs @@ -27,8 +27,6 @@ pub mod sqlite; #[cfg(feature = "blocking_requests")] pub mod blocking_requests; -pub mod colors; - pub use lists::UnRecoverableResult; use crate::values::closed::HeapRef; diff --git a/crates/steel-core/src/primitives/colors.rs b/crates/steel-core/src/primitives/colors.rs deleted file mode 100644 index 9daaeae71..000000000 --- a/crates/steel-core/src/primitives/colors.rs +++ /dev/null @@ -1,90 +0,0 @@ -use crate::steel_vm::builtin::BuiltInModule; -use crate::steel_vm::register_fn::RegisterFn; - -#[cfg(feature = "colors")] -use colored::{ColoredString, Colorize}; - -#[cfg(feature = "colors")] -impl crate::rvals::Custom for ColoredString { - fn fmt(&self) -> Option> { - Some(Ok(format!("{}", self))) - } -} - -macro_rules! wrap_coloring { - ($($name:ident),* $(,)?) => { - - - $ ( - #[cfg(feature = "colors")] - fn $name(string: String) -> ColoredString { - string.$name() - } - ) * - - - - $ ( - #[cfg(not(feature = "colors"))] - fn $name(string: String) -> String { - string - } - ) * - - pub fn string_coloring_module() -> BuiltInModule { - let mut module = BuiltInModule::new("steel/strings/colors".to_string()); - - $ ( - module.register_fn(stringify!($name), $name); - ) * - - module - - } - }; -} - -wrap_coloring! { - black, - red, - green, - yellow, - blue, - magenta, - purple, - cyan, - white, - bright_black, - bright_red, - bright_green, - bright_yellow, - bright_blue, - bright_white, - on_black, - on_red, - on_green, - on_yellow, - on_blue, - on_magenta, - on_purple, - on_cyan, - on_white, - on_bright_black, - on_bright_red, - on_bright_green, - on_bright_yellow, - on_bright_blue, - on_bright_magenta, - on_bright_purple, - on_bright_cyan, - on_bright_white, - normal, - bold, - dimmed, - italic, - underline, - blink, - reversed, - hidden, - strikethrough -} diff --git a/crates/steel-core/src/primitives/nums.rs b/crates/steel-core/src/primitives/nums.rs index 33cc29f85..d9a1e6ff2 100644 --- a/crates/steel-core/src/primitives/nums.rs +++ b/crates/steel-core/src/primitives/nums.rs @@ -77,11 +77,26 @@ pub fn divide_primitive(args: &[SteelVal]) -> Result { stop!(ArityMismatch => "/ requires at least one argument") } + if args.len() == 1 { + match &args[0] { + SteelVal::IntV(n) => return Ok(SteelVal::NumV((1 / n) as f64)), + SteelVal::NumV(n) => return Ok(SteelVal::NumV((1.0 / n) as f64)), + unexpected => { + stop!(TypeMismatch => "division expects a number, found: {:?}", unexpected) + } + } + } + + let mut no_floats = true; + let floats: Result> = args .iter() .map(|x| match x { SteelVal::IntV(n) => Ok(*n as f64), - SteelVal::NumV(n) => Ok(*n), + SteelVal::NumV(n) => { + no_floats = false; + Ok(*n) + } _ => stop!(TypeMismatch => "division expects a number"), }) .collect(); @@ -91,7 +106,7 @@ pub fn divide_primitive(args: &[SteelVal]) -> Result { if let Some(first) = floats.next() { let result = floats.fold(first, |acc, x| acc / x); - if result.fract() == 0.0 { + if no_floats && result.fract() == 0.0 { Ok(SteelVal::IntV(result as isize)) } else { Ok(SteelVal::NumV(result)) diff --git a/crates/steel-core/src/primitives/ports.rs b/crates/steel-core/src/primitives/ports.rs index c4d8c9e6d..f41f1fb1c 100644 --- a/crates/steel-core/src/primitives/ports.rs +++ b/crates/steel-core/src/primitives/ports.rs @@ -14,14 +14,22 @@ pub fn port_module() -> BuiltInModule { let mut module = BuiltInModule::new("steel/ports"); module .register_native_fn_definition(OPEN_STDIN_DEFINITION) + .register_native_fn_definition(OPEN_STDOUT_DEFINITION) .register_native_fn_definition(OPEN_INPUT_FILE_DEFINITION) .register_native_fn_definition(OPEN_OUTPUT_FILE_DEFINITION) + .register_native_fn_definition(OPEN_OUTPUT_STRING_DEFINITION) .register_native_fn_definition(WRITE_LINE_DEFINITION) + .register_native_fn_definition(WRITE_STRING_DEFINITION) + .register_native_fn_definition(WRITE_DEFINITION) + .register_native_fn_definition(WRITE_CHAR_DEFINITION) + .register_native_fn_definition(FLUSH_OUTPUT_PORT_DEFINITION) .register_native_fn_definition(READ_PORT_TO_STRING_DEFINITION) .register_native_fn_definition(READ_LINE_TO_STRING_DEFINITION) - .register_native_fn_definition(OPEN_STDIN_DEFINITION) + .register_native_fn_definition(GET_OUTPUT_STRING_DEFINITION) .register_native_fn_definition(IS_INPUT_DEFINITION) - .register_native_fn_definition(IS_OUTPUT_DEFINITION); + .register_native_fn_definition(IS_OUTPUT_DEFINITION) + .register_native_fn_definition(DEFAULT_INPUT_PORT_DEFINITION) + .register_native_fn_definition(DEFAULT_OUTPUT_PORT_DEFINITION); module } @@ -41,6 +49,13 @@ pub fn open_stdin() -> SteelVal { )))) } +#[function(name = "stdout")] +pub fn open_stdout() -> SteelVal { + SteelVal::PortV(Gc::new(SteelPort::StdOutput(new_rc_ref_cell( + std::io::stdout(), + )))) +} + /// Takes a filename `path` referring to an existing file and returns an input port. Raises an error /// if the file does not exist /// @@ -76,6 +91,12 @@ pub fn open_output_file(path: &SteelString) -> Result { Ok(SteelVal::PortV(Gc::new(new_port))) } +#[function(name = "open-output-string")] +pub fn open_output_string() -> Result { + let new_port = SteelPort::new_output_port(); + Ok(SteelVal::PortV(Gc::new(new_port))) +} + /// Takes a port and reads the entire content into a string /// /// (read-port-to-string port) -> string? @@ -152,3 +173,61 @@ pub fn write_line(port: &Gc, line: &SteelVal) -> Result { stop!(Generic => "unable to write string to file"); } } + +#[function(name = "raw-write")] +pub fn write(port: &Gc, line: &SteelVal) -> Result { + let line = line.to_string(); + let res = port.write_string(line.as_str()); + + if res.is_ok() { + Ok(SteelVal::Void) + } else { + stop!(Generic => "unable to write string to port"); + } +} + +#[function(name = "raw-write-char")] +pub fn write_char(port: &Gc, character: char) -> Result { + let res = port.write_char(character); + + if res.is_ok() { + Ok(SteelVal::Void) + } else { + stop!(Generic => "unable to write string to port"); + } +} + +#[function(name = "raw-write-string")] +pub fn write_string(port: &Gc, line: &SteelVal) -> Result { + let res = if let SteelVal::StringV(s) = line { + port.write_string(s.as_str()) + } else { + port.write_string(line.to_string().as_str()) + }; + + if res.is_ok() { + Ok(SteelVal::Void) + } else { + stop!(Generic => "unable to write string to port"); + } +} + +#[function(name = "get-output-string")] +pub fn get_output_string(port: &Gc) -> Result { + port.get_output_string().map(SteelVal::from) +} + +#[function(name = "flush-output-port")] +pub fn flush_output_port(port: &Gc) -> Result { + port.flush().map(|_| SteelVal::Void) +} + +#[function(name = "#%default-input-port")] +pub fn default_input_port() -> SteelVal { + SteelVal::PortV(Gc::new(SteelPort::default_current_input_port())) +} + +#[function(name = "#%default-output-port")] +pub fn default_output_port() -> SteelVal { + SteelVal::PortV(Gc::new(SteelPort::default_current_output_port())) +} diff --git a/crates/steel-core/src/primitives/strings.rs b/crates/steel-core/src/primitives/strings.rs index b679f89f7..0e0916b04 100644 --- a/crates/steel-core/src/primitives/strings.rs +++ b/crates/steel-core/src/primitives/strings.rs @@ -52,10 +52,16 @@ pub fn string_module() -> BuiltInModule { .register_native_fn_definition(STRING_TO_NUMBER_DEFINITION) .register_native_fn_definition(NUMBER_TO_STRING_DEFINITION) .register_fn("char-upcase", char_upcase) - .register_fn("char-whitespace?", char::is_whitespace); + .register_fn("char-whitespace?", char::is_whitespace) + .register_native_fn_definition(CHAR_EQUALS_DEFINITION); module } +#[function(name = "char=?", constant = true)] +pub fn char_equals(left: char, right: char) -> bool { + left == right +} + fn number_to_string_impl(value: &SteelVal, radix: Option) -> Result { match value { SteelVal::IntV(v) => { diff --git a/crates/steel-core/src/primitives/time.rs b/crates/steel-core/src/primitives/time.rs index e1d2b206d..9771f85c1 100644 --- a/crates/steel-core/src/primitives/time.rs +++ b/crates/steel-core/src/primitives/time.rs @@ -1,6 +1,9 @@ +use crate::gc::Gc; +use crate::SteelVal; use crate::{rvals::Custom, steel_vm::builtin::MarkdownDoc}; use chrono::Local; use std::{time::Duration, time::Instant}; +use steel_derive::function; use crate::steel_vm::builtin::BuiltInModule; use crate::steel_vm::register_fn::RegisterFn; @@ -34,6 +37,48 @@ fn sleep_millis(millis: usize) { std::thread::sleep(Duration::from_millis(millis.try_into().unwrap())) } +#[function(name = "current-milliseconds")] +fn current_milliseconds() -> SteelVal { + use std::time::{SystemTime, UNIX_EPOCH}; + + match SystemTime::now().duration_since(UNIX_EPOCH) { + Ok(n) => { + let ms = n.as_millis(); + match isize::try_from(ms) { + Ok(inner) => SteelVal::IntV(inner), + _ => SteelVal::BigNum(Gc::new(num::BigInt::from(ms))), + } + } + Err(_) => panic!("SystemTime before UNIX EPOCH!"), + } +} + +#[function(name = "current-second")] +fn current_seconds() -> SteelVal { + use std::time::{SystemTime, UNIX_EPOCH}; + + match SystemTime::now().duration_since(UNIX_EPOCH) { + Ok(n) => { + let ms = n.as_millis(); + match isize::try_from(ms) { + Ok(inner) => SteelVal::IntV(inner), + _ => SteelVal::BigNum(Gc::new(num::BigInt::from(ms))), + } + } + Err(_) => panic!("SystemTime before UNIX EPOCH!"), + } +} + +#[function(name = "current-inexact-milliseconds")] +fn current_inexact_milliseconds() -> f64 { + use std::time::{SystemTime, UNIX_EPOCH}; + + match SystemTime::now().duration_since(UNIX_EPOCH) { + Ok(n) => n.as_secs_f64() * 1000.0, + Err(_) => panic!("SystemTime before UNIX EPOCH!"), + } +} + pub fn time_module() -> BuiltInModule { let mut module = BuiltInModule::new("steel/time".to_string()); @@ -46,7 +91,10 @@ pub fn time_module() -> BuiltInModule { .register_fn("duration->string", duration_to_string) .register_fn("duration->seconds", Duration::as_secs) .register_fn("local-time/now!", current_time_formatted) - .register_fn("time/sleep-ms", sleep_millis); + .register_fn("time/sleep-ms", sleep_millis) + .register_native_fn_definition(CURRENT_MILLISECONDS_DEFINITION) + .register_native_fn_definition(CURRENT_SECONDS_DEFINITION) + .register_native_fn_definition(CURRENT_INEXACT_MILLISECONDS_DEFINITION); module } diff --git a/crates/steel-core/src/primitives/vectors.rs b/crates/steel-core/src/primitives/vectors.rs index 09abeb93c..2ec194d2d 100644 --- a/crates/steel-core/src/primitives/vectors.rs +++ b/crates/steel-core/src/primitives/vectors.rs @@ -24,6 +24,28 @@ impl VectorOperations { ) } + pub fn make_vector() -> SteelVal { + fn make_vector_impl(ctx: &mut VmCore, args: &[SteelVal]) -> Result { + match &args { + &[SteelVal::IntV(i)] if *i >= 0 => { + Ok(ctx.make_mutable_vector(vec![SteelVal::IntV(0); *i as usize])) + } + &[SteelVal::IntV(i), initial_value] if *i >= 0 => { + Ok(ctx.make_mutable_vector(vec![initial_value.clone(); *i as usize])) + } + _ => { + stop!(TypeMismatch => "make-vector expects a positive integer, and optionally a value to initialize the vector with, found: {:?}", args) + } + } + } + + SteelVal::BuiltIn( + |ctx: &mut VmCore, args: &[SteelVal]| -> Option> { + Some(make_vector_impl(ctx, args)) + }, + ) + } + pub fn mut_vec_to_list() -> SteelVal { SteelVal::FuncV(|args: &[SteelVal]| -> Result { if args.len() != 1 { @@ -36,9 +58,9 @@ impl VectorOperations { let ptr = v.strong_ptr(); let guard = &mut ptr.borrow_mut().value; - let new = std::mem::replace(guard, Vec::new()); + // let new = std::mem::replace(guard, Vec::new()); - Ok(SteelVal::ListV(new.into())) + Ok(SteelVal::ListV(guard.iter().collect())) // let inner = std::mem::take(guard); @@ -154,6 +176,9 @@ impl VectorOperations { }) } + // TODO: This _should_ increase the size count on the maybe_memory_size on the heap + // since it is a growable structure, we'll need to know to rerun the GC when that size + // increases past a certain amount pub fn mut_vec_push() -> SteelVal { SteelVal::FuncV(|args: &[SteelVal]| -> Result { if args.len() != 2 { diff --git a/crates/steel-core/src/rvals.rs b/crates/steel-core/src/rvals.rs index 4ead2f8db..d307455b7 100644 --- a/crates/steel-core/src/rvals.rs +++ b/crates/steel-core/src/rvals.rs @@ -16,6 +16,7 @@ use crate::{ // contracts::{ContractType, ContractedFunction}, functions::ByteCodeLambda, lazy_stream::LazyStream, + structs::SerializableUserDefinedStruct, // lists::ListDropHandler, transducers::{Reducer, Transducer}, }, @@ -914,6 +915,11 @@ impl From for SteelVal { } } +// TODO: +// This needs to be a method on the runtime: in order to properly support +// threads +// Tracking issue here: https://github.com/mattwparas/steel/issues/98 + // Values which can be sent to another thread. // If it cannot be sent to another thread, then we'll error out on conversion. // TODO: Add boxed dyn functions to this. @@ -934,6 +940,7 @@ pub enum SerializableSteelVal { BuiltIn(BuiltInSignature), SymbolV(String), Custom(Box), // Custom() + CustomStruct(SerializableUserDefinedStruct), } // Once crossed over the line, convert BACK into a SteelVal @@ -963,6 +970,12 @@ pub fn from_serializable_value(val: SerializableSteelVal) -> SteelVal { SerializableSteelVal::BuiltIn(f) => SteelVal::BuiltIn(f), SerializableSteelVal::SymbolV(s) => SteelVal::SymbolV(s.into()), SerializableSteelVal::Custom(b) => SteelVal::Custom(Gc::new(RefCell::new(b))), + SerializableSteelVal::CustomStruct(s) => { + SteelVal::CustomStruct(Gc::new(UserDefinedStruct { + fields: s.fields.into_iter().map(from_serializable_value).collect(), + type_descriptor: s.type_descriptor, + })) + } } } @@ -1004,6 +1017,18 @@ pub fn into_serializable_value(val: SteelVal) -> Result { stop!(Generic => "Custom type not allowed to be moved across threads!") } } + + SteelVal::CustomStruct(s) => Ok(SerializableSteelVal::CustomStruct( + SerializableUserDefinedStruct { + fields: s + .fields + .iter() + .cloned() + .map(into_serializable_value) + .collect::>>()?, + type_descriptor: s.type_descriptor, + }, + )), illegal => stop!(Generic => "Type not allowed to be moved across threads!: {}", illegal), } } @@ -1487,7 +1512,9 @@ impl SteelVal { (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), + (ListV(l), ListV(r)) => { + l.ptr_eq(r) || l.storage_ptr_eq(r) || l.is_empty() && r.is_empty() + } (MutFunc(l), MutFunc(r)) => *l as usize == *r as usize, (BuiltIn(l), BuiltIn(r)) => *l as usize == *r as usize, (MutableVector(l), MutableVector(r)) => HeapRef::ptr_eq(l, r), @@ -1927,6 +1954,8 @@ impl PartialOrd for SteelVal { (StringV(s), StringV(o)) => s.partial_cmp(o), (CharV(l), CharV(r)) => l.partial_cmp(r), (IntV(l), IntV(r)) => l.partial_cmp(r), + (NumV(l), IntV(r)) => l.partial_cmp(&(*r as f64)), + (IntV(l), NumV(r)) => (*l as f64).partial_cmp(r), _ => None, // unimplemented for other types } } diff --git a/crates/steel-core/src/rvals/cycles.rs b/crates/steel-core/src/rvals/cycles.rs index 59974c886..8a06a5079 100644 --- a/crates/steel-core/src/rvals/cycles.rs +++ b/crates/steel-core/src/rvals/cycles.rs @@ -49,7 +49,7 @@ pub(super) struct CycleDetector { impl CycleDetector { pub(super) fn detect_and_display_cycles(val: &SteelVal, f: &mut fmt::Formatter) -> fmt::Result { // Consider using one shared queue here - let mut queue = VecDeque::new(); + let mut queue = Vec::new(); let mut bfs_detector = CycleCollector { visited: fxhash::FxHashSet::default(), @@ -152,7 +152,13 @@ impl CycleDetector { IntV(x) => write!(f, "{x}"), StringV(s) => write!(f, "{s:?}"), BigNum(b) => write!(f, "{}", b.as_ref()), - CharV(c) => write!(f, "#\\{c}"), + CharV(c) => { + if c.is_ascii_control() { + write!(f, "{}", c) + } else { + write!(f, "#\\{c}") + } + } FuncV(func) => { if let Some(name) = get_function_name(*func) { write!(f, "#", name.name) @@ -264,7 +270,13 @@ impl CycleDetector { NumV(x) => write!(f, "{x:?}"), IntV(x) => write!(f, "{x}"), StringV(s) => write!(f, "{s:?}"), - CharV(c) => write!(f, "#\\{c}"), + CharV(c) => { + if c.is_ascii_control() { + write!(f, "{}", c) + } else { + write!(f, "#\\{c}") + } + } FuncV(func) => { if let Some(name) = get_function_name(*func) { write!(f, "#", name.name) @@ -402,7 +414,7 @@ impl Custom for SteelCycleCollector {} impl SteelCycleCollector { pub fn from_root(value: SteelVal) -> Self { - let mut queue = VecDeque::new(); + let mut queue = Vec::new(); let mut collector = CycleCollector { visited: fxhash::FxHashSet::default(), @@ -497,7 +509,7 @@ struct CycleCollector<'a> { values: Vec, // Queue of items to check - queue: &'a mut VecDeque, + queue: &'a mut Vec, // Whether we found something mutable - if we haven't, then a cycle // isn't even possible @@ -506,6 +518,10 @@ struct CycleCollector<'a> { impl<'a> CycleCollector<'a> { fn add(&mut self, val: usize, steelval: &SteelVal) -> bool { + if !self.found_mutable { + false; + } + if self.visited.contains(&val) { let id = self.cycles.len(); @@ -532,11 +548,11 @@ impl<'a> BreadthFirstSearchSteelValVisitor for CycleCollector<'a> { fn default_output(&mut self) -> Self::Output {} fn pop_front(&mut self) -> Option { - self.queue.pop_front() + self.queue.pop() } fn push_back(&mut self, value: SteelVal) { - self.queue.push_back(value) + self.queue.push(value) } fn visit_closure(&mut self, _closure: Gc) -> Self::Output {} @@ -624,6 +640,8 @@ impl<'a> BreadthFirstSearchSteelValVisitor for CycleCollector<'a> { // TODO: Figure out the mutable vector first fn visit_mutable_vector(&mut self, vector: HeapRef>) -> Self::Output { + self.found_mutable = true; + if !self.add( vector.as_ptr_usize(), &SteelVal::MutableVector(vector.clone()), @@ -776,25 +794,25 @@ pub(crate) mod drop_impls { } } - 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(); - } - } + // 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> { @@ -823,7 +841,25 @@ impl<'a> BreadthFirstSearchSteelValVisitor for IterativeDropHandler<'a> { } fn push_back(&mut self, value: SteelVal) { - self.drop_buffer.push_back(value) + match &value { + SteelVal::BoolV(_) + | SteelVal::NumV(_) + | SteelVal::IntV(_) + | SteelVal::CharV(_) + | SteelVal::Void + | SteelVal::StringV(_) + | SteelVal::FuncV(_) + | SteelVal::SymbolV(_) + | SteelVal::FutureFunc(_) + | SteelVal::FutureV(_) + | SteelVal::BoxedFunction(_) + | SteelVal::MutFunc(_) + | SteelVal::BuiltIn(_) + | SteelVal::BigNum(_) => return, + _ => { + self.drop_buffer.push_back(value); + } + } } fn visit_bool(&mut self, _boolean: bool) {} @@ -1149,9 +1185,101 @@ pub trait BreadthFirstSearchSteelValVisitor { fn visit_heap_allocated(&mut self, heap_ref: HeapRef) -> Self::Output; } +pub trait BreadthFirstSearchSteelValReferenceVisitor<'a> { + type Output; + + fn default_output(&mut self) -> Self::Output; + + fn pop_front(&mut self) -> Option<&'a SteelVal>; + + fn push_back(&mut self, value: &'a 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: &'a 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: &'a SteelVector) -> Self::Output; + fn visit_void(&mut self) -> Self::Output; + fn visit_string(&mut self, string: &'a SteelString) -> Self::Output; + fn visit_function_pointer(&mut self, ptr: FunctionSignature) -> Self::Output; + fn visit_symbol(&mut self, symbol: &'a SteelString) -> Self::Output; + fn visit_custom_type( + &mut self, + custom_type: &'a Gc>>, + ) -> Self::Output; + fn visit_hash_map(&mut self, hashmap: &'a SteelHashMap) -> Self::Output; + fn visit_hash_set(&mut self, hashset: &'a SteelHashSet) -> Self::Output; + fn visit_steel_struct(&mut self, steel_struct: &'a Gc) -> Self::Output; + fn visit_port(&mut self, port: &'a Gc) -> Self::Output; + fn visit_transducer(&mut self, transducer: &'a Gc) -> Self::Output; + fn visit_reducer(&mut self, reducer: &'a Gc) -> Self::Output; + fn visit_future_function(&mut self, function: &'a BoxedAsyncFunctionSignature) -> Self::Output; + fn visit_future(&mut self, future: &'a Gc) -> Self::Output; + fn visit_stream(&mut self, stream: &'a Gc) -> Self::Output; + fn visit_boxed_function(&mut self, function: &'a Rc) -> Self::Output; + fn visit_continuation(&mut self, continuation: &'a Gc) -> Self::Output; + fn visit_list(&mut self, list: &'a List) -> Self::Output; + fn visit_mutable_function(&mut self, function: &'a MutFunctionSignature) -> Self::Output; + fn visit_mutable_vector(&mut self, vector: &'a HeapRef>) -> Self::Output; + fn visit_builtin_function(&mut self, function: &'a BuiltInSignature) -> Self::Output; + fn visit_boxed_iterator(&mut self, iterator: &'a Gc>) -> Self::Output; + fn visit_syntax_object(&mut self, syntax_object: &'a Gc) -> Self::Output; + fn visit_boxed_value(&mut self, boxed_value: &'a Gc>) -> Self::Output; + fn visit_reference_value( + &mut self, + reference: &'a Rc>, + ) -> Self::Output; + fn visit_bignum(&mut self, bignum: &'a Gc) -> Self::Output; + fn visit_heap_allocated(&mut self, heap_ref: &'a 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 LEFT_QUEUE: RefCell> = RefCell::new(Vec::with_capacity(128)); + static RIGHT_QUEUE: RefCell> = RefCell::new(Vec::with_capacity(128)); static VISITED_SET: RefCell> = RefCell::new(fxhash::FxHashSet::default()); static EQ_DEPTH: Cell = Cell::new(0); } @@ -1183,7 +1311,7 @@ struct RecursiveEqualityHandler<'a> { left: EqualityVisitor<'a>, right: EqualityVisitor<'a>, visited: &'a mut fxhash::FxHashSet, - found_mutable_object: bool, + // found_mutable_object: bool, } impl<'a> RecursiveEqualityHandler<'a> { @@ -1195,11 +1323,11 @@ impl<'a> RecursiveEqualityHandler<'a> { } 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; + // } - if !self.found_mutable_object { + if self.visited.insert(value) { return true; } @@ -1214,13 +1342,51 @@ impl<'a> RecursiveEqualityHandler<'a> { _ => return false, }; + // println!("{} - {}", left, right); + + // println!( + // "Queue size: {:?}", + // self.left.queue.len(), + // // self.right.queue.len() + // ); + match (left, right) { - (Closure(l), Closure(r)) => { - if l != r { - return false; + (ListV(l), ListV(r)) => { + // If we've reached the same object, we're good + if l.ptr_eq(&r) || l.storage_ptr_eq(&r) { + continue; } - self.left.visit_closure(l); + if self.should_visit(l.elements_as_ptr_usize()) + && self.should_visit(r.elements_as_ptr_usize()) + { + if l.len() != r.len() { + return false; + } + + for (lvalue, rvalue) in l.iter().zip(r.iter()) { + // TODO: @Matt - need to do optimistic checks here so we don't + // visit things we don't need to - basically a "check left" function + match (lvalue, rvalue) { + (SteelVal::ListV(llist), SteelVal::ListV(rlist)) + if (llist.is_empty() && rlist.is_empty()) + || llist.ptr_eq(&rlist) + || llist.storage_ptr_eq(&rlist) => + { + continue; + } + // (SteelVal::ListV(llist), SteelVal::ListV(rlist)) if llist.len() == 1 && rlist.len() == 1 { + + // } + (a, b) => { + // println!("Pushing back: {}", a); + + self.left.push_back(a.clone()); + self.right.push_back(b.clone()); + } + } + } + } continue; } @@ -1430,23 +1596,6 @@ impl<'a> RecursiveEqualityHandler<'a> { 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 as usize != r as usize { @@ -1472,13 +1621,40 @@ impl<'a> RecursiveEqualityHandler<'a> { self.left.visit_syntax_object(l); self.right.visit_syntax_object(r); + + continue; } (HeapAllocated(l), HeapAllocated(r)) => { + if HeapRef::ptr_eq(&l, &r) { + continue; + } + self.left.visit_heap_allocated(l); self.right.visit_heap_allocated(r); continue; } + + (MutableVector(l), MutableVector(r)) => { + if HeapRef::ptr_eq(&l, &r) { + continue; + } + + self.left.visit_mutable_vector(l); + self.right.visit_mutable_vector(r); + + continue; + } + (Closure(l), Closure(r)) => { + if l != r { + return false; + } + + self.left.visit_closure(l); + self.right.visit_closure(r); + + continue; + } (_, _) => { return false; } @@ -1489,13 +1665,14 @@ impl<'a> RecursiveEqualityHandler<'a> { } } +// TODO: This _needs_ to use references. Or otherwise we'll thrash stuff on drop 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, + queue: &'a mut Vec, } impl<'a> BreadthFirstSearchSteelValVisitor for EqualityVisitor<'a> { @@ -1504,11 +1681,11 @@ impl<'a> BreadthFirstSearchSteelValVisitor for EqualityVisitor<'a> { fn default_output(&mut self) -> Self::Output {} fn pop_front(&mut self) -> Option { - self.queue.pop_front() + self.queue.pop() } fn push_back(&mut self, value: SteelVal) { - self.queue.push_back(value) + self.queue.push(value) } fn visit_closure(&mut self, _closure: Gc) -> Self::Output {} @@ -1599,8 +1776,8 @@ impl<'a> BreadthFirstSearchSteelValVisitor for EqualityVisitor<'a> { 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); + for value in list.iter() { + self.push_back(value.clone()); } } @@ -1651,6 +1828,7 @@ impl PartialEq for SteelVal { // (VectorV(l), VectorV(r)) => l == r, (SymbolV(l), SymbolV(r)) => l == r, (CharV(l), CharV(r)) => l == r, + // (ListV(l), ListV(r)) => l == r, // (HashSetV(l), HashSetV(r)) => l == r, // (HashMapV(l), HashMapV(r)) => l == r, // (Closure(l), Closure(r)) => l == r, @@ -1677,7 +1855,7 @@ impl PartialEq for SteelVal { queue: &mut right_queue, }, visited: &mut visited_set, - found_mutable_object: false, + // found_mutable_object: false, }; let res = @@ -1695,8 +1873,8 @@ impl PartialEq for SteelVal { res } _ => { - let mut left_queue = VecDeque::new(); - let mut right_queue = VecDeque::new(); + let mut left_queue = Vec::new(); + let mut right_queue = Vec::new(); let mut visited_set = fxhash::FxHashSet::default(); @@ -1714,7 +1892,7 @@ impl PartialEq for SteelVal { queue: &mut right_queue, }, visited: &mut visited_set, - found_mutable_object: false, + // found_mutable_object: false, }; let res = diff --git a/crates/steel-core/src/scheme/kernel.scm b/crates/steel-core/src/scheme/kernel.scm index 26336e224..f48632474 100644 --- a/crates/steel-core/src/scheme/kernel.scm +++ b/crates/steel-core/src/scheme/kernel.scm @@ -111,7 +111,7 @@ (if transparent? `(lambda (obj printer-function) (display "(") - (printer-function (symbol->string ,(list 'quote struct-name))) + (display (symbol->string ,(list 'quote struct-name))) ,@(map (lambda (field) `(begin (display " ") diff --git a/crates/steel-core/src/scheme/modules/mvector.scm b/crates/steel-core/src/scheme/modules/mvector.scm index 5891ff90c..e654e32c0 100644 --- a/crates/steel-core/src/scheme/modules/mvector.scm +++ b/crates/steel-core/src/scheme/modules/mvector.scm @@ -9,7 +9,11 @@ mutable-vector? make-vector vector - mutable-vector->list) + mutable-vector->list + mutable-vector-set! + mutable-vector-ref + mutable-vector-len + list->mutable-vector) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -18,17 +22,17 @@ #:prop:into-iter (lambda (object) (IntoIterator (MutableVectorIterator object 0) MutableVectorIterator-next)) #:printer (lambda (this printer-function) - (printer-function "'#(") + (simple-display "'#(") (cond [(mutable-vector-empty? this) void] [else (printer-function (mutable-vector-ref this 0)) (mutable-vector-for-each this (lambda (elem) - (printer-function " ") + (simple-display " ") (printer-function elem)) 1) - (printer-function ")")]))) + (simple-display ")")]))) ;;@doc ;; Check if the value is an immutable vector @@ -62,6 +66,12 @@ (MutableVector (private.make-mutable-vector))) (define (mutable-vector-ref vector index) + (define inner (MutableVector-inner vector)) + (when (>= index (private.mutable-vector-len inner)) + (error "index out of bounds - attempted to index" + (private.mutable-vector->list inner) + "with index: " + index)) (private.mutable-vector-ref (MutableVector-inner vector) index)) (define (mutable-vector-set! vector index value) diff --git a/crates/steel-core/src/scheme/modules/parameters.scm b/crates/steel-core/src/scheme/modules/parameters.scm index d4a8c44bd..fcd9950ba 100644 --- a/crates/steel-core/src/scheme/modules/parameters.scm +++ b/crates/steel-core/src/scheme/modules/parameters.scm @@ -5,6 +5,90 @@ make-parameter continuation?) +;;;;;; Parameters ;;;;; + +(struct Parameter (getter value) + #:mutable + #:printer (lambda (obj printer-function) (simple-display "")) + #:prop:procedure 0) + +(define (make-parameter value) + (define param (Parameter 'uninitialized value)) + + (set-Parameter-getter! param + (case-lambda + [() (Parameter-value param)] + [(new-value) (set-Parameter-value! param new-value)])) + + 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))))])) + +;;;;;;; Bootstrapping printing functions for various primitive structs + +(provide current-input-port + current-output-port + simple-display + simple-displayln + newline + write-char + write) + +(define current-input-port (make-parameter (#%default-input-port))) +(define current-output-port (make-parameter (#%default-output-port))) + +(define (simple-display x) + (raw-write-string (current-output-port) x)) + +(define newline + (case-lambda + [() (raw-write-char (current-output-port) #\newline)] + [(port) (raw-write-char port #\newline)])) + +(define (simple-displayln x) + (simple-display x) + (newline)) + +;; TODO: Swap argument order of primitive +(define (write-char char port) + (raw-write-char port char)) + +(define (write obj port) + (raw-write port obj)) + +;;;;;;;;;;;;;;;;;;;;; Port functions ;;;;;;;;;;;;;;;;;;;;; + +(provide call-with-output-string + with-output-to-string) + +(define (call-with-output-string proc) + (define output-string (open-output-string)) + (proc output-string) + (get-output-string output-string)) + +(define (with-output-to-string proc) + (call-with-output-string (lambda (p) + (parameterize ([current-output-port p]) + (proc))))) + +;;;;;;;;;;;;;;;;;;;;; Dynamic Wind ;;;;;;;;;;;;;;;;;;;;;;; + (define winders '()) (define list-tail drop) @@ -17,8 +101,6 @@ (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 @@ -76,58 +158,3 @@ (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/reader.scm b/crates/steel-core/src/scheme/modules/reader.scm new file mode 100644 index 000000000..90f17f79a --- /dev/null +++ b/crates/steel-core/src/scheme/modules/reader.scm @@ -0,0 +1,40 @@ +(require-builtin #%private/steel/reader as reader.) +(require "steel/result") +(require "#%private/steel/control") + +(provide read) + +(define *reader* (reader.new-reader)) + +(define (read) + (define value (read-impl)) + (if (Ok? value) (Ok->value value) (raise-error (Err->value value)))) + +(define (read-impl) + + (cond + [(reader.reader-empty? *reader*) + (define next-line (read-line-from-port (current-input-port))) + + (cond + [(string? next-line) + (reader.reader-push-string *reader* next-line) + (reader.reader-read-one *reader*)] + + [else + => + next-line])] + + ;; The reader is not empty! + [else + => + (let ([next (reader.reader-read-one *reader*)]) + + (map-ok next + (lambda (obj) + (if (void? next) + (begin + (displayln "pushing another string") + (reader.reader-push-string *reader* (read-line-from-port (current-input-port))) + (read-impl)) + next))))])) diff --git a/crates/steel-core/src/scheme/modules/result.scm b/crates/steel-core/src/scheme/modules/result.scm index 0fa2895fa..b420941bf 100644 --- a/crates/steel-core/src/scheme/modules/result.scm +++ b/crates/steel-core/src/scheme/modules/result.scm @@ -4,11 +4,8 @@ ;; 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")) +(require "#%private/steel/contract" + (for-syntax "#%private/steel/contract")) (provide Result? Ok diff --git a/crates/steel-core/src/scheme/print.scm b/crates/steel-core/src/scheme/print.scm index 7e4335bee..7f158dedb 100644 --- a/crates/steel-core/src/scheme/print.scm +++ b/crates/steel-core/src/scheme/print.scm @@ -1,4 +1,5 @@ (require-builtin steel/base) +(require "#%private/steel/control") (provide displayln display) @@ -12,14 +13,15 @@ (return! void)) (for-each func (cdr lst))))) -(define (display obj) - +(define (display-impl 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) "=") + (simple-display "#") + (simple-display (#%private-cycle-collector-get cycle-collector obj)) + (simple-display "=") (#%top-level-print obj cycle-collector) (newline))) (#%private-cycle-collector-values cycle-collector)) @@ -30,6 +32,15 @@ (#%top-level-print obj cycle-collector)) +(define display + (case-lambda + [(obj) (display-impl obj)] + [(obj port) + (parameterize ([current-output-port port]) + (display-impl obj))])) + +;; TODO: Nuke the displayln multiple arguments. I think displayln should +;; just take one argument for now (define (displayln . objs) (cond @@ -39,7 +50,10 @@ (newline)] [else - (for-each display objs) + (for-each (lambda (x) + (display x) + (simple-display " ")) + objs) (newline)])) (define (#%top-level-print obj collector) @@ -67,10 +81,13 @@ (cond [(function? printer) (printer obj (lambda (x) (#%print x collector)))] - [else + ;; Truthiness here needs to be addressed + [printer (simple-display "#<") (simple-display (symbol->string (#%struct-property-ref obj '#:name))) - (simple-display ">")]))] + (simple-display ">")] + + [else (simple-display obj)]))] [(set? obj) (cond @@ -124,9 +141,12 @@ [(symbol? obj) (simple-display (symbol->string obj))] [(atom? obj) (simple-display obj)] [(function? obj) (simple-display obj)] + [(void? obj) (simple-display obj)] ;; There is a cycle! [(int? (#%private-cycle-collector-get collector obj)) - (simple-display "#" (#%private-cycle-collector-get collector obj) "#")] + (simple-display "#") + (simple-display (#%private-cycle-collector-get collector obj)) + (simple-display "#")] [(list? obj) (simple-display "(") (when (not (empty? obj)) @@ -143,11 +163,12 @@ (cond [(function? printer) (printer obj (lambda (x) (#%print x collector)))] - - [else + [printer (simple-display "#<") (simple-display (symbol->string (#%struct-property-ref obj '#:name))) - (simple-display ">")]))] + (simple-display ">")] + + [else (simple-display obj)]))] [(set? obj) (cond @@ -190,4 +211,4 @@ (simple-display ")")]))] - [else (simple-displayln obj)])) + [else (simple-display obj)])) diff --git a/crates/steel-core/src/scheme/stdlib.scm b/crates/steel-core/src/scheme/stdlib.scm index 452b86b5d..3bf33b7ef 100644 --- a/crates/steel-core/src/scheme/stdlib.scm +++ b/crates/steel-core/src/scheme/stdlib.scm @@ -453,9 +453,10 @@ (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 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 (obj lst) (fold (mem-helper (curry equal? obj) id) #f lst))) (define member (lambda (x los) @@ -472,14 +473,16 @@ [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 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 (lambda (obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))) ; (define assoc ) (define (assoc thing alist) + ; (simple-displayln "Calling assoc") + ; (simple-displayln alist) (if (null? alist) #f (if (equal? (car (car alist)) thing) (car alist) (assoc thing (cdr alist))))) (define (filter pred lst) @@ -710,4 +713,8 @@ (define values list) (define (call-with-values producer consumer) - (apply consumer (producer))) + (define result (apply consumer (producer))) + (cond + [(not (list? result)) result] + [(= (length result) 1) (car result)] + [else result])) diff --git a/crates/steel-core/src/stdlib.rs b/crates/steel-core/src/stdlib.rs index 60034928f..75c6c0d61 100644 --- a/crates/steel-core/src/stdlib.rs +++ b/crates/steel-core/src/stdlib.rs @@ -12,8 +12,6 @@ pub const MERGE: &str = include_str!("scheme/merge.rkt"); #[cfg(not(target_os = "windows"))] pub const COMPILER: &str = include_str!("scheme/nanopass.rkt"); #[cfg(not(target_os = "windows"))] -pub const DISPLAY: &str = include_str!("scheme/display.rkt"); -#[cfg(not(target_os = "windows"))] pub const KERNEL: &str = include_str!("scheme/kernel.scm"); #[cfg(target_os = "windows")] @@ -27,6 +25,4 @@ pub const MERGE: &str = include_str!(r#"scheme\merge.rkt"#); #[cfg(target_os = "windows")] pub const COMPILER: &str = include_str!(r#"scheme\nanopass.rkt"#); #[cfg(target_os = "windows")] -pub const DISPLAY: &str = include_str!(r#"scheme\display.rkt"#); -#[cfg(target_os = "windows")] pub const KERNEL: &str = include_str!(r#"scheme\kernel.scm"#); diff --git a/crates/steel-core/src/steel_vm/engine.rs b/crates/steel-core/src/steel_vm/engine.rs index 07f3260ab..c7783e54e 100644 --- a/crates/steel-core/src/steel_vm/engine.rs +++ b/crates/steel-core/src/steel_vm/engine.rs @@ -15,7 +15,7 @@ use super::dylib::DylibContainers; use crate::{ compiler::{ compiler::{Compiler, SerializableCompiler}, - modules::CompiledModule, + modules::{CompiledModule, PRELUDE_WITHOUT_BASE}, program::{Executable, RawProgramWithSymbols, SerializableRawProgramWithSymbols}, }, containers::RegisterValue, @@ -252,7 +252,7 @@ impl Engine { log::debug!(target:"kernel", "Registered modules in the kernel!"); - let core_libraries = [crate::stdlib::PRELUDE, crate::stdlib::DISPLAY]; + let core_libraries = [crate::stdlib::PRELUDE]; for core in core_libraries.into_iter() { vm.compile_and_run_raw_program(core).unwrap(); @@ -418,7 +418,6 @@ impl Engine { let bootstrap_sources = [ crate::steel_vm::primitives::ALL_MODULES, crate::stdlib::PRELUDE, - crate::stdlib::DISPLAY, ]; for source in bootstrap_sources { @@ -470,7 +469,6 @@ impl Engine { let bootstrap_sources = [ crate::steel_vm::primitives::ALL_MODULES, crate::stdlib::PRELUDE, - crate::stdlib::DISPLAY, ]; for source in bootstrap_sources { @@ -652,7 +650,6 @@ impl Engine { let bootstrap_sources = [ crate::steel_vm::primitives::ALL_MODULES, crate::stdlib::PRELUDE, - crate::stdlib::DISPLAY, ]; for source in bootstrap_sources { @@ -760,7 +757,7 @@ impl Engine { vm.compile_and_run_raw_program(crate::steel_vm::primitives::SANDBOXED_MODULES) .unwrap(); - let core_libraries = [crate::stdlib::PRELUDE, crate::stdlib::DISPLAY]; + let core_libraries = [crate::stdlib::PRELUDE]; for core in core_libraries.into_iter() { vm.compile_and_run_raw_program(core).unwrap(); @@ -960,14 +957,7 @@ impl 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.run(PRELUDE_WITHOUT_BASE).unwrap(); engine } @@ -992,7 +982,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]; + let core_libraries = &[crate::stdlib::PRELUDE]; for core in core_libraries { self.compile_and_run_raw_program(core)?; @@ -1014,7 +1004,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]; + let core_libraries = &[crate::stdlib::PRELUDE]; for core in core_libraries { self.compile_and_run_raw_program(core)?; diff --git a/crates/steel-core/src/steel_vm/primitives.rs b/crates/steel-core/src/steel_vm/primitives.rs index a45304f7e..2239f850b 100644 --- a/crates/steel-core/src/steel_vm/primitives.rs +++ b/crates/steel-core/src/steel_vm/primitives.rs @@ -53,11 +53,9 @@ use crate::{ #[cfg(feature = "web")] use crate::primitives::web::{requests::requests_module, websockets::websockets_module}; -use crate::primitives::colors::string_coloring_module; - use crate::values::lists::List; use im_rc::HashMap; -use num::Signed; +use num::{Signed, ToPrimitive}; use once_cell::sync::Lazy; macro_rules! ensure_tonicity_two { @@ -311,6 +309,7 @@ thread_local! { pub static MUTABLE_HASH_MODULE: BuiltInModule = mutable_hashmap_module(); pub static MUTABLE_VECTOR_MODULE: BuiltInModule = mutable_vector_module(); + pub static PRIVATE_READER_MODULE: BuiltInModule = reader_module(); #[cfg(feature = "web")] pub static WEBSOCKETS_MODULE: BuiltInModule = websockets_module(); @@ -321,7 +320,6 @@ thread_local! { #[cfg(feature = "blocking_requests")] pub static BLOCKING_REQUESTS_MODULE: BuiltInModule = crate::primitives::blocking_requests::blocking_requests_module(); - pub static STRING_COLORS_MODULE: BuiltInModule = string_coloring_module(); #[cfg(feature = "sqlite")] pub static SQLITE_MODULE: BuiltInModule = crate::primitives::sqlite::sqlite_module(); @@ -466,8 +464,7 @@ pub fn register_builtin_modules(engine: &mut Engine) { // Private module engine.register_module(MUTABLE_HASH_MODULE.with(|x| x.clone())); engine.register_module(MUTABLE_VECTOR_MODULE.with(|x| x.clone())); - - engine.register_module(STRING_COLORS_MODULE.with(|x| x.clone())); + engine.register_module(PRIVATE_READER_MODULE.with(|x| x.clone())); #[cfg(feature = "web")] engine @@ -619,6 +616,7 @@ fn vector_module() -> BuiltInModule { let mut module = BuiltInModule::new("steel/vectors"); module .register_value("mutable-vector", VectorOperations::mut_vec_construct()) + .register_value("make-vector", VectorOperations::make_vector()) .register_value("mutable-vector->list", VectorOperations::mut_vec_to_list()) .register_value("vector-push!", VectorOperations::mut_vec_push()) .register_value("mut-vec-len", VectorOperations::mut_vec_length()) @@ -739,11 +737,14 @@ fn functionp(value: &SteelVal) -> bool { #[steel_derive::function(name = "procedure?", constant = true)] fn procedurep(value: &SteelVal) -> bool { + if let SteelVal::CustomStruct(s) = value { + return s.maybe_proc().map(|x| procedurep(x)).unwrap_or(false); + } + matches!( value, SteelVal::Closure(_) | SteelVal::FuncV(_) - // | SteelVal::ContractedFunction(_) | SteelVal::BoxedFunction(_) | SteelVal::ContinuationFunction(_) | SteelVal::MutFunc(_) @@ -809,6 +810,25 @@ fn stream_module() -> BuiltInModule { // module // } +#[steel_derive::function(name = "exact->inexact", constant = true)] +fn exact_to_inexact(number: &SteelVal) -> Result { + match number { + SteelVal::IntV(i) => Ok(SteelVal::NumV(*i as f64)), + SteelVal::NumV(n) => Ok(SteelVal::NumV(*n)), + SteelVal::BigNum(n) => Ok(SteelVal::NumV(n.to_f64().unwrap())), + _ => stop!(TypeMismatch => "exact->inexact expects a number type, found: {}", number), + } +} + +// Docs from racket: +// (round x) → (or/c integer? +inf.0 -inf.0 +nan.0) +// x : real? +// Returns the integer closest to x, resolving ties in favor of an even number, but +inf.0, -inf.0, and +nan.0 round to themselves. +#[steel_derive::function(name = "round", constant = true)] +fn round(number: f64) -> f64 { + number.round() +} + #[steel_derive::function(name = "abs", constant = true)] fn abs(number: &SteelVal) -> Result { match number { @@ -842,7 +862,9 @@ fn number_module() -> BuiltInModule { .register_fn("quotient", quotient) .register_value("arithmetic-shift", NumOperations::arithmetic_shift()) .register_native_fn_definition(ABS_DEFINITION) - .register_native_fn_definition(EXPT_DEFINITION); + .register_native_fn_definition(EXPT_DEFINITION) + .register_native_fn_definition(ROUND_DEFINITION) + .register_native_fn_definition(EXACT_TO_INEXACT_DEFINITION); module } @@ -916,6 +938,7 @@ fn equality_module() -> BuiltInModule { "equal?", SteelVal::FuncV(ensure_tonicity_two!(|a, b| a == b)), ) + .register_value("eqv?", SteelVal::FuncV(ensure_tonicity_two!(|a, b| a == b))) .register_value( "eq?", SteelVal::FuncV(ensure_tonicity_two!( @@ -987,13 +1010,13 @@ 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("simple-display", IoFunctions::display()) + .register_value("stdout-simple-displayln", IoFunctions::displayln()) + // .register_value("newline", IoFunctions::newline()) .register_value("read-to-string", IoFunctions::read_to_string()); - #[cfg(feature = "colors")] - module.register_value("display-color", IoFunctions::display_color()); + // #[cfg(feature = "colors")] + // module.register_value("display-color", IoFunctions::display_color()); module } @@ -1215,6 +1238,71 @@ impl MutableHashTable { } } +struct Reader { + buffer: String, + offset: usize, +} + +impl crate::rvals::Custom for Reader {} + +impl Reader { + fn create_reader() -> Reader { + Self { + buffer: String::new(), + offset: 0, + } + } + + fn push_string(&mut self, input: crate::rvals::SteelString) { + self.buffer.push_str(input.as_str()); + } + + fn is_empty(&self) -> bool { + self.buffer.is_empty() + } + + fn read_one(&mut self) -> Result { + if let Some(buffer) = self.buffer.get(self.offset..) { + let mut parser = crate::parser::parser::Parser::new(buffer, None); + + if let Some(next) = parser.next() { + self.offset += parser.offset(); + + let result = SteelVal::try_from(next?); + + if let Some(remaining) = self.buffer.get(self.offset..) { + for _ in remaining.chars().take_while(|x| x.is_whitespace()) { + self.offset += 1; + } + } + + if self.offset == self.buffer.len() { + self.buffer.clear(); + self.offset = 0; + } + + result + } else { + Ok(SteelVal::Void) + } + } else { + Ok(SteelVal::Void) + } + } +} + +fn reader_module() -> BuiltInModule { + let mut module = BuiltInModule::new("#%private/steel/reader"); + + module + .register_fn("new-reader", Reader::create_reader) + .register_fn("reader-push-string", Reader::push_string) + .register_fn("reader-read-one", Reader::read_one) + .register_fn("reader-empty?", Reader::is_empty); + + module +} + fn mutable_vector_module() -> BuiltInModule { let mut module = BuiltInModule::new("#%private/steel/mvector"); diff --git a/crates/steel-core/src/steel_vm/register_fn.rs b/crates/steel-core/src/steel_vm/register_fn.rs index 1439330aa..1105aaf59 100644 --- a/crates/steel-core/src/steel_vm/register_fn.rs +++ b/crates/steel-core/src/steel_vm/register_fn.rs @@ -1617,7 +1617,11 @@ impl< } let mut input = ::as_ref_from_ref(&args[0])?; - let arg = ::from_steelval(&args[1])?; + let arg = ::from_steelval(&args[1]).map_err(|mut err| { + err.prepend_message(":"); + err.prepend_message(name); + err + })?; let res = func(&mut input, arg); @@ -1734,7 +1738,14 @@ impl< let input = B::as_ref(&args[1], &mut nursery)?; - let res = func(A::from_steelval(&args[0])?, &input); + let res = func( + A::from_steelval(&args[0]).map_err(|mut err| { + err.prepend_message(":"); + err.prepend_message(name); + err + })?, + &input, + ); res.into_steelval() }; @@ -1763,7 +1774,11 @@ macro_rules! impl_register_fn { stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, $arg_count, args.len())); } - let res = func($(<$param>::from_steelval(&args[$idx])?,)*); + let res = func($(<$param>::from_steelval(&args[$idx]).map_err(|mut err| { + err.prepend_message(":"); + err.prepend_message(name); + err + })?,)*); res.into_steelval() }; @@ -1790,7 +1805,11 @@ macro_rules! impl_register_fn { stop!(ArityMismatch => format!("{} expected {} argument, got {}", name, $arg_count, args.len())); } - let res = func($(<$param>::from_steelval(&args[$idx])?,)*); + let res = func($(<$param>::from_steelval(&args[$idx]).map_err(|mut err| { + err.prepend_message(":"); + err.prepend_message(name); + err + })?,)*); res.into_steelval() }; @@ -1872,7 +1891,11 @@ macro_rules! impl_register_fn_self { let input = ::as_ref(&args[0], &mut nursery)?; - let res = func(&input, $(<$param>::from_steelval(&args[$idx])?,)*); + let res = func(&input, $(<$param>::from_steelval(&args[$idx]).map_err(|mut err| { + err.prepend_message(":"); + err.prepend_message(name); + err + })?,)*); res.into_steelval() }; @@ -1903,7 +1926,11 @@ macro_rules! impl_register_fn_self { let mut input = ::as_mut_ref(&args[0])?; - let res = func(&mut input, $(<$param>::from_steelval(&args[$idx])?,)*); + let res = func(&mut input, $(<$param>::from_steelval(&args[$idx]).map_err(|mut err| { + err.prepend_message(":"); + err.prepend_message(name); + err + })?,)*); res.into_steelval() }; @@ -1934,7 +1961,11 @@ macro_rules! impl_register_fn_self { let mut input = ::as_mut_ref_from_ref(&args[0])?; - let res = func(&mut input, $(<$param>::from_steelval(&args[$idx])?,)*); + let res = func(&mut input, $(<$param>::from_steelval(&args[$idx]).map_err(|mut err| { + err.prepend_message(":"); + err.prepend_message(name); + err + })?,)*); res.into_steelval() }; diff --git a/crates/steel-core/src/steel_vm/vm.rs b/crates/steel-core/src/steel_vm/vm.rs index 7c13763d7..79fe95869 100644 --- a/crates/steel-core/src/steel_vm/vm.rs +++ b/crates/steel-core/src/steel_vm/vm.rs @@ -29,7 +29,6 @@ use crate::{ stop, values::functions::ByteCodeLambda, }; -// use std::env::current_exe; use std::{cell::RefCell, collections::HashMap, iter::Iterator, rc::Rc}; use super::builtin::DocTemplate; @@ -80,6 +79,7 @@ const STACK_LIMIT: usize = 1000000; const _JIT_THRESHOLD: usize = 100; const USE_SUPER_INSTRUCTIONS: bool = false; +const CHECK_STACK_OVERFLOW: bool = false; #[repr(C)] #[derive(Clone, Debug, Copy, PartialEq)] @@ -218,6 +218,7 @@ impl StackFrame { // self // } + #[inline(always)] pub fn set_function(&mut self, function: Gc) { #[cfg(not(feature = "unsafe-internals"))] { @@ -867,6 +868,7 @@ impl<'a> VmCore<'a> { fn gc_collect(&mut self) { self.thread.heap.collect( + None, None, self.thread.stack.iter(), self.thread.stack_frames.iter().map(|x| x.function.as_ref()), @@ -2288,7 +2290,10 @@ impl<'a> VmCore<'a> { // dbg!(value); // } - self.update_state_with_frame(last); + // self.update_state_with_frame(last); + + self.ip = last.ip; + self.instructions = last.instructions; self.sp = self.get_last_stack_frame_sp(); @@ -2559,7 +2564,9 @@ impl<'a> VmCore<'a> { let mut captures = Vec::with_capacity(ndefs as usize); // TODO: This shouldn't be the same size as the captures - let mut heap_vars = Vec::with_capacity(ndefs as usize); + // let mut heap_vars = Vec::with_capacity(ndefs as usize); + + let mut heap_vars = Vec::new(); // TODO clean this up a bit // hold the spot for where we need to jump aftwards @@ -2599,12 +2606,14 @@ impl<'a> VmCore<'a> { // need to do this step at all each time. // Looks like all COPYHEAPCAPTURECLOSURE(s) happen at the start. So we should be able to store those // Directly - (OpCode::COPYHEAPCAPTURECLOSURE, n) => { - heap_vars.push(guard.function.heap_allocated().borrow()[n as usize].clone()); - } - (OpCode::FIRSTCOPYHEAPCAPTURECLOSURE, n) => { - heap_vars.push(guard.function.heap_allocated().borrow()[n as usize].clone()); - } + + // TODO: These will disappear + // (OpCode::COPYHEAPCAPTURECLOSURE, n) => { + // heap_vars.push(guard.function.heap_allocated().borrow()[n as usize].clone()); + // } + // (OpCode::FIRSTCOPYHEAPCAPTURECLOSURE, n) => { + // heap_vars.push(guard.function.heap_allocated().borrow()[n as usize].clone()); + // } (l, _) => { panic!( "Something went wrong in closure construction!, found: {:?} @ {}", @@ -2623,14 +2632,14 @@ impl<'a> VmCore<'a> { .closure_interner .get(&closure_id) { - log::trace!("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::trace!("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); @@ -3005,6 +3014,7 @@ impl<'a> VmCore<'a> { .thread .stack .split_off(self.thread.stack.len() - payload_size); + let result = func(self, &args).map(|x| { x.map_err(|x| { // TODO: @Matt 4/24/2022 -> combine this into one function probably @@ -3298,14 +3308,14 @@ impl<'a> VmCore<'a> { #[inline(always)] fn check_stack_overflow(&self) -> Result<()> { - // println!("Depth: {}", self.thread.stack_frames.len()); - // println!("Stack length: {}", self.thread.stack.len()); - - if unlikely(self.thread.stack_frames.len() >= STACK_LIMIT) { - crate::core::instructions::pretty_print_dense_instructions(&self.instructions); - println!("stack frame at exit: {:?}", self.thread.stack); - stop!(Generic => "stack overflowed!"; self.current_span()); + if CHECK_STACK_OVERFLOW { + if unlikely(self.thread.stack_frames.len() >= STACK_LIMIT) { + crate::core::instructions::pretty_print_dense_instructions(&self.instructions); + println!("stack frame at exit: {:?}", self.thread.stack); + stop!(Generic => "stack overflowed!"; self.current_span()); + } } + Ok(()) } @@ -3504,7 +3514,6 @@ impl<'a> VmCore<'a> { // } // TODO improve this a bit - // #[inline(always)] #[inline(always)] fn handle_function_call_closure_jit_without_profiling( &mut self, @@ -5501,6 +5510,22 @@ fn read_alloc_handler(ctx: &mut VmCore<'_>) -> Result<()> { .borrow()[payload_size] .get(); + // dbg!(payload_size); + + // dbg!(ctx + // .thread + // .stack_frames + // .last() + // .unwrap() + // .function + // .heap_allocated() + // .borrow() + // .iter() + // .map(|x| x.get()) + // .collect::>()); + + dbg!(&value); + ctx.thread.stack.push(value); ctx.ip += 1; diff --git a/crates/steel-core/src/tests/mod.rs b/crates/steel-core/src/tests/mod.rs index fc4439ca9..b0206d490 100644 --- a/crates/steel-core/src/tests/mod.rs +++ b/crates/steel-core/src/tests/mod.rs @@ -112,6 +112,7 @@ test_harness_success! { stack_test_with_contract, string_append, structs, + // TODO: @Matt 11/11/2023 threads, transducer_over_streams, tree_traversal, diff --git a/crates/steel-core/src/tests/success/letrec_simple_recursion.scm b/crates/steel-core/src/tests/success/letrec_simple_recursion.scm index 0102a1a98..9ba0ab8f3 100644 --- a/crates/steel-core/src/tests/success/letrec_simple_recursion.scm +++ b/crates/steel-core/src/tests/success/letrec_simple_recursion.scm @@ -1,10 +1,6 @@ (define (test) - (let ((loop void)) - (let ((loop-prime (lambda (x) - (if (= x 10000) - x - (loop (+ x 1)))))) - (set! loop loop-prime)) + (let ([loop void]) + (let ([loop-prime (lambda (x) (if (= x 10000) x (loop (+ x 1))))]) (set! loop loop-prime)) (loop 0))) -(assert! (= (test) 10000)) \ No newline at end of file +(assert! (= (test) 10000)) diff --git a/crates/steel-core/src/tests/success/matcher.scm b/crates/steel-core/src/tests/success/matcher.scm index 29acb09b1..46d87805f 100644 --- a/crates/steel-core/src/tests/success/matcher.scm +++ b/crates/steel-core/src/tests/success/matcher.scm @@ -64,13 +64,13 @@ (display "> ") (display name) (display " ... ") - (display-color "OK" 'green) + (display "OK") (newline)) (begin (display "> ") (display name) (display " ... ") - (display-color "FAILED" 'red) + (display "FAILED") (newline) (display " Expected: ") (display expected) diff --git a/crates/steel-core/src/tests/success/threads.scm b/crates/steel-core/src/tests/success/threads.scm index 114cab67a..c90ea4284 100644 --- a/crates/steel-core/src/tests/success/threads.scm +++ b/crates/steel-core/src/tests/success/threads.scm @@ -1,5 +1,14 @@ (define (foo x) (vector 10 20 30 40 x)) +;; TODO: This actually won't work now - displayln references (current-output-port) +;; which is a parameter, which allocates a mutable variable. So for this to work: +;; 1. Certain kinds of ports need to be transferrable across threads +;; 2. Mutable variables need to be transferrable across threads, by being allocated +;; in the target threads heap +;; 3. Parameters somehow need to be "reinitialized" to have a default value. This should +;; be doable by having some kind of thread initialization function (like how thread locals work) + ;; Closure should get serialized and sent across the thread -(Ok->value (thread-join! (spawn-thread! (lambda () (displayln (vector-ref (foo 100) 4)))))) +(Ok->value (thread-join! (spawn-thread! (lambda () + (stdout-simple-displayln (vector-ref (foo 100) 4)))))) diff --git a/crates/steel-core/src/values/closed.rs b/crates/steel-core/src/values/closed.rs index 261ea7d0e..45b1ef1c8 100644 --- a/crates/steel-core/src/values/closed.rs +++ b/crates/steel-core/src/values/closed.rs @@ -1,6 +1,5 @@ use std::{ cell::RefCell, - collections::VecDeque, rc::{Rc, Weak}, }; @@ -30,7 +29,7 @@ use super::{ transducers::{Reducer, Transducer}, }; -const GC_THRESHOLD: usize = 256; +const GC_THRESHOLD: usize = 256 * 1000; const GC_GROW_FACTOR: usize = 2; const RESET_LIMIT: usize = 5; @@ -107,13 +106,95 @@ impl SteelVal { } } +type HeapValue = Rc>>; +type HeapVector = Rc>>>; + +// Maybe uninitialized + +struct FreeList { + elements: Vec>, + cursor: usize, + alloc_count: usize, +} + +impl FreeList { + const EXTEND_CHUNK: usize = 128; + + fn is_heap_full(&self) -> bool { + self.alloc_count == self.elements.len() + } + + fn extend_heap(&mut self) { + self.cursor = self.elements.len(); + + self.elements.reserve(Self::EXTEND_CHUNK); + self.elements + .extend(std::iter::repeat(None).take(Self::EXTEND_CHUNK)); + } + + fn allocate(&mut self, value: SteelVal) -> HeapRef { + // Drain, moving values around... + // is that expensive? + + let pointer = Rc::new(RefCell::new(HeapAllocated::new(value))); + let weak_ptr = Rc::downgrade(&pointer); + + self.elements[self.cursor] = Some(pointer); + self.alloc_count += 1; + + // Find where to assign the next slot optimistically + let next_slot = self.elements[self.cursor..] + .iter() + .position(Option::is_none); + + if let Some(next_slot) = next_slot { + self.cursor += next_slot; + } else { + // + if self.is_heap_full() { + // Extend the heap, move the cursor to the end + self.extend_heap(); + } else { + self.cursor = self.elements.iter().position(Option::is_none).unwrap() + } + } + + HeapRef { inner: weak_ptr } + } + + fn collect_on_condition(&mut self, func: fn(&HeapValue) -> bool) -> usize { + let mut amount_dropped = 0; + + self.elements.iter_mut().for_each(|x| { + if x.as_ref().map(func).unwrap_or_default() { + *x = None; + amount_dropped += 1; + } + }); + + self.alloc_count -= amount_dropped; + + amount_dropped + } + + fn weak_collection(&mut self) -> usize { + self.collect_on_condition(|inner| Rc::weak_count(inner) == 0) + } + + fn strong_collection(&mut self) -> usize { + self.collect_on_condition(|inner| !inner.borrow().is_reachable()) + } +} + #[derive(Clone)] pub struct Heap { memory: Vec>>>, vectors: Vec>>>>, count: usize, threshold: usize, - mark_and_sweep_queue: VecDeque, + // mark_and_sweep_queue: VecDeque, + mark_and_sweep_queue: Vec, + maybe_memory_size: usize, } impl Heap { @@ -123,7 +204,9 @@ impl Heap { vectors: Vec::with_capacity(256), count: 0, threshold: GC_THRESHOLD, - mark_and_sweep_queue: VecDeque::with_capacity(256), + // mark_and_sweep_queue: VecDeque::with_capacity(256), + mark_and_sweep_queue: Vec::with_capacity(256), + maybe_memory_size: 0, } } @@ -137,7 +220,7 @@ impl Heap { live_functions: impl Iterator, globals: impl Iterator, ) -> HeapRef { - self.collect(Some(value.clone()), roots, live_functions, globals); + self.collect(Some(value.clone()), None, roots, live_functions, globals); let pointer = Rc::new(RefCell::new(HeapAllocated::new(value))); let weak_ptr = Rc::downgrade(&pointer); @@ -155,7 +238,7 @@ impl Heap { live_functions: impl Iterator, globals: impl Iterator, ) -> HeapRef> { - self.collect(None, roots, live_functions, globals); + self.collect(None, Some(&values), roots, live_functions, globals); let pointer = Rc::new(RefCell::new(HeapAllocated::new(values))); let weak_ptr = Rc::downgrade(&pointer); @@ -165,16 +248,22 @@ impl Heap { HeapRef { inner: weak_ptr } } + fn vector_cells_allocated(&self) -> usize { + // self.vectors.iter().map(|x| x.borrow().value.len()).sum() + self.vectors.len() + } + // 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, + root_vector: Option<&Vec>, roots: impl Iterator, live_functions: impl Iterator, globals: impl Iterator, ) { - let memory_size = self.memory.len() + self.vectors.len(); + let memory_size = self.memory.len() + self.vector_cells_allocated(); if memory_size > self.threshold { log::debug!(target: "gc", "Freeing memory"); @@ -190,32 +279,36 @@ impl Heap { // sweep collection. let mut changed = true; while changed { + let now = std::time::Instant::now(); + log::debug!(target: "gc", "Small collection"); - let prior_len = self.memory.len() + self.vectors.len(); + let prior_len = self.memory.len() + self.vector_cells_allocated(); log::debug!(target: "gc", "Previous length: {:?}", prior_len); self.memory.retain(|x| Rc::weak_count(x) > 0); self.vectors.retain(|x| Rc::weak_count(x) > 0); - let after = self.memory.len() + self.vectors.len(); + let after = self.memory.len() + self.vector_cells_allocated(); log::debug!(target: "gc", "Objects freed: {:?}", prior_len - after); + log::debug!(target: "gc", "Small collection time: {:?}", now.elapsed()); + changed = prior_len != after; } - let post_small_collection_size = self.memory.len() + self.vectors.len(); + let post_small_collection_size = self.memory.len() + self.vector_cells_allocated(); // 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); + self.mark_and_sweep(root_value, root_vector, 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.threshold = (self.threshold + self.memory.len() + self.vector_cells_allocated()) + * GC_GROW_FACTOR; self.count += 1; @@ -226,8 +319,8 @@ impl Heap { self.threshold = GC_THRESHOLD; self.count = 0; - self.memory.shrink_to(GC_THRESHOLD); - self.vectors.shrink_to(GC_THRESHOLD); + self.memory.shrink_to(GC_THRESHOLD * GC_GROW_FACTOR); + self.vectors.shrink_to(GC_THRESHOLD * GC_GROW_FACTOR); } } } @@ -235,12 +328,15 @@ impl Heap { fn mark_and_sweep<'a>( &mut self, root_value: Option, + root_vector: Option<&Vec>, roots: impl Iterator, function_stack: impl Iterator, globals: impl Iterator, ) { log::debug!(target: "gc", "Marking the heap"); + let now = std::time::Instant::now(); + let mut context = MarkAndSweepContext { queue: &mut self.mark_and_sweep_queue, }; @@ -249,6 +345,12 @@ impl Heap { context.push_back(root_value); } + if let Some(root_vector) = root_vector { + for value in root_vector { + context.push_back(value.clone()); + } + } + for root in roots { context.push_back(root.clone()); } @@ -265,6 +367,10 @@ impl Heap { for heap_ref in function.heap_allocated.borrow().iter() { context.mark_heap_reference(&heap_ref.strong_ptr()) } + + for value in function.captures() { + context.push_back(value.clone()); + } } context.visit(); @@ -278,6 +384,10 @@ impl Heap { context.visit(); + log::debug!(target: "gc", "Mark: Time taken: {:?}", now.elapsed()); + + let now = std::time::Instant::now(); + // println!("Freeing heap"); // TODO -> move destructors to another thread? @@ -293,11 +403,25 @@ impl Heap { // ); log::debug!(target: "gc", "--- Sweeping ---"); - let prior_len = self.memory.len() + self.vectors.len(); + let prior_len = self.memory.len() + self.vector_cells_allocated(); // sweep - self.memory.retain(|x| x.borrow().is_reachable()); - self.vectors.retain(|x| x.borrow().is_reachable()); + self.memory.retain(|x| { + // let mut guard = x.borrow_mut(); + // let is_reachable = guard.is_reachable(); + // guard.reset(); + // is_reachable + + x.borrow().is_reachable() + }); + self.vectors.retain(|x| { + // let mut guard = x.borrow_mut(); + // let is_reachable = guard.is_reachable(); + // guard.reset(); + // is_reachable + x.borrow().is_reachable() + }); + // (|x| x.borrow().is_reachable()); let after_len = self.memory.len(); @@ -308,8 +432,11 @@ impl Heap { // put them back as unreachable self.memory.iter().for_each(|x| x.borrow_mut().reset()); + self.vectors.iter().for_each(|x| x.borrow_mut().reset()); ROOTS.with(|x| x.borrow_mut().increment_generation()); + + log::debug!(target: "gc", "Sweep: Time taken: {:?}", now.elapsed()); } } @@ -371,6 +498,19 @@ pub struct HeapAllocated { pub(crate) value: T, } +// Adding generation information should be doable here +// struct Test { +// pub(crate) reachable: bool, +// pub(crate) generation: u32, +// pub(crate) value: SteelVal, +// } + +#[test] +fn check_size_of_heap_allocated_value() { + println!("{:?}", std::mem::size_of::>()); + // println!("{:?}", std::mem::size_of::()); +} + impl HeapAllocated { pub fn new(value: T) -> Self { Self { @@ -393,7 +533,8 @@ impl HeapAllocated { } pub struct MarkAndSweepContext<'a> { - queue: &'a mut VecDeque, + // queue: &'a mut VecDeque, + queue: &'a mut Vec, } impl<'a> MarkAndSweepContext<'a> { @@ -431,11 +572,31 @@ impl<'a> BreadthFirstSearchSteelValVisitor for MarkAndSweepContext<'a> { fn default_output(&mut self) -> Self::Output {} fn pop_front(&mut self) -> Option { - self.queue.pop_front() + // self.queue.pop_front() + self.queue.pop() } fn push_back(&mut self, value: SteelVal) { - self.queue.push_back(value); + match &value { + SteelVal::BoolV(_) + | SteelVal::NumV(_) + | SteelVal::IntV(_) + | SteelVal::CharV(_) + | SteelVal::Void + | SteelVal::StringV(_) + | SteelVal::FuncV(_) + | SteelVal::SymbolV(_) + | SteelVal::FutureFunc(_) + | SteelVal::FutureV(_) + | SteelVal::BoxedFunction(_) + | SteelVal::MutFunc(_) + | SteelVal::BuiltIn(_) + | SteelVal::BigNum(_) => return, + _ => { + // self.queue.push_back(value); + self.queue.push(value); + } + } } fn visit_closure(&mut self, closure: Gc) -> Self::Output { diff --git a/crates/steel-core/src/values/port.rs b/crates/steel-core/src/values/port.rs index e93560d1e..8740a1dec 100644 --- a/crates/steel-core/src/values/port.rs +++ b/crates/steel-core/src/values/port.rs @@ -10,7 +10,9 @@ use std::process::ChildStdout; // use utils::chars::Chars; // use utils::{new_rc_ref_cell, RcRefCell}; +use crate::rerrs; use crate::rvals::Result; +use crate::SteelErr; // use crate::rvals::{new_rc_ref_cell, RcRefSteelVal}; @@ -165,6 +167,18 @@ impl SteelPort { } } + // TODO: Implement the rest of the flush methods + pub fn flush(&self) -> Result<()> { + match self { + SteelPort::FileOutput(_, s) => Ok(s.borrow_mut().flush()?), + SteelPort::StdOutput(s) => Ok(s.borrow_mut().flush()?), + SteelPort::ChildStdInput(s) => Ok(s.borrow_mut().flush()?), + SteelPort::StringOutput(s) => Ok(s.borrow_mut().flush()?), + SteelPort::Closed => Ok(()), + _ => stop!(TypeMismatch => "expected an output port, found: {:?}", self), + } + } + pub fn read_all_str(&self) -> Result<(usize, String)> { match self { SteelPort::FileInput(_, br) => port_read_str_fn!(br, read_to_string), @@ -236,10 +250,33 @@ impl SteelPort { // } // } + pub fn write_char(&self, c: char) -> Result<()> { + macro_rules! write_string( + ($br: ident) => {{ + let br = &mut *$br.borrow_mut(); + write!(br, "{}", c)?; + br.flush()?; + }}; + ); + + match self { + SteelPort::FileOutput(_, br) => write_string!(br), + SteelPort::StringOutput(br) => write_string!(br), + SteelPort::StdOutput(out) => { + let mut br = out.borrow_mut().lock(); + write!(br, "{}", c)?; + br.flush()?; + } + _x => stop!(Generic => "write-car"), + }; + + Ok(()) + } + // // Write functions // - pub fn write_string(&mut self, string: &str) -> Result<()> { + pub fn write_string(&self, string: &str) -> Result<()> { macro_rules! write_string( ($br: ident) => {{ let br = &mut *$br.borrow_mut(); @@ -250,7 +287,12 @@ impl SteelPort { match self { SteelPort::FileOutput(_, br) => write_string!(br), - SteelPort::StdOutput(br) => write_string!(br), + SteelPort::StdOutput(out) => { + let mut br = out.borrow_mut().lock(); + write!(br, "{}", string)?; + br.flush()?; + } + SteelPort::StringOutput(br) => write_string!(br), _x => stop!(Generic => "write-string"), }; @@ -270,6 +312,7 @@ impl SteelPort { SteelPort::FileOutput(_, br) => write_string!(br), SteelPort::StdOutput(br) => write_string!(br), SteelPort::ChildStdInput(br) => write_string!(br), + SteelPort::StringOutput(br) => write_string!(br), _x => stop!(Generic => "write-string"), }; @@ -310,16 +353,22 @@ impl SteelPort { } pub fn default_current_output_port() -> Self { - SteelPort::StdOutput(new_rc_ref_cell(io::stdout())) + if cfg!(test) { + SteelPort::new_output_port() + } else { + SteelPort::StdOutput(new_rc_ref_cell(io::stdout())) + } } -} -// pub fn default_current_input_port() -> SteelPort { -// // TODO: current_input should be changable -// SteelPort::StdInput(new_rc_ref_cell(io::stdin())) -// } + pub fn get_output_string(&self) -> Result { + if let SteelPort::StringOutput(s) = self { + // Ensure that this is flushed + s.borrow_mut().flush()?; -// pub fn default_current_output_port() -> SteelPort { -// // TODO: current_output should be changable -// SteelPort::StdOutput(new_rc_ref_cell(io::stdout())) -// } + String::from_utf8(s.borrow().get_ref().to_vec()) + .map_err(|err| SteelErr::new(rerrs::ErrorKind::Generic, err.to_string())) + } else { + stop!(TypeMismatch => "get-output-string expects an output port, found: {:?}", self); + } + } +} diff --git a/crates/steel-core/src/values/structs.rs b/crates/steel-core/src/values/structs.rs index 6141610a0..a2bcecc4f 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, SteelHashMap}; +use crate::rvals::{Custom, SerializableSteelVal, SteelHashMap}; use crate::steel_vm::register_fn::RegisterFn; use crate::throw; use crate::{ @@ -86,6 +86,12 @@ impl StructTypeDescriptor { } } +pub struct SerializableUserDefinedStruct { + pub(crate) fields: Vec, + + pub(crate) type_descriptor: StructTypeDescriptor, +} + #[derive(Clone, Debug, Hash)] pub struct UserDefinedStruct { // pub(crate) name: InternedString, diff --git a/crates/steel-derive/src/lib.rs b/crates/steel-derive/src/lib.rs index cc9c79bc3..64362f5a1 100644 --- a/crates/steel-derive/src/lib.rs +++ b/crates/steel-derive/src/lib.rs @@ -285,7 +285,7 @@ pub fn function( match last.ident.into_token_stream().to_string().as_str() { "Result" => quote! { res }, _ => quote! { - res.into_steelval() + res.into_steelval().map_err(err_thunk) }, } } else { @@ -295,7 +295,7 @@ pub fn function( } } else { quote! { - res.into_steelval() + res.into_steelval().map_err(err_thunk) } } } @@ -348,7 +348,7 @@ pub fn function( let arg_enumerate = type_vec.into_iter().enumerate(); let arg_type = arg_enumerate.clone().map(|(_, x)| x); let arg_index = arg_enumerate.clone().map(|(i, _)| i); - let function_names_with_colon = std::iter::repeat(function_name_with_colon); + // let function_names_with_colon = std::iter::repeat(function_name_with_colon.clone()); let function_name = sign.ident.clone(); let _arity_name = Ident::new( &(function_name.to_string().to_uppercase() + "_ARITY"), @@ -429,16 +429,19 @@ pub fn function( crate::stop!(ArityMismatch => format!("{} expected {} arguments, got {}", #value, #arity_number.to_string(), args.len())) } + fn err_thunk(mut err: crate::rerrs::SteelErr) -> crate::rerrs::SteelErr { + err.prepend_message(#function_name_with_colon); + err.set_kind(crate::rerrs::ErrorKind::TypeMismatch); + err + }; + let res = #function_name( #( // TODO: Distinguish reference types here if possible - make a special implementation // for builtin pointer types here to distinguish them <#arg_type>::#conversion_functions(&args[#arg_index]) - .map_err(|mut err| { - err.prepend_message(#function_names_with_colon); - err.set_kind(crate::rerrs::ErrorKind::TypeMismatch); - err - } )?, + .map_err(err_thunk) + ?, )* ); @@ -468,16 +471,19 @@ pub fn function( crate::stop!(ArityMismatch => format!("{} expected {} arguments, got {}", #value, #arity_number.to_string(), args.len())) } + + fn err_thunk(mut err: crate::rerrs::SteelErr) -> crate::rerrs::SteelErr { + err.prepend_message(#function_name_with_colon); + err.set_kind(crate::rerrs::ErrorKind::TypeMismatch); + err + }; + let res = #function_name( #( // TODO: Distinguish reference types here if possible - make a special implementation // for builtin pointer types here to distinguish them <#arg_type>::#conversion_functions(&args[#arg_index]) - .map_err(|mut err| { - err.prepend_message(#function_names_with_colon); - err.set_kind(crate::rerrs::ErrorKind::TypeMismatch); - err - } )?, + .map_err(err_thunk)?, )* ); diff --git a/crates/steel-parser/src/lexer.rs b/crates/steel-parser/src/lexer.rs index 6f9c50c49..9965f4b57 100644 --- a/crates/steel-parser/src/lexer.rs +++ b/crates/steel-parser/src/lexer.rs @@ -60,6 +60,12 @@ impl<'a, T, F: ToOwnedString> Iterator for OwnedTokenStream<'a, T, F> { } } +impl<'a, T, F: ToOwnedString> OwnedTokenStream<'a, T, F> { + pub fn offset(&self) -> usize { + self.stream.lexer.span().end + } +} + impl<'a> Iterator for TokenStream<'a> { type Item = Token<'a, &'a str>; diff --git a/crates/steel-parser/src/tokens.rs b/crates/steel-parser/src/tokens.rs index 1315b646b..1f2475128 100644 --- a/crates/steel-parser/src/tokens.rs +++ b/crates/steel-parser/src/tokens.rs @@ -58,9 +58,9 @@ pub fn decode_hex(s: &str) -> Result, DecodeHexError> { } fn parse_unicode_str(slice: &str) -> Option { - if slice.starts_with("#\\\\u") && slice.contains('{') && slice.contains('}') { + if slice.starts_with("#\\u") && slice.contains('{') && slice.contains('}') { let rest = slice - .trim_start_matches("#\\\\u") + .trim_start_matches("#\\u") .trim_start_matches('{') .trim_end_matches('}') .to_lowercase(); @@ -78,6 +78,24 @@ fn parse_unicode_str(slice: &str) -> Option { let result = char::try_from(uinitial).ok(); // println!("{result:?}"); + result + } else if slice.starts_with("#\\u") { + let rest = slice.trim_start_matches("#\\u").to_lowercase(); + + let rest = match rest.len() { + 1 => "000".to_string() + &rest, + 2 => "00".to_string() + &rest, + 3 => "0".to_string() + &rest, + 4 => rest, + _ => return None, + }; + + let decoded: u8 = decode_hex(&rest).ok()?.into_iter().sum(); + + let uinitial: u32 = decoded.into(); + + let result = char::try_from(uinitial).ok(); + result } else { None @@ -361,16 +379,6 @@ impl<'a> TokenType<&'a str> { } } -// impl<'a, T: From<&'a str>> From> for TokenType { -// fn from(value: TokenType<&'a str>) -> Self { -// match &value { -// TokenType::Identifier(i) => TokenType::Identifier(i.into()), -// TokenType::Keyword(i) => TokenType::Identifier(i.into()), -// _ => value, -// } -// } -// } - fn character_special_display(c: char, f: &mut fmt::Formatter) -> fmt::Result { match c { ' ' => write!(f, "#\\SPACE"), @@ -427,41 +435,6 @@ impl fmt::Display for TokenType { } } -// impl fmt::Display for TokenType { -// fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { -// match self { -// OpenParen => write!(f, "("), -// CloseParen => write!(f, "("), -// CharacterLiteral(x) => character_special_display(*x, f), -// BooleanLiteral(x) => write!(f, "#{x}"), -// Identifier(x) => write!(f, "{x}"), -// NumberLiteral(x) => write!(f, "{x:?}"), -// IntegerLiteral(x) => write!(f, "{x}"), -// StringLiteral(x) => write!(f, "\"{x}\""), -// Keyword(x) => write!(f, "{x}"), -// QuoteTick => write!(f, "'"), -// Unquote => write!(f, ","), -// QuasiQuote => write!(f, "`"), -// UnquoteSplice => write!(f, ",@"), -// Error => write!(f, "error"), -// Comment => write!(f, ""), -// If => write!(f, "if"), -// Define => write!(f, "define"), -// Let => write!(f, "let"), -// TestLet => write!(f, "test-let"), -// Return => write!(f, "return!"), -// Begin => write!(f, "begin"), -// Lambda => write!(f, "lambda"), -// Quote => write!(f, "quote"), -// DefineSyntax => write!(f, "define-syntax"), -// SyntaxRules => write!(f, "syntax-rules"), -// Ellipses => write!(f, "..."), -// Set => write!(f, "set!"), -// Require => write!(f, "require"), -// } -// } -// } - #[derive(Debug, Clone, PartialEq)] pub struct Token<'a, T> { pub ty: TokenType, diff --git a/r7rs-benchmarks/ack.scm b/r7rs-benchmarks/ack.scm new file mode 100644 index 000000000..037f3a87d --- /dev/null +++ b/r7rs-benchmarks/ack.scm @@ -0,0 +1,44 @@ +(define values list) +(define (call-with-values producer consumer) + (define result (apply consumer (producer))) + (if (= (length result) 1) (car result) result)) + +(define (hide r x) + (call-with-values (lambda () (values (vector values (lambda (x) x)) (if (< r 100) 0 1))) + (lambda (v i) ((vector-ref v i) x)))) + +(define (ack m n) + (cond + [(= m 0) (+ n 1)] + [(= n 0) (ack (- m 1) 1)] + [else (ack (- m 1) (ack m (- n 1)))])) + +; 2 +; 3 +; 12 +; 32765 + +(define count 2) + +(let loop ([i 0]) + ; (when (< i 1000000) + (when (< i count) + (begin + (equal? (ack (hide count 3) (hide count 12)) 32765) + + (loop (+ i 1))))) + +; (define (run-benchmark) +; (let* ((count (read)) +; (input1 (read)) +; (input2 (read)) +; (output (read)) +; (s3 (number->string count)) +; (s2 (number->string input2)) +; (s1 (number->string input1)) +; (name "ack")) +; (run-r7rs-benchmark +; (string-append name ":" s1 ":" s2 ":" s3) +; count +; (lambda () (ack (hide count input1) (hide count input2))) +; (lambda (result) (= result output))))) diff --git a/r7rs-benchmarks/array1.scm b/r7rs-benchmarks/array1.scm new file mode 100644 index 000000000..2919f366e --- /dev/null +++ b/r7rs-benchmarks/array1.scm @@ -0,0 +1,64 @@ +(define-syntax do + (syntax-rules () + [(do ((var init step ...) ...) (test expr ...) command ...) + (letrec* ([loop + (lambda (var ...) + (if test + (begin + expr ...) + (begin + command ... + (loop (do "step" var step ...) ...))))]) + (loop init ...))] + [(do "step" x) x] + [(do "step" x y) y])) + +(define vector->list mutable-vector->list) +(define vector-ref mut-vector-ref) +(define vector-length mut-vec-len) +; (define (make-vector n) +; (apply mutable-vector (map (lambda (x) 0) (range 0 n)))) + +(define values list) +(define (call-with-values producer consumer) + (define result (apply consumer (producer))) + (if (= (length result) 1) (car result) result)) + +(define (hide r x) + (call-with-values (lambda () (values (vector values (lambda (x) x)) (if (< r 100) 0 1))) + (lambda (v i) ((vector-ref v i) x)))) + +(define (create-x n) + (define result (make-vector n)) + (do ((i 0 (+ i 1))) ((>= i n) result) (vector-set! result i i))) + +(define (create-y x) + (let* ([n (vector-length x)] [result (make-vector n)]) + (do ((i (- n 1) (- i 1))) ((< i 0) result) (vector-set! result i (vector-ref x i))))) + +(define (my-try n) + (vector-length (create-y (create-x n)))) + +(define (go m n) + (let loop ([repeat m] [result '()]) + (if (> repeat 0) (loop (- repeat 1) (my-try n)) result))) + +; (displayln (go 50 1000000)) + +(displayln (go 1 1000)) + +; 500 +; 1000000 +; 1000000 + +; (define (run-benchmark) +; (let* ([count (read)] +; [input1 (read)] +; [output (read)] +; [s2 (number->string count)] +; [s1 (number->string input1)] +; [name "array1"]) +; (run-r7rs-benchmark (string-append name ":" s1 ":" s2) +; 1 +; (lambda () (go (hide count count) (hide count input1))) +; (lambda (result) (equal? result output))))) diff --git a/r7rs-benchmarks/common.scm b/r7rs-benchmarks/common.scm new file mode 100644 index 000000000..03d44be0d --- /dev/null +++ b/r7rs-benchmarks/common.scm @@ -0,0 +1,86 @@ +;;; The following code is appended to all benchmarks. + +; (define current-second current-seconds) +; (define (jiffies-per-second) +; 1000) +; (define (current-jiffy) +; (llong->flonum (current-nanoseconds))) + +(require-builtin steel/time) + +(define values list) +(define (call-with-values producer consumer) + (define result (apply consumer (producer))) + (if (= (length result) 1) (car result) result)) + +(define (this-scheme-implementation-name) + "steel") + +(define (current-jiffy) + (current-milliseconds)) + +(define (jiffies-per-second) + 1000) + +(define (current-second) + (* 0.001 (current-inexact-milliseconds))) + +(define inexact exact->inexact) + +;;; Given an integer and an object, returns the object +;;; without making it too easy for compilers to tell +;;; the object will be returned. + +(define (hide r x) + (call-with-values (lambda () (values (vector values (lambda (x) x)) (if (< r 100) 0 1))) + (lambda (v i) ((vector-ref v i) x)))) + +;;; Given the name of a benchmark, +;;; the number of times it should be executed, +;;; a thunk that runs the benchmark once, +;;; and a unary predicate that is true of the +;;; correct results the thunk may return, +;;; runs the benchmark for the number of specified iterations. + +(define (run-r7rs-benchmark name count thunk ok?) + + ;; Rounds to thousandths. + (define (rounded x) + (/ (round (* 1000 x)) 1000)) + + (display "Running ") + (display name) + (newline) + (flush-output-port (current-output-port)) + (let* ([j/s (jiffies-per-second)] [t0 (current-second)] [j0 (current-jiffy)]) + (let loop ([i 0] [result #f]) + (cond + [(< i count) (loop (+ i 1) (thunk))] + [(ok? result) + (let* ([j1 (current-jiffy)] + [t1 (current-second)] + [jifs (- j1 j0)] + [secs (inexact (/ jifs j/s))] + [secs2 (rounded (- t1 t0))]) + (display "Elapsed time: ") + (write secs) + (display " seconds (") + (write secs2) + (display ") for ") + (display name) + (newline) + (display "+!CSVLINE!+") + (display (this-scheme-implementation-name)) + (display ",") + (display name) + (display ",") + (display secs) + (newline) + (flush-output-port (current-output-port))) + 0] + [else + (display "ERROR: returned incorrect result: ") + (write result) + (newline) + (flush-output-port (current-output-port)) + 0])))) diff --git a/r7rs-benchmarks/equal.scm b/r7rs-benchmarks/equal.scm new file mode 100644 index 000000000..dbb6b9366 --- /dev/null +++ b/r7rs-benchmarks/equal.scm @@ -0,0 +1,239 @@ +(define (hide r x) + (call-with-values (lambda () (values (vector values (lambda (x) x)) (if (< r 100) 0 1))) + (lambda (v i) ((vector-ref v i) x)))) + +(define vector->list mutable-vector->list) +(define list-tail drop) + +;; Returns a list with n elements, all equal to x. +(define (make-test-list1 n x) + (if (zero? n) '() (cons x (make-test-list1 (- n 1) x)))) + +;; Returns a list of n lists, each consisting of n x's. +;; The n elements of the outer list are actually the same list. + +(define (make-test-tree1 n) + (if (zero? n) '() (make-test-list1 n (make-test-tree1 (- n 1))))) + +;; Returns a list of n elements, as returned by the thunk. + +(define (make-test-list2 n thunk) + ; (displayln "CALLING make-test-list2" n) + (if (zero? n) '() (cons (thunk) (make-test-list2 (- n 1) thunk)))) + +;; Returns a balanced tree of height n, with the branching factor +;; at each level equal to the height of the tree at that level. +;; The subtrees do not share structure. + +(define (make-test-tree2 n) + ; (displayln "CALLING make-test-tree2" n) + (if (zero? n) '() (make-test-list2 n (lambda () (make-test-tree2 (- n 1)))))) + +;; Returns an extremely unbalanced tree of height n. + +(define (make-test-tree5 n) + (if (zero? n) '() (cons (make-test-tree5 (- n 1)) 'a))) + +;; Calls the thunk n times. + +(define (iterate n thunk) + ; (displayln n) + (cond + [(= n 1) (thunk)] + [(> n 1) + (thunk) + (iterate (- n 1) thunk)] + [else #f])) + +;; A simple circular list is a worst case for R5RS equal?. + +; (define (equality-benchmark0 n) +; (let ([x (vector->list (make-vector n 'a))]) +; (set-cdr! (list-tail x (- n 1)) x) +; (iterate n (hide n (lambda () (equal? x (cdr x))))))) + +;; DAG with much sharing. +;; 10 is a good parameter for n. + +(define (equality-benchmark1 n) + (let ([x (make-test-tree1 n)] [y (make-test-tree1 n)]) + (iterate n (hide n (lambda () (equal? x y)))))) + +;; Tree with no sharing. +;; 8 is a good parameter for n. + +(define (equality-benchmark2 n) + (let ([x (make-test-tree2 n)] [y (make-test-tree2 n)]) + ; (displayln y) + + (iterate n (hide n (lambda () (equal? x y)))))) + +;; Flat vectors. +;; 1000 might be a good parameter for n. + +(define (equality-benchmark3 n) + (let* ([x (make-vector n 'a)] [y (make-vector n 'a)]) + (iterate n (hide n (lambda () (equal? x y)))))) + +;; Shallow lists. +;; 300 might be a good parameter for n. + +(define (equality-benchmark4 n) + (let* ([x (vector->list (make-vector n (make-test-tree2 3)))] + [y (vector->list (make-vector n (make-test-tree2 3)))]) + (iterate n (hide n (lambda () (equal? x y)))))) + +;; No sharing, no proper lists, +;; and deep following car chains instead of cdr. + +(define (equality-benchmark5 n . rest) + (let* ([x (make-test-tree5 n)] [y (make-test-tree5 n)] [iterations (if (null? rest) n (car rest))]) + (iterate iterations (hide n (lambda () (equal? x y)))))) + +;; A shorter form of the benchmark above. + +(define (equality-benchmark5short n) + (equality-benchmark5 n 100)) + +(define (equality-benchmarks n0 n1 n2 n3 n4 n5) + (and ; (equality-benchmark0 n0) ;; cyclic benchmark does not work on most non-R7RS schemes + (equality-benchmark1 n1) + (equality-benchmark2 n2) + (equality-benchmark3 n3) + (equality-benchmark4 n4) + (equality-benchmark5 n5))) + +; 100 +; 100 +; 8 +; 1000 +; 2000 +; 5000 +; #t + +;; Actual test +; (equality-benchmarks 100 100 8 1000 2000 5000) + +;; For test suite + +; (equality-benchmarks 10 10 3 100 200 500) + +(define (run-benchmark) + (let* ([input0 (read)] + [input1 (read)] + [input2 (read)] + [input3 (read)] + [input4 (read)] + [input5 (read)] + [output (read)] + [s5 (number->string input5)] + [s4 (number->string input4)] + [s3 (number->string input3)] + [s2 (number->string input2)] + [s1 (number->string input1)] + [s0 (number->string input0)] + [name "equal"]) + (run-r7rs-benchmark (string-append name ":" s0 ":" s1 ":" s2 ":" s3 ":" s4 ":" s5) + 1 + (lambda () + (equality-benchmarks (hide input0 input0) + (hide input0 input1) + (hide input0 input2) + (hide input0 input3) + (hide input0 input4) + (hide input0 input5))) + (lambda (result) (eq? result #t))))) + +(require-builtin steel/time) + +; (define values list) +; (define (call-with-values producer consumer) +; (define result (apply consumer (producer))) +; (if (= (length result) 1) (car result) result)) + +(define (this-scheme-implementation-name) + "steel") + +(define (current-jiffy) + (current-milliseconds)) + +(define (jiffies-per-second) + 1000) + +(define (current-second) + (* 0.001 (current-inexact-milliseconds))) + +(define inexact exact->inexact) + +;;; Given an integer and an object, returns the object +;;; without making it too easy for compilers to tell +;;; the object will be returned. + +(define (hide r x) + (call-with-values (lambda () (values (vector values (lambda (x) x)) (if (< r 100) 0 1))) + (lambda (v i) ((vector-ref v i) x)))) + +;;; Given the name of a benchmark, +;;; the number of times it should be executed, +;;; a thunk that runs the benchmark once, +;;; and a unary predicate that is true of the +;;; correct results the thunk may return, +;;; runs the benchmark for the number of specified iterations. + +(define (run-r7rs-benchmark name count thunk ok?) + + ;; Rounds to thousandths. + (define (rounded x) + (/ (round (* 1000 x)) 1000)) + + (display "Running ") + (display name) + (newline) + (flush-output-port (current-output-port)) + (let* ([j/s (jiffies-per-second)] [t0 (current-second)] [j0 (current-jiffy)]) + (let loop ([i 0] [result #f]) + (cond + [(< i count) (loop (+ i 1) (thunk))] + [(ok? result) + (let* ([j1 (current-jiffy)] + [t1 (current-second)] + [jifs (- j1 j0)] + [secs (inexact (/ jifs j/s))] + [secs2 (rounded (- t1 t0))]) + (display "Elapsed time: ") + ; (write secs) + (display secs) + (display " seconds (") + ; (write secs2) + (display secs2) + (display ") for ") + (display name) + (newline) + (display "+!CSVLINE!+") + (display (this-scheme-implementation-name)) + (display ",") + (display name) + (display ",") + (display secs) + (newline) + (flush-output-port (current-output-port))) + 0] + [else + (display "ERROR: returned incorrect result: ") + (write result) + (newline) + (flush-output-port (current-output-port)) + 0])))) + +;; Run the bench! +(parameterize ([current-input-port (open-input-file "r7rs-benchmarks/inputs/equal.input")]) + + ; (displayln (read)) + ; (displayln (read)) + ; (displayln (read)) + ; (displayln (read)) + ; (displayln (read)) + + ; (read) + + (run-benchmark)) diff --git a/r7rs-benchmarks/inputs/equal.input b/r7rs-benchmarks/inputs/equal.input new file mode 100644 index 000000000..c893d4853 --- /dev/null +++ b/r7rs-benchmarks/inputs/equal.input @@ -0,0 +1,7 @@ +100 +100 +8 +1000 +2000 +5000 +#t diff --git a/r7rs-benchmarks/scheme.scm b/r7rs-benchmarks/scheme.scm new file mode 100644 index 000000000..6dc4c141e --- /dev/null +++ b/r7rs-benchmarks/scheme.scm @@ -0,0 +1,1135 @@ +;;; SCHEME -- A Scheme interpreter evaluating a sort, written by Marc Feeley. + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +; (import (scheme base) +; (scheme cxr) +; (scheme inexact) +; (scheme char) +; (scheme file) +; (scheme read) +; (scheme write) +; (scheme time)) + +; (require "steel/mutable-vectors") + +(define member + (lambda (x los) + ; (displayln "Calling member") + (cond + [(null? los) #f] + ; (begin + ; (displayln los) + [(equal? x (car los)) los] + [else (member x (cdr los))]))) + +;; Compatibility ----------------------------------------------------------- +(define assq assoc) +(define assv assoc) +(define memq member) +(define memv member) +(define eq? equal?) + +; (define vector-set! mutable-vector-set!) +(define vector-ref mut-vector-ref) +(define vector mutable-vector) +(define (make-vector n) + (apply mutable-vector (map (lambda (x) 0) (range 0 n)))) + +;; -------------------------------------------------------------------------- + +(define (scheme-eval expr) + (let ([code (scheme-comp expr scheme-global-environment)]) (code #f))) + +(define scheme-global-environment + (cons '() ;; environment chain + '())) ;; macros + +; (define (scheme-add-macro name proc) +; (set-cdr! scheme-global-environment (cons (cons name proc) (cdr scheme-global-environment))) +; name) + +(define (scheme-add-macro name proc) + (set! scheme-global-environment + (cons (car scheme-global-environment) + (cons (cons name proc) (cdr scheme-global-environment))))) + +(define (scheme-error msg . args) + (error #f msg args)) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (lst->vector l) + (let* ([n (length l)] [v (make-vector n)]) + (let loop ([l l] [i 0]) + (if (pair? l) + (begin + (vector-set! v i (car l)) + (loop (cdr l) (+ i 1))) + v)))) + +(define (vector->lst v) + (let loop ([l '()] [i (- (vector-length v) 1)]) + (if (< i 0) l (loop (cons (vector-ref v i) l) (- i 1))))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define scheme-syntactic-keywords + '(quote quasiquote + unquote + unquote-splicing + lambda + if + set! + cond + => + else + and + or + case + let + let* + letrec + begin + do + define + define-macro)) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (push-frame frame env) + (if (null? frame) env (cons (cons (car env) frame) (cdr env)))) + +(define (lookup-var name env) + (let loop1 ([chain (car env)] [up 0]) + (if (null? chain) + name + (let loop2 ([chain chain] [up up] [frame (cdr chain)] [over 1]) + (cond + [(null? frame) (loop1 (car chain) (+ up 1))] + [(eq? (car frame) name) (cons up over)] + [else (loop2 chain up (cdr frame) (+ over 1))]))))) + +(define (macro? name env) + (assq name (cdr env))) + +(define (push-macro name proc env) + (cons (car env) (cons (cons name proc) (cdr env)))) + +(define (lookup-macro name env) + (cdr (assq name (cdr env)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (variable x) + (unless (symbol? x) + (scheme-error "Identifier expected" x)) + (when (memq x scheme-syntactic-keywords) + (scheme-error "Variable name can not be a syntactic keyword" x))) + +(define (shape form n) + (let loop ([form form] [n n] [l form]) + (cond + [(<= n 0)] + [(pair? l) (loop form (- n 1) (cdr l))] + [else (scheme-error "Ill-constructed form" form)]))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (macro-expand expr env) + (apply (lookup-macro (car expr) env) (cdr expr))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-var expr env) + (variable expr) + (gen-var-ref (lookup-var expr env))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-self-eval expr env) + (gen-cst expr)) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quote expr env) + (shape expr 2) + (gen-cst (cadr expr))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quasiquote expr env) + (comp-quasiquotation (cadr expr) 1 env)) + +(define (comp-quasiquotation form level env) + (cond + [(= level 0) (scheme-comp form env)] + [(pair? form) + (cond + [(eq? (car form) 'quasiquote) (comp-quasiquotation-list form (+ level 1) env)] + [(eq? (car form) 'unquote) + (if (= level 1) + (scheme-comp (cadr form) env) + (comp-quasiquotation-list form (- level 1) env))] + [(eq? (car form) 'unquote-splicing) + (when (= level 1) + (scheme-error "Ill-placed 'unquote-splicing'" form)) + (comp-quasiquotation-list form (- level 1) env)] + [else (comp-quasiquotation-list form level env)])] + [(vector? form) (gen-vector-form (comp-quasiquotation-list (vector->lst form) level env))] + [else (gen-cst form)])) + +(define (comp-quasiquotation-list l level env) + (if (pair? l) + (let ([first (car l)]) + (if (= level 1) + (if (unquote-splicing? first) + (begin + (shape first 2) + (gen-append-form (scheme-comp (cadr first) env) + (comp-quasiquotation (cdr l) 1 env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env)))) + (comp-quasiquotation l level env))) + +(define (unquote-splicing? x) + (if (pair? x) (if (eq? (car x) 'unquote-splicing) #t #f) #f)) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote expr env) + (scheme-error "Ill-placed 'unquote'" expr)) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote-splicing expr env) + (scheme-error "Ill-placed 'unquote-splicing'" expr)) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-set! expr env) + (shape expr 3) + (variable (cadr expr)) + (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-lambda expr env) + (shape expr 3) + (let ([parms (cadr expr)]) + (let ([frame (parms->frame parms)]) + (let ([nb-vars (length frame)] [code (comp-body (cddr expr) (push-frame frame env))]) + (if (rest-param? parms) (gen-lambda-rest nb-vars code) (gen-lambda nb-vars code)))))) + +(define (parms->frame parms) + (cond + [(null? parms) '()] + [(pair? parms) + (let ([x (car parms)]) + (variable x) + (cons x (parms->frame (cdr parms))))] + [else + (variable parms) + (list parms)])) + +(define (rest-param? parms) + (cond + [(pair? parms) (rest-param? (cdr parms))] + [(null? parms) #f] + [else #t])) + +(define (comp-body body env) + + (define (letrec-defines vars vals body env) + (if (pair? body) + + (let ([expr (car body)]) + (cond + [(not (pair? expr)) (letrec-defines* vars vals body env)] + [(macro? (car expr) env) + (letrec-defines vars vals (cons (macro-expand expr env) (cdr body)) env)] + [else + (cond + [(eq? (car expr) 'begin) (letrec-defines vars vals (append (cdr expr) (cdr body)) env)] + [(eq? (car expr) 'define) + (let ([x (definition-name expr)]) + (variable x) + (letrec-defines (cons x vars) (cons (definition-value expr) vals) (cdr body) env))] + [(eq? (car expr) 'define-macro) + (let ([x (definition-name expr)]) + (letrec-defines vars + vals + (cdr body) + (push-macro x (scheme-eval (definition-value expr)) env)))] + [else (letrec-defines* vars vals body env)])])) + + (scheme-error "Body must contain at least one evaluable expression"))) + + (define (letrec-defines* vars vals body env) + (if (null? vars) (comp-sequence body env) (comp-letrec-aux vars vals body env))) + + (letrec-defines '() '() body env)) + +(define (definition-name expr) + (shape expr 3) + (let ([pattern (cadr expr)]) + (let ([name (if (pair? pattern) (car pattern) pattern)]) + (unless (symbol? name) + (scheme-error "Identifier expected" name)) + name))) + +(define (definition-value expr) + (let ([pattern (cadr expr)]) + (if (pair? pattern) (cons 'lambda (cons (cdr pattern) (cddr expr))) (caddr expr)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-if expr env) + (shape expr 3) + (let ([code1 (scheme-comp (cadr expr) env)] [code2 (scheme-comp (caddr expr) env)]) + (if (pair? (cdddr expr)) + (gen-if code1 code2 (scheme-comp (cadddr expr) env)) + (gen-when code1 code2)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-cond expr env) + (comp-cond-aux (cdr expr) env)) + +(define (comp-cond-aux clauses env) + (if (pair? clauses) + (let ([clause (car clauses)]) + (shape clause 1) + (cond + [(eq? (car clause) 'else) + (shape clause 2) + (comp-sequence (cdr clause) env)] + [(not (pair? (cdr clause))) + (gen-or (scheme-comp (car clause) env) (comp-cond-aux (cdr clauses) env))] + [(eq? (cadr clause) '=>) + (shape clause 3) + (gen-cond-send (scheme-comp (car clause) env) + (scheme-comp (caddr clause) env) + (comp-cond-aux (cdr clauses) env))] + [else + (gen-if (scheme-comp (car clause) env) + (comp-sequence (cdr clause) env) + (comp-cond-aux (cdr clauses) env))])) + (gen-cst '()))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-and expr env) + (let ([rest (cdr expr)]) (if (pair? rest) (comp-and-aux rest env) (gen-cst #t)))) + +(define (comp-and-aux l env) + (let ([code (scheme-comp (car l) env)] [rest (cdr l)]) + (if (pair? rest) (gen-and code (comp-and-aux rest env)) code))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-or expr env) + (let ([rest (cdr expr)]) (if (pair? rest) (comp-or-aux rest env) (gen-cst #f)))) + +(define (comp-or-aux l env) + (let ([code (scheme-comp (car l) env)] [rest (cdr l)]) + (if (pair? rest) (gen-or code (comp-or-aux rest env)) code))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-case expr env) + (shape expr 3) + (gen-case (scheme-comp (cadr expr) env) (comp-case-aux (cddr expr) env))) + +(define (comp-case-aux clauses env) + (if (pair? clauses) + (let ([clause (car clauses)]) + (shape clause 2) + (if (eq? (car clause) 'else) + (gen-case-else (comp-sequence (cdr clause) env)) + (gen-case-clause (car clause) + (comp-sequence (cdr clause) env) + (comp-case-aux (cdr clauses) env)))) + (gen-case-else (gen-cst '())))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let expr env) + (shape expr 3) + (let ([x (cadr expr)]) + (cond + [(symbol? x) + (shape expr 4) + (let ([y (caddr expr)]) + (let ([proc (cons 'lambda (cons (bindings->vars y) (cdddr expr)))]) + (scheme-comp (cons (list 'letrec (list (list x proc)) x) (bindings->vals y)) env)))] + [(pair? x) + (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr))) (bindings->vals x)) + env)] + [else (comp-body (cddr expr) env)]))) + +(define (bindings->vars bindings) + (if (pair? bindings) + (let ([binding (car bindings)]) + (shape binding 2) + (let ([x (car binding)]) + (variable x) + (cons x (bindings->vars (cdr bindings))))) + '())) + +(define (bindings->vals bindings) + (if (pair? bindings) + (let ([binding (car bindings)]) (cons (cadr binding) (bindings->vals (cdr bindings)))) + '())) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let* expr env) + (shape expr 3) + (let ([bindings (cadr expr)]) + (if (pair? bindings) + (scheme-comp (list 'let (list (car bindings)) (cons 'let* (cons (cdr bindings) (cddr expr)))) + env) + (comp-body (cddr expr) env)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-letrec expr env) + (shape expr 3) + (let ([bindings (cadr expr)]) + (comp-letrec-aux (bindings->vars bindings) (bindings->vals bindings) (cddr expr) env))) + +(define (comp-letrec-aux vars vals body env) + (if (pair? vars) + (let ([new-env (push-frame vars env)]) + (gen-letrec (comp-vals vals new-env) (comp-body body new-env))) + (comp-body body env))) + +(define (comp-vals l env) + (if (pair? l) (cons (scheme-comp (car l) env) (comp-vals (cdr l) env)) '())) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-begin expr env) + (shape expr 2) + (comp-sequence (cdr expr) env)) + +(define (comp-sequence exprs env) + (if (pair? exprs) (comp-sequence-aux exprs env) (gen-cst '()))) + +(define (comp-sequence-aux exprs env) + (let ([code (scheme-comp (car exprs) env)] [rest (cdr exprs)]) + (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-do expr env) + (shape expr 3) + (let ([bindings (cadr expr)] [exit (caddr expr)]) + (shape exit 1) + (let* ([vars (bindings->vars bindings)] + [new-env1 (push-frame '(#f) env)] + [new-env2 (push-frame vars new-env1)]) + (gen-letrec + (list (gen-lambda (length vars) + (gen-if (scheme-comp (car exit) new-env2) + (comp-sequence (cdr exit) new-env2) + (gen-sequence (comp-sequence (cdddr expr) new-env2) + (gen-combination (gen-var-ref '(1 . 1)) + (comp-vals (bindings->steps bindings) + new-env2)))))) + (gen-combination (gen-var-ref '(0 . 1)) (comp-vals (bindings->vals bindings) new-env1)))))) + +(define (bindings->steps bindings) + (if (pair? bindings) + (let ([binding (car bindings)]) + (cons (if (pair? (cddr binding)) (caddr binding) (car binding)) + (bindings->steps (cdr bindings)))) + '())) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define expr env) + (shape expr 3) + (let ([pattern (cadr expr)]) + (let ([x (if (pair? pattern) (car pattern) pattern)]) + (variable x) + (gen-sequence (gen-var-set (lookup-var x env) + (scheme-comp (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)) + env)) + (gen-cst x))))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define-macro expr env) + (let ([x (definition-name expr)]) (gen-macro x (scheme-eval (definition-value expr))))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-combination expr env) + (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env))) + +;;------------------------------------------------------------------------------ + +(define (gen-var-ref var) + ;; vv changed to cadr + (if (pair? var) (gen-rte-ref (car var) (cadr var)) (gen-glo-ref (scheme-global-var var)))) + +(define (gen-rte-ref up over) + (case up + [(0) (gen-slot-ref-0 over)] + [(1) (gen-slot-ref-1 over)] + [else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))])) + +(define (gen-slot-ref-0 i) + (case i + [(0) (lambda (rte) (vector-ref rte 0))] + [(1) (lambda (rte) (vector-ref rte 1))] + [(2) (lambda (rte) (vector-ref rte 2))] + [(3) (lambda (rte) (vector-ref rte 3))] + [else (lambda (rte) (vector-ref rte i))])) + +(define (gen-slot-ref-1 i) + (case i + [(0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))] + [(1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))] + [(2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))] + [(3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))] + [else (lambda (rte) (vector-ref (vector-ref rte 0) i))])) + +(define (gen-slot-ref-up-2 code) + (lambda (rte) (code (vector-ref (vector-ref rte 0) 0)))) + +(define (gen-glo-ref i) + (lambda (rte) (scheme-global-var-ref i))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cst val) + (case val + [(()) (lambda (rte) '())] + [(#f) (lambda (rte) #f)] + [(#t) (lambda (rte) #t)] + [(-2) (lambda (rte) -2)] + [(-1) (lambda (rte) -1)] + [(0) (lambda (rte) 0)] + [(1) (lambda (rte) 1)] + [(2) (lambda (rte) 2)] + [else (lambda (rte) val)])) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-append-form code1 code2) + (lambda (rte) (append (code1 rte) (code2 rte)))) + +(define (gen-cons-form code1 code2) + (lambda (rte) (cons (code1 rte) (code2 rte)))) + +(define (gen-vector-form code) + (lambda (rte) (lst->vector (code rte)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-var-set var code) + (if (pair? var) (gen-rte-set (car var) (cdr var) code) (gen-glo-set (scheme-global-var var) code))) + +(define (gen-rte-set up over code) + (case up + [(0) (gen-slot-set-0 over code)] + [(1) (gen-slot-set-1 over code)] + [else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)])) + +(define (gen-slot-set-0 i code) + (case i + [(0) (lambda (rte) (vector-set! rte 0 (code rte)))] + [(1) (lambda (rte) (vector-set! rte 1 (code rte)))] + [(2) (lambda (rte) (vector-set! rte 2 (code rte)))] + [(3) (lambda (rte) (vector-set! rte 3 (code rte)))] + [else (lambda (rte) (vector-set! rte i (code rte)))])) + +(define (gen-slot-set-1 i code) + (case i + [(0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))] + [(1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))] + [(2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))] + [(3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))] + [else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))])) + +(define (gen-slot-set-n up i code) + (case i + [(0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))] + [(1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))] + [(2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))] + [(3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))] + [else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))])) + +(define (gen-glo-set i code) + (lambda (rte) (scheme-global-var-set! i (code rte)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-lambda-rest nb-vars body) + (case nb-vars + [(1) (gen-lambda-1-rest body)] + [(2) (gen-lambda-2-rest body)] + [(3) (gen-lambda-3-rest body)] + [else (gen-lambda-n-rest nb-vars body)])) + +(define (gen-lambda-1-rest body) + (lambda (rte) (lambda a (body (vector rte a))))) + +(define (gen-lambda-2-rest body) + (lambda (rte) (lambda (a . b) (body (vector rte a b))))) + +(define (gen-lambda-3-rest body) + (lambda (rte) (lambda (a b . c) (body (vector rte a b c))))) + +(define (gen-lambda-n-rest nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ([x (make-vector (+ nb-vars 1))]) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ([n nb-vars] [x x] [i 4] [l d]) + (if (< i n) + (begin + (vector-set! x i (car l)) + (loop n x (+ i 1) (cdr l))) + (vector-set! x i l))) + (body x))))) + +(define (gen-lambda nb-vars body) + (case nb-vars + [(0) (gen-lambda-0 body)] + [(1) (gen-lambda-1 body)] + [(2) (gen-lambda-2 body)] + [(3) (gen-lambda-3 body)] + [else (gen-lambda-n nb-vars body)])) + +(define (gen-lambda-0 body) + (lambda (rte) (lambda () (body rte)))) + +(define (gen-lambda-1 body) + (lambda (rte) (lambda (a) (body (vector rte a))))) + +(define (gen-lambda-2 body) + (lambda (rte) (lambda (a b) (body (vector rte a b))))) + +(define (gen-lambda-3 body) + (lambda (rte) (lambda (a b c) (body (vector rte a b c))))) + +(define (gen-lambda-n nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ([x (make-vector (+ nb-vars 1))]) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ([n nb-vars] [x x] [i 4] [l d]) + (when (<= i n) + (vector-set! x i (car l)) + (loop n x (+ i 1) (cdr l)))) + (body x))))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-sequence code1 code2) + (lambda (rte) + (code1 rte) + (code2 rte))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-when code1 code2) + (lambda (rte) (if (code1 rte) (code2 rte) '()))) + +(define (gen-if code1 code2 code3) + (lambda (rte) (if (code1 rte) (code2 rte) (code3 rte)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cond-send code1 code2 code3) + (lambda (rte) (let ([temp (code1 rte)]) (if temp ((code2 rte) temp) (code3 rte))))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-and code1 code2) + (lambda (rte) (let ([temp (code1 rte)]) (if temp (code2 rte) temp)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-or code1 code2) + (lambda (rte) (let ([temp (code1 rte)]) (if temp temp (code2 rte))))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-case code1 code2) + (lambda (rte) (code2 rte (code1 rte)))) + +(define (gen-case-clause datums code1 code2) + (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key)))) + +(define (gen-case-else code) + (lambda (rte key) (code rte))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-letrec vals body) + (let ([nb-vals (length vals)]) + (case nb-vals + [(1) (gen-letrec-1 (car vals) body)] + [(2) (gen-letrec-2 (car vals) (cadr vals) body)] + [(3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)] + [else (gen-letrec-n nb-vals vals body)]))) + +(define (gen-letrec-1 val1 body) + (lambda (rte) + (let ([x (vector rte #f)]) + (vector-set! x 1 (val1 x)) + (body x)))) + +(define (gen-letrec-2 val1 val2 body) + (lambda (rte) + (let ([x (vector rte #f #f)]) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (body x)))) + +(define (gen-letrec-3 val1 val2 val3 body) + (lambda (rte) + (let ([x (vector rte #f #f #f)]) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (vector-set! x 3 (val3 x)) + (body x)))) + +(define (gen-letrec-n nb-vals vals body) + (lambda (rte) + (let ([x (make-vector (+ nb-vals 1))]) + (vector-set! x 0 rte) + (let loop ([x x] [i 1] [l vals]) + (when (pair? l) + (vector-set! x i ((car l) x)) + (loop x (+ i 1) (cdr l)))) + (body x)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-macro name proc) + (lambda (rte) (scheme-add-macro name proc))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-combination oper args) + (case (length args) + [(0) (gen-combination-0 oper)] + [(1) (gen-combination-1 oper (car args))] + [(2) (gen-combination-2 oper (car args) (cadr args))] + [(3) (gen-combination-3 oper (car args) (cadr args) (caddr args))] + [else (gen-combination-n oper args)])) + +(define (gen-combination-0 oper) + (lambda (rte) ((oper rte)))) + +(define (gen-combination-1 oper arg1) + (lambda (rte) ((oper rte) (arg1 rte)))) + +(define (gen-combination-2 oper arg1 arg2) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte)))) + +(define (gen-combination-3 oper arg1 arg2 arg3) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte)))) + +(define (gen-combination-n oper args) + (lambda (rte) + (define (evaluate l rte) + (if (pair? l) (cons ((car l) rte) (evaluate (cdr l) rte)) '())) + (apply (oper rte) (evaluate args rte)))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-comp expr env) + (cond + [(symbol? expr) (comp-var expr env)] + [(not (pair? expr)) (comp-self-eval expr env)] + [(macro? (car expr) env) (scheme-comp (macro-expand expr env) env)] + [else + (cond + [(eq? (car expr) 'quote) (comp-quote expr env)] + [(eq? (car expr) 'quasiquote) (comp-quasiquote expr env)] + [(eq? (car expr) 'unquote) (comp-unquote expr env)] + [(eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env)] + [(eq? (car expr) 'set!) (comp-set! expr env)] + [(eq? (car expr) 'lambda) (comp-lambda expr env)] + [(eq? (car expr) 'if) (comp-if expr env)] + [(eq? (car expr) 'cond) (comp-cond expr env)] + [(eq? (car expr) 'and) (comp-and expr env)] + [(eq? (car expr) 'or) (comp-or expr env)] + [(eq? (car expr) 'case) (comp-case expr env)] + [(eq? (car expr) 'let) (comp-let expr env)] + [(eq? (car expr) 'let*) (comp-let* expr env)] + [(eq? (car expr) 'letrec) (comp-letrec expr env)] + [(eq? (car expr) 'begin) (comp-begin expr env)] + [(eq? (car expr) 'do) (comp-do expr env)] + [(eq? (car expr) 'define) (comp-define expr env)] + [(eq? (car expr) 'define-macro) (comp-define-macro expr env)] + [else (comp-combination expr env)])])) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +;; Compatibility -- In order to use mutable pairs, this will +;; need to be adjusted slightly. + +(define scheme-global-variables '()) + +(struct MutablePair (first second) #:mutable) + +(define (scheme-global-var name) + (let ([x (assq name scheme-global-variables)]) + (if x + (list-ref x 1) + (let ([y (MutablePair name '())]) ;; cons -> MutablePair + (set! scheme-global-variables (cons (cons name y) scheme-global-variables)) + y)))) + +(define (scheme-global-var-ref i) + (MutablePair-second i)) + +(define (scheme-global-var-set! i val) + (set-MutablePair-second! i val) + '()) + +; (define scheme-global-variables '()) + +(define (def-proc name value) + (scheme-global-var-set! (scheme-global-var name) value)) + +(def-proc 'not (lambda (x) (not x))) +(def-proc 'boolean? boolean?) +(def-proc 'eqv? eqv?) +(def-proc 'eq? eq?) +(def-proc 'equal? equal?) +(def-proc 'pair? (lambda (obj) (pair? obj))) +(def-proc 'cons (lambda (x y) (cons x y))) +(def-proc 'car (lambda (x) (car x))) +(def-proc 'cdr (lambda (x) (cdr x))) + +;; Compatibility - getting removed +; (def-proc 'set-car! set-car!) +; (def-proc 'set-cdr! set-cdr!) + +(def-proc 'caar caar) +(def-proc 'cadr cadr) +(def-proc 'cdar cdar) +(def-proc 'cddr cddr) +(def-proc 'caaar caaar) +(def-proc 'caadr caadr) +(def-proc 'cadar cadar) +(def-proc 'caddr caddr) +(def-proc 'cdaar cdaar) +(def-proc 'cdadr cdadr) +(def-proc 'cddar cddar) +(def-proc 'cdddr cdddr) +(def-proc 'caaaar caaaar) +(def-proc 'caaadr caaadr) +(def-proc 'caadar caadar) +(def-proc 'caaddr caaddr) +(def-proc 'cadaar cadaar) +(def-proc 'cadadr cadadr) +(def-proc 'caddar caddar) +(def-proc 'cadddr cadddr) +(def-proc 'cdaaar cdaaar) +(def-proc 'cdaadr cdaadr) +(def-proc 'cdadar cdadar) +(def-proc 'cdaddr cdaddr) +(def-proc 'cddaar cddaar) +(def-proc 'cddadr cddadr) +(def-proc 'cdddar cdddar) +(def-proc 'cddddr cddddr) +(def-proc 'null? (lambda (x) (null? x))) +(def-proc 'list? list?) +(def-proc 'list list) +(def-proc 'length length) +(def-proc 'append append) +(def-proc 'reverse reverse) +(def-proc 'list-ref list-ref) +(def-proc 'memq memq) +(def-proc 'memv memv) +(def-proc 'member member) +(def-proc 'assq assq) +(def-proc 'assv assv) +(def-proc 'assoc assoc) +(def-proc 'symbol? symbol?) +(def-proc 'symbol->string symbol->string) +(def-proc 'string->symbol string->symbol) +(def-proc 'number? number?) + +; (def-proc 'complex? complex?) +; (def-proc 'real? real?) +; (def-proc 'rational? rational?) +(def-proc 'integer? integer?) +; (def-proc 'exact? exact?) +; (def-proc 'inexact? inexact?) + +;;(def-proc '= =) +;;(def-proc '< <) +;;(def-proc '> >) +;;(def-proc '<= <=) +;;(def-proc '>= >=) +;;(def-proc 'zero? zero?) +;;(def-proc 'positive? positive?) +;;(def-proc 'negative? negative?) +;;(def-proc 'odd? odd?) +;;(def-proc 'even? even?) +(def-proc 'max max) +(def-proc 'min min) +;;(def-proc '+ +) +;;(def-proc '* *) +;;(def-proc '- -) +(def-proc '/ /) +(def-proc 'abs abs) +;;(def-proc 'quotient quotient) +;;(def-proc 'remainder remainder) +;;(def-proc 'modulo modulo) +; (def-proc 'gcd gcd) +; (def-proc 'lcm lcm) +;;(def-proc 'numerator numerator) +;;(def-proc 'denominator denominator) +; (def-proc 'floor floor) +; (def-proc 'ceiling ceiling) +; (def-proc 'truncate truncate) +; (def-proc 'round round) +;;(def-proc 'rationalize rationalize) +; (def-proc 'exp exp) +; (def-proc 'log log) +; (def-proc 'sin sin) +; (def-proc 'cos cos) +; (def-proc 'tan tan) +; (def-proc 'asin asin) +; (def-proc 'acos acos) +; (def-proc 'atan atan) +; (def-proc 'sqrt sqrt) +; (def-proc 'expt expt) +;;(def-proc 'make-rectangular make-rectangular) +;;(def-proc 'make-polar make-polar) +;;(def-proc 'real-part real-part) +;;(def-proc 'imag-part imag-part) +;;(def-proc 'magnitude magnitude) +;;(def-proc 'angle angle) +; (def-proc 'exact->inexact inexact) +; (def-proc 'inexact->exact exact) +(def-proc 'number->string number->string) +(def-proc 'string->number string->number) +(def-proc 'char? char?) +; (def-proc 'char=? char=?) +; (def-proc 'char? char>?) +; (def-proc 'char<=? char<=?) +; (def-proc 'char>=? char>=?) +; (def-proc 'char-ci=? char-ci=?) +; (def-proc 'char-ci? char-ci>?) +; (def-proc 'char-ci<=? char-ci<=?) +; (def-proc 'char-ci>=? char-ci>=?) +; (def-proc 'char-alphabetic? char-alphabetic?) +; (def-proc 'char-numeric? char-numeric?) +; (def-proc 'char-whitespace? char-whitespace?) +; (def-proc 'char-lower-case? char-lower-case?) +; (def-proc 'char->integer char->integer) +; (def-proc 'integer->char integer->char) +; (def-proc 'char-upcase char-upcase) +; (def-proc 'char-downcase char-downcase) +(def-proc 'string? string?) +; (def-proc 'make-string make-string) +(def-proc 'string string) +(def-proc 'string-length string-length) +(def-proc 'string-ref string-ref) +; (def-proc 'string-set! string-set!) +(def-proc 'string=? string=?) +(def-proc 'string? string>?) +(def-proc 'string<=? string<=?) +(def-proc 'string>=? string>=?) +(def-proc 'string-ci=? string-ci=?) +(def-proc 'string-ci? string-ci>?) +(def-proc 'string-ci<=? string-ci<=?) +(def-proc 'string-ci>=? string-ci>=?) +(def-proc 'substring substring) +(def-proc 'string-append string-append) +(def-proc 'vector? vector?) +(def-proc 'make-vector make-vector) +(def-proc 'vector vector) +(def-proc 'vector-length vector-length) +(def-proc 'vector-ref vector-ref) +(def-proc 'vector-set! vector-set!) +(def-proc 'procedure? procedure?) +(def-proc 'apply apply) +(def-proc 'map map) +; (def-proc 'for-each for-each) +;;(def-proc 'call-with-current-continuation call-with-current-continuation) +; (def-proc 'call-with-input-file call-with-input-file) +; (def-proc 'call-with-output-file call-with-output-file) +; (def-proc 'input-port? input-port?) +; (def-proc 'output-port? output-port?) +; (def-proc 'current-input-port current-input-port) +; (def-proc 'current-output-port current-output-port) +; (def-proc 'open-input-file open-input-file) +; (def-proc 'open-output-file open-output-file) +; (def-proc 'close-input-port close-input-port) +; (def-proc 'close-output-port close-output-port) +; (def-proc 'eof-object? eof-object?) +; (def-proc 'read read) +; (def-proc 'read-char read-char) +; (def-proc 'peek-char peek-char) +; (def-proc 'write write) +(def-proc 'display display) +(def-proc 'newline newline) +; (def-proc 'write-char write-char) + +;; TODO: Make this work! +; (define (run-benchmark) +; (let* ([count (read)] +; [input1 (read)] +; [output (read)] +; [s2 (number->string count)] +; [s1 ""] +; [name "scheme"]) +; (run-r7rs-benchmark (string-append name ":" s2) +; count +; (lambda () (scheme-eval (hide count input1))) +; (lambda (result) (equal? result output))))) + +;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define program + '(let () + + (define (sort-list obj pred) + + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) (split l '() '()) l)) + + (define (split l one two) + (if (pair? l) (split (cdr l) two (cons (car l) one)) (merge (loop one) (loop two)))) + + (define (merge one two) + (cond + [(null? one) two] + [(pred (car two) (car one)) (cons (car two) (merge (cdr two) one))] + [else (cons (car one) (merge (cdr one) two))])) + + (loop obj)) + + (sort-list '("one" "two" + "three" + "four" + "five" + "six" + "seven" + "eight" + "nine" + "ten" + "eleven" + "twelve" + "thirteen" + "fourteen" + "fifteen" + "sixteen" + "seventeen" + "eighteen" + "nineteen" + "twenty" + "twentyone" + "twentytwo" + "twentythree" + "twentyfour" + "twentyfive" + "twentysix" + "twentyseven" + "twentyeight" + "twentynine" + "thirty") + string x 0)) + +(define (negative? x) + (< x 0)) + +(define-syntax do + (syntax-rules () + [(do ((var init step ...) ...) (test expr ...) command ...) + (letrec* ([loop + (lambda (var ...) + (if test + (begin + expr ...) + (begin + command ... + (loop (do "step" var step ...) ...))))]) + (loop init ...))] + [(do "step" x) x] + [(do "step" x y) y])) + +(define (matrix-rows a) + (vector-length a)) +(define (matrix-columns a) + (vector-length (vector-ref a 0))) +(define (matrix-ref a i j) + (vector-ref (vector-ref a i) j)) +(define (matrix-set! a i j x) + (vector-set! (vector-ref a i) j x)) + +(define (complain) + (error #f "This shouldn't happen")) + +(define (simplex a m1 m2 m3) + ;(define *epsilon* 1e-6) + (define *epsilon* 0.000001) + (unless (and (>= m1 0) (>= m2 0) (>= m3 0) (= (matrix-rows a) (+ m1 m2 m3 2))) + (complain)) + (let* ([m12 (+ m1 m2 1)] + [m (- (matrix-rows a) 2)] + [n (- (matrix-columns a) 1)] + ; [nl1 n] + [l1 (make-vector n)] + [l2 (make-vector m)] + [l3 (make-vector m2)] + [nl1 n] + [iposv (make-vector m)] + [izrov (make-vector n)] + [ip 0] + [kp 0] + [bmax 0.0] + [one? #f] + [pass2? #t]) + + (define (simp1 mm abs?) + (set! kp (vector-ref l1 0)) + (set! bmax (matrix-ref a mm kp)) + (do ((k 1 (+ k 1))) + ((>= k nl1)) + (begin + (when (positive? (if abs? + (- (abs (matrix-ref a mm (vector-ref l1 k))) (abs bmax)) + (- (matrix-ref a mm (vector-ref l1 k)) bmax))) + (begin + (set! kp (vector-ref l1 k)) + (set! bmax (matrix-ref a mm (vector-ref l1 k)))))))) + (define (simp2) + (set! ip 0) + (let ([q1 0.0] [flag? #f]) + (do ((i 0 (+ i 1))) + ((= i m)) + (if flag? + (when (< (matrix-ref a (vector-ref l2 i) kp) (- *epsilon*)) + (let ([q (/ (- (matrix-ref a (vector-ref l2 i) 0)) + (matrix-ref a (vector-ref l2 i) kp))]) + (cond + [(< q q1) + (set! ip (vector-ref l2 i)) + (set! q1 q)] + [(= q q1) + (let ([qp 0.0] [q0 0.0]) + (let loop ([k 1]) + (when (<= k n) + (begin + (set! qp (/ (- (matrix-ref a ip k)) (matrix-ref a ip kp))) + (set! q0 + (/ (- (matrix-ref a (vector-ref l2 i) k)) + (matrix-ref a (vector-ref l2 i) kp))) + (when (= q0 qp) + (loop (+ k 1)))))) + (when (< q0 qp) + (set! ip (vector-ref l2 i))))]))) + (when (< (matrix-ref a (vector-ref l2 i) kp) (- *epsilon*)) + (set! q1 + (/ (- (matrix-ref a (vector-ref l2 i) 0)) + (matrix-ref a (vector-ref l2 i) kp))) + (set! ip (vector-ref l2 i)) + (set! flag? #t)))))) + (define (simp3 one?) + (let ([piv (/ (matrix-ref a ip kp))]) + (do ((ii 0 (+ ii 1))) + ((= ii (+ m (if one? 2 1)))) + (unless (= ii ip) + (matrix-set! a ii kp (* piv (matrix-ref a ii kp))) + (do ((kk 0 (+ kk 1))) + ((= kk (+ n 1))) + (unless (= kk kp) + (matrix-set! a + ii + kk + (- (matrix-ref a ii kk) + (* (matrix-ref a ip kk) (matrix-ref a ii kp)))))))) + (do ((kk 0 (+ kk 1))) + ((= kk (+ n 1))) + (unless (= kk kp) + (matrix-set! a ip kk (* (- piv) (matrix-ref a ip kk))))) + (matrix-set! a ip kp piv))) + (do ((k 0 (+ k 1))) ((= k n)) (vector-set! l1 k (+ k 1)) (vector-set! izrov k k)) + (do ((i 0 (+ i 1))) + ((= i m)) + (when (negative? (matrix-ref a (+ i 1) 0)) + (complain)) + (vector-set! l2 i (+ i 1)) + (vector-set! iposv i (+ n i))) + (do ((i 0 (+ i 1))) ((= i m2)) (vector-set! l3 i #t)) + (when (positive? (+ m2 m3)) + (do ((k 0 (+ k 1))) + ((= k (+ n 1))) + (do ((i (+ m1 1) (+ i 1)) (sum 0.0 (+ sum (matrix-ref a i k)))) + ((> i m) (matrix-set! a (+ m 1) k (- sum))))) + (let loop () + (simp1 (+ m 1) #f) + (cond + [(<= bmax *epsilon*) + (cond + [(< (matrix-ref a (+ m 1) 0) (- *epsilon*)) (set! pass2? #f)] + [(<= (matrix-ref a (+ m 1) 0) *epsilon*) + (let loop ([ip1 m12]) + (if (<= ip1 m) + (cond + [(= (vector-ref iposv (- ip1 1)) (+ ip n -1)) + (simp1 ip1 #t) + (cond + [(positive? bmax) + (set! ip ip1) + (set! one? #t)] + [else (loop (+ ip1 1))])] + [else (loop (+ ip1 1))]) + (do ((i (+ m1 1) (+ i 1))) + ((>= i m12)) + (when (vector-ref l3 (- i (+ m1 1))) + (do ((k 0 (+ k 1))) + ((= k (+ n 1))) + (matrix-set! a i k (- (matrix-ref a i k))))))))] + [else + (simp2) + (if (zero? ip) (set! pass2? #f) (set! one? #t))])] + [else + (simp2) + (if (zero? ip) (set! pass2? #f) (set! one? #t))]) + (when one? + (set! one? #f) + (simp3 #t) + (cond + [(>= (vector-ref iposv (- ip 1)) (+ n m12 -1)) + (let loop ([k 0]) + (cond + [(and (< k nl1) (not (= kp (vector-ref l1 k)))) (loop (+ k 1))] + [else + (set! nl1 (- nl1 1)) + (do ((is k (+ is 1))) ((>= is nl1)) (vector-set! l1 is (vector-ref l1 (+ is 1)))) + (matrix-set! a (+ m 1) kp (+ (matrix-ref a (+ m 1) kp) 1.0)) + (do ((i 0 (+ i 1))) + ((= i (+ m 2))) + (matrix-set! a i kp (- (matrix-ref a i kp))))]))] + [(and (>= (vector-ref iposv (- ip 1)) (+ n m1)) + (vector-ref l3 (- (vector-ref iposv (- ip 1)) (+ m1 n)))) + (vector-set! l3 (- (vector-ref iposv (- ip 1)) (+ m1 n)) #f) + (matrix-set! a (+ m 1) kp (+ (matrix-ref a (+ m 1) kp) 1.0)) + (do ((i 0 (+ i 1))) ((= i (+ m 2))) (matrix-set! a i kp (- (matrix-ref a i kp))))]) + (let ([t (vector-ref izrov (- kp 1))]) + (vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1))) + (vector-set! iposv (- ip 1) t)) + (loop)))) + + (and pass2? + (let loop () + (simp1 0 #f) + (cond + [(positive? bmax) + (simp2) + (cond + [(zero? ip) #t] + [else + (simp3 #f) + (let ([t (vector-ref izrov (- kp 1))]) + (vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1))) + (vector-set! iposv (- ip 1) t)) + (loop)])] + [else (list iposv izrov)]))))) + +(define (test input) + (simplex (vector (vector 0.0 1.0 1.0 3.0 -0.5) + (vector 740.0 -1.0 0.0 -2.0 0.0) + (vector 0.0 0.0 -2.0 0.0 7.0) + (vector 0.5 0.0 -1.0 1.0 -2.0) + (vector 9.0 -1.0 -1.0 -1.0 -1.0) + (vector 0.0 0.0 0.0 0.0 0.0)) + 2 + 1 + 1)) + +(assert! (equal? (list (vector 4 1 3 2) (vector 0 5 7 6)) (test 740.0))) + +(let loop ([i 0]) + ; (when (< i 500000) + (when (< i 10000) + (begin + ; (displayln i) + (assert! (equal? (list (vector 4 1 3 2) (vector 0 5 7 6)) (test 740.0))) + + (loop (+ i 1))))) + +; 1000000 +; 740.0 +; (#(4 1 3 2) #(0 5 7 6)) + +; (define (run-benchmark) +; (let* ((count (read)) +; (input1 (read)) +; (output (read)) +; (s2 (number->string count)) +; (s1 "") +; (name "simplex")) +; (run-r7rs-benchmark +; (string-append name ":" s2) +; count +; (lambda () (test (hide count input1))) +; (lambda (result) (equal? result output))))) diff --git a/r7rs-benchmarks/triangl.scm b/r7rs-benchmarks/triangl.scm new file mode 100644 index 000000000..d17f1ee8c --- /dev/null +++ b/r7rs-benchmarks/triangl.scm @@ -0,0 +1,107 @@ +;;; TRIANGL -- Board game benchmark. + +; (import (scheme base) (scheme read) (scheme write) (scheme time)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; (require "steel/mutable-vectors") + +(define-syntax do + (syntax-rules () + [(do ((var init step ...) ...) (test expr ...) command ...) + (letrec* ([loop + (lambda (var ...) + (if test + (begin + expr ...) + (begin + command ... + (loop (do "step" var step ...) ...))))]) + (loop init ...))] + [(do "step" x) x] + [(do "step" x y) y])) + +(define (list->vector lst) + (apply mutable-vector lst)) + +; (define list->vector list->mutable-vector) +(define vector->list mutable-vector->list) +(define vector-ref mut-vector-ref) +; (define vector-set! mutable-vector-set!) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define *board* (list->vector '(1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1))) + +(define *sequence* (list->vector '(0 0 0 0 0 0 0 0 0 0 0 0 0 0))) + +; (displayln *sequence*) + +(define *a* + (list->vector + '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 6))) + +(define *b* + (list->vector '(2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))) + +(define *c* + (list->vector + '(4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))) + +(define *answer* '()) + +(define (attempt i depth) + (cond + [(= depth 14) + (set! *answer* (cons (cdr (vector->list *sequence*)) *answer*)) + #t] + [(and (= 1 (vector-ref *board* (vector-ref *a* i))) + (= 1 (vector-ref *board* (vector-ref *b* i))) + (= 0 (vector-ref *board* (vector-ref *c* i)))) + (vector-set! *board* (vector-ref *a* i) 0) + (vector-set! *board* (vector-ref *b* i) 0) + (vector-set! *board* (vector-ref *c* i) 1) + (vector-set! *sequence* depth i) + (do ((j 0 (+ j 1)) (depth (+ depth 1))) ((or (= j 36) (attempt j depth)) #f)) + (vector-set! *board* (vector-ref *a* i) 1) + (vector-set! *board* (vector-ref *b* i) 1) + (vector-set! *board* (vector-ref *c* i) 0) + #f] + [else #f])) + +(define (test i depth) + (set! *answer* '()) + (attempt i depth) + (car *answer*)) + +; 50 +; 22 +; 1 +; (22 34 31 15 7 1 20 17 25 6 5 13 32) + +; (displayln (test 22 1)) + +(let loop ([i 0]) + ; (when (< i 50) + (when (< i 1) + (begin + ; (displayln i) + ; (assert! (equal? (list (vector 4 1 3 2) (vector 0 5 7 6)) (test 740.0))) + (displayln (test 22 1)) + + (loop (+ i 1))))) + +; (define (run-benchmark) +; (let* ((count (read)) +; (input1 (read)) +; (input2 (read)) +; (output (read)) +; (s3 (number->string count)) +; (s2 (number->string input2)) +; (s1 (number->string input1)) +; (name "triangl")) +; (run-r7rs-benchmark +; (string-append name ":" s1 ":" s2 ":" s3) +; count +; (lambda () (test (hide count input1) (hide count input2))) +; (lambda (result) (equal? result output))))) diff --git a/src/lib.rs b/src/lib.rs index b630728ca..393afadb0 100644 --- a/src/lib.rs +++ b/src/lib.rs @@ -182,7 +182,7 @@ pub fn run(clap_args: Args) -> Result<(), Box> { }), .. } => { - let core_libraries = &[steel::stdlib::PRELUDE, steel::stdlib::DISPLAY]; + let core_libraries = &[steel::stdlib::PRELUDE]; for core in core_libraries { let res = vm.compile_and_run_raw_program(core); @@ -259,3 +259,23 @@ fn r7rs_test_suite() { run(args).unwrap() } + +#[test] +fn r7rs_benchmark_test_suite() { + let benches = &[ + "r7rs-benchmarks/scheme.scm", + "r7rs-benchmarks/simplex.scm", + "r7rs-benchmarks/array1.scm", + "r7rs-benchmarks/triangl.scm", + ]; + + for bench in benches { + let args = Args { + action: None, + default_file: Some(PathBuf::from(bench)), + arguments: vec![], + }; + + run(args).unwrap(); + } +}