diff options
Diffstat (limited to 'libguile/intrinsics.c')
-rw-r--r-- | libguile/intrinsics.c | 551 |
1 files changed, 551 insertions, 0 deletions
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c new file mode 100644 index 000000000..a619fda90 --- /dev/null +++ b/libguile/intrinsics.c @@ -0,0 +1,551 @@ +/* Copyright 2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include "alist.h" +#include "atomics-internal.h" +#include "boolean.h" +#include "cache-internal.h" +#include "extensions.h" +#include "fluids.h" +#include "frames.h" +#include "gc-inline.h" +#include "goops.h" +#include "gsubr.h" +#include "keywords.h" +#include "modules.h" +#include "numbers.h" +#include "symbols.h" +#include "threads.h" +#include "version.h" + +#include "intrinsics.h" + + +struct scm_vm_intrinsics scm_vm_intrinsics; + +SCM_DEFINE (scm_intrinsic_list, "intrinsic-list", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_intrinsic_list +{ + SCM list = SCM_EOL; + +#define ADD_INTRINSIC(type, id, name, ID) \ + if (name) \ + list = scm_acons (scm_from_latin1_symbol (name), \ + scm_from_int (SCM_VM_INTRINSIC_##ID), \ + list); + SCM_FOR_ALL_VM_INTRINSICS (ADD_INTRINSIC); +#undef ADD_INTRINSIC + + return list; +} +#undef FUNC_NAME + +static SCM +add_immediate (SCM a, uint8_t b) +{ + if (SCM_LIKELY (SCM_I_INUMP (a))) + { + scm_t_signed_bits sum = SCM_I_INUM (a) + b; + + if (SCM_LIKELY (SCM_POSFIXABLE (sum))) + return SCM_I_MAKINUM (sum); + } + + return scm_sum (a, scm_from_uint8 (b)); +} + +static SCM +sub_immediate (SCM a, uint8_t b) +{ + if (SCM_LIKELY (SCM_I_INUMP (a))) + { + scm_t_signed_bits diff = SCM_I_INUM (a) - b; + + if (SCM_LIKELY (SCM_NEGFIXABLE (diff))) + return SCM_I_MAKINUM (diff); + } + + return scm_difference (a, scm_from_uint8 (b)); +} + +static void +string_set_x (SCM str, size_t idx, uint32_t ch) +{ + str = scm_i_string_start_writing (str); + scm_i_string_set_x (str, idx, ch); + scm_i_string_stop_writing (); +} + +static SCM +string_to_number (SCM str) +{ + return scm_string_to_number (str, SCM_UNDEFINED /* radix = 10 */); +} + +static uint64_t +scm_to_uint64_truncate (SCM x) +{ + if (SCM_LIKELY (SCM_I_INUMP (x))) + return (uint64_t) SCM_I_INUM (x); + else + return scm_to_uint64 (scm_logand (x, scm_from_uint64 ((uint64_t) -1))); +} + +#if INDIRECT_INT64_INTRINSICS +static void +indirect_scm_to_int64 (int64_t *dst, SCM x) +{ + *dst = scm_to_int64 (x); +} +static void +indirect_scm_to_uint64 (uint64_t *dst, SCM x) +{ + *dst = scm_to_uint64 (x); +} +static void +indirect_scm_to_uint64_truncate (uint64_t *dst, SCM x) +{ + *dst = scm_to_uint64_truncate (x); +} +static SCM +indirect_scm_from_int64 (int64_t *src) +{ + return scm_from_int64 (*src); +} +static SCM +indirect_scm_from_uint64 (uint64_t *src) +{ + return scm_from_uint64 (*src); +} +#endif + +static SCM +logsub (SCM x, SCM y) +{ + if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) + { + scm_t_signed_bits a, b; + + a = SCM_I_INUM (x); + b = SCM_I_INUM (y); + + return SCM_I_MAKINUM (a & ~b); + } + + return scm_logand (x, scm_lognot (y)); +} + +static void +wind (scm_thread *thread, SCM winder, SCM unwinder) +{ + scm_dynstack_push_dynwind (&thread->dynstack, winder, unwinder); +} + +static void +unwind (scm_thread *thread) +{ + scm_dynstack_pop (&thread->dynstack); +} + +static void +push_fluid (scm_thread *thread, SCM fluid, SCM value) +{ + scm_dynstack_push_fluid (&thread->dynstack, fluid, value, + thread->dynamic_state); +} + +static void +pop_fluid (scm_thread *thread) +{ + scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state); +} + +static SCM +fluid_ref (scm_thread *thread, SCM fluid) +{ + struct scm_cache_entry *entry; + + /* If we find FLUID in the cache, then it is indeed a fluid. */ + entry = scm_cache_lookup (&thread->dynamic_state->cache, fluid); + if (SCM_LIKELY (scm_is_eq (SCM_PACK (entry->key), fluid) + && !SCM_UNBNDP (SCM_PACK (entry->value)))) + return SCM_PACK (entry->value); + + return scm_fluid_ref (fluid); +} + +static void +fluid_set_x (scm_thread *thread, SCM fluid, SCM value) +{ + struct scm_cache_entry *entry; + + /* If we find FLUID in the cache, then it is indeed a fluid. */ + entry = scm_cache_lookup (&thread->dynamic_state->cache, fluid); + if (SCM_LIKELY (scm_is_eq (SCM_PACK (entry->key), fluid))) + entry->value = SCM_UNPACK (value); + else + scm_fluid_set_x (fluid, value); +} + +static void +push_dynamic_state (scm_thread *thread, SCM state) +{ + scm_dynstack_push_dynamic_state (&thread->dynstack, state, + thread->dynamic_state); +} + +static void +pop_dynamic_state (scm_thread *thread) +{ + scm_dynstack_unwind_dynamic_state (&thread->dynstack, + thread->dynamic_state); +} + +static SCM +lsh (SCM a, uint64_t b) +{ + if (SCM_LIKELY (SCM_I_INUMP (a)) + && b < (uint64_t) (SCM_I_FIXNUM_BIT - 1) + && ((scm_t_bits) + (SCM_SRS (SCM_I_INUM (a), (SCM_I_FIXNUM_BIT-1 - b)) + 1) + <= 1)) + { + scm_t_signed_bits nn = SCM_I_INUM (a); + return SCM_I_MAKINUM (nn < 0 ? -(-nn << b) : (nn << b)); + } + else + return scm_ash (a, scm_from_uint64 (b)); +} + +static SCM +rsh (SCM a, uint64_t b) +{ + if (SCM_LIKELY (SCM_I_INUMP (a))) + { + if (b > (uint64_t) (SCM_I_FIXNUM_BIT - 1)) + b = SCM_I_FIXNUM_BIT - 1; + return SCM_I_MAKINUM (SCM_SRS (SCM_I_INUM (a), b)); + } + else + return scm_ash (a, scm_difference (SCM_INUM0, scm_from_uint64 (b))); +} + +#if INDIRECT_INT64_INTRINSICS +static SCM +indirect_lsh (SCM a, uint64_t *b) +{ + return lsh (a, *b); +} +static SCM +indirect_rsh (SCM a, uint64_t *b) +{ + return rsh (a, *b); +} +#endif + +static SCM +lsh_immediate (SCM a, uint8_t b) +{ + return lsh (a, b); +} + +static SCM +rsh_immediate (SCM a, uint8_t b) +{ + return rsh (a, b); +} + +static enum scm_compare +less_p (SCM a, SCM b) +{ + if (SCM_LIKELY (SCM_I_INUMP (a) && SCM_I_INUMP (b))) + { + scm_t_signed_bits a_bits = SCM_UNPACK (a); + scm_t_signed_bits b_bits = SCM_UNPACK (b); + return a_bits < b_bits ? SCM_F_COMPARE_LESS_THAN : SCM_F_COMPARE_NONE; + } + + if (scm_is_true (scm_nan_p (a)) || scm_is_true (scm_nan_p (b))) + return SCM_F_COMPARE_INVALID; + else if (scm_is_true (scm_less_p (a, b))) + return SCM_F_COMPARE_LESS_THAN; + else + return SCM_F_COMPARE_NONE; +} + +static int +numerically_equal_p (SCM a, SCM b) +{ + if (SCM_LIKELY (SCM_I_INUMP (a) && SCM_I_INUMP (b))) + return scm_is_eq (a, b); + + return scm_is_true (scm_num_eq_p (a, b)); +} + +static SCM +resolve_module (SCM name, uint8_t public_p) +{ + SCM mod; + + if (!scm_module_system_booted_p) + return SCM_BOOL_F; + + mod = scm_maybe_resolve_module (name); + if (scm_is_false (mod)) + scm_misc_error (NULL, "Module named ~s does not exist", + scm_list_1 (name)); + + if (public_p) + { + mod = scm_module_public_interface (mod); + + if (scm_is_false (mod)) + scm_misc_error (NULL, "Module named ~s has no public interface", + scm_list_1 (name)); + } + + return mod; +} + +static SCM +lookup (SCM module, SCM name) +{ + /* If MODULE was captured before modules were booted, use the root + module. Not so nice, but hey... */ + if (scm_is_false (module)) + module = scm_the_root_module (); + + return scm_module_variable (module, name); +} + +static void throw_ (SCM key, SCM args) SCM_NORETURN; +static void throw_with_value (SCM val, SCM key_subr_and_message) SCM_NORETURN; +static void throw_with_value_and_data (SCM val, SCM key_subr_and_message) SCM_NORETURN; + +static void +throw_ (SCM key, SCM args) +{ + scm_throw (key, args); + abort(); /* not reached */ +} + +static void +throw_with_value (SCM val, SCM key_subr_and_message) +{ + SCM key, subr, message, args, data; + + key = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 0); + subr = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 1); + message = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 2); + args = scm_list_1 (val); + data = SCM_BOOL_F; + + throw_ (key, scm_list_4 (subr, message, args, data)); +} + +static void +throw_with_value_and_data (SCM val, SCM key_subr_and_message) +{ + SCM key, subr, message, args, data; + + key = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 0); + subr = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 1); + message = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 2); + args = scm_list_1 (val); + data = args; + + throw_ (key, scm_list_4 (subr, message, args, data)); +} + +static void error_wrong_num_args (scm_thread *) SCM_NORETURN; +static void error_no_values (void) SCM_NORETURN; +static void error_not_enough_values (void) SCM_NORETURN; +static void error_wrong_number_of_values (uint32_t expected) SCM_NORETURN; + +static void +error_wrong_num_args (scm_thread *thread) +{ + SCM callee = SCM_FRAME_LOCAL (thread->vm.fp, 0); + scm_wrong_num_args (callee); +} + +static void +error_no_values (void) +{ + scm_misc_error (NULL, "Zero values returned to single-valued continuation", + SCM_EOL); +} + +static void +error_not_enough_values (void) +{ + scm_misc_error (NULL, "Too few values returned to continuation", SCM_EOL); +} + +static void +error_wrong_number_of_values (uint32_t expected) +{ + scm_misc_error (NULL, + "Wrong number of values returned to continuation (expected ~a)", + scm_list_1 (scm_from_uint32 (expected))); +} + +static SCM +allocate_words (scm_thread *thread, size_t n) +{ + return SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, n)); +} + +static SCM +current_module (scm_thread *thread) +{ + return scm_i_current_module (thread); +} + +static void +push_prompt (scm_thread *thread, uint8_t escape_only_p, + SCM tag, const union scm_vm_stack_element *sp, uint32_t *vra, + uint8_t *mra) +{ + struct scm_vm *vp = &thread->vm; + scm_t_dynstack_prompt_flags flags; + + flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; + scm_dynstack_push_prompt (&thread->dynstack, flags, tag, + vp->stack_top - vp->fp, vp->stack_top - sp, + vra, mra, thread->vm.registers); +} + +static SCM +atomic_ref_scm (SCM *loc) +{ + return scm_atomic_ref_scm (loc); +} + +static void +atomic_set_scm (SCM *loc, SCM val) +{ + scm_atomic_set_scm (loc, val); +} + +static SCM +atomic_swap_scm (SCM *loc, SCM val) +{ + return scm_atomic_swap_scm (loc, val); +} + +static SCM +atomic_compare_and_swap_scm (SCM *loc, SCM expected, SCM desired) +{ + scm_atomic_compare_and_swap_scm (loc, &expected, desired); + return expected; +} + +void +scm_bootstrap_intrinsics (void) +{ + scm_vm_intrinsics.add = scm_sum; + scm_vm_intrinsics.add_immediate = add_immediate; + scm_vm_intrinsics.sub = scm_difference; + scm_vm_intrinsics.sub_immediate = sub_immediate; + scm_vm_intrinsics.mul = scm_product; + scm_vm_intrinsics.div = scm_divide; + scm_vm_intrinsics.quo = scm_quotient; + scm_vm_intrinsics.rem = scm_remainder; + scm_vm_intrinsics.mod = scm_modulo; + scm_vm_intrinsics.logand = scm_logand; + scm_vm_intrinsics.logior = scm_logior; + scm_vm_intrinsics.logxor = scm_logxor; + scm_vm_intrinsics.string_set_x = string_set_x; + scm_vm_intrinsics.string_to_number = string_to_number; + scm_vm_intrinsics.string_to_symbol = scm_string_to_symbol; + scm_vm_intrinsics.symbol_to_keyword = scm_symbol_to_keyword; + scm_vm_intrinsics.class_of = scm_class_of; + scm_vm_intrinsics.scm_to_f64 = scm_to_double; +#if INDIRECT_INT64_INTRINSICS + scm_vm_intrinsics.scm_to_u64 = indirect_scm_to_uint64; + scm_vm_intrinsics.scm_to_u64_truncate = indirect_scm_to_uint64_truncate; + scm_vm_intrinsics.scm_to_s64 = indirect_scm_to_int64; + scm_vm_intrinsics.u64_to_scm = indirect_scm_from_uint64; + scm_vm_intrinsics.s64_to_scm = indirect_scm_from_int64; +#else + scm_vm_intrinsics.scm_to_u64 = scm_to_uint64; + scm_vm_intrinsics.scm_to_u64_truncate = scm_to_uint64_truncate; + scm_vm_intrinsics.scm_to_s64 = scm_to_int64; + scm_vm_intrinsics.u64_to_scm = scm_from_uint64; + scm_vm_intrinsics.s64_to_scm = scm_from_int64; +#endif + scm_vm_intrinsics.logsub = logsub; + scm_vm_intrinsics.wind = wind; + scm_vm_intrinsics.unwind = unwind; + scm_vm_intrinsics.push_fluid = push_fluid; + scm_vm_intrinsics.pop_fluid = pop_fluid; + scm_vm_intrinsics.fluid_ref = fluid_ref; + scm_vm_intrinsics.fluid_set_x = fluid_set_x; + scm_vm_intrinsics.push_dynamic_state = push_dynamic_state; + scm_vm_intrinsics.pop_dynamic_state = pop_dynamic_state; +#if INDIRECT_INT64_INTRINSICS + scm_vm_intrinsics.lsh = indirect_lsh; + scm_vm_intrinsics.rsh = indirect_rsh; +#else + scm_vm_intrinsics.lsh = lsh; + scm_vm_intrinsics.rsh = rsh; +#endif + scm_vm_intrinsics.lsh_immediate = lsh_immediate; + scm_vm_intrinsics.rsh_immediate = rsh_immediate; + scm_vm_intrinsics.heap_numbers_equal_p = scm_i_heap_numbers_equal_p; + scm_vm_intrinsics.less_p = less_p; + scm_vm_intrinsics.numerically_equal_p = numerically_equal_p; + scm_vm_intrinsics.resolve_module = resolve_module; + scm_vm_intrinsics.lookup = lookup; + scm_vm_intrinsics.define_x = scm_module_ensure_local_variable; + scm_vm_intrinsics.throw_ = throw_; + scm_vm_intrinsics.throw_with_value = throw_with_value; + scm_vm_intrinsics.throw_with_value_and_data = throw_with_value_and_data; + scm_vm_intrinsics.error_wrong_num_args = error_wrong_num_args; + scm_vm_intrinsics.error_no_values = error_no_values; + scm_vm_intrinsics.error_not_enough_values = error_not_enough_values; + scm_vm_intrinsics.error_wrong_number_of_values = error_wrong_number_of_values; + scm_vm_intrinsics.allocate_words = allocate_words; + scm_vm_intrinsics.current_module = current_module; + scm_vm_intrinsics.push_prompt = push_prompt; + scm_vm_intrinsics.atomic_ref_scm = atomic_ref_scm; + scm_vm_intrinsics.atomic_set_scm = atomic_set_scm; + scm_vm_intrinsics.atomic_swap_scm = atomic_swap_scm; + scm_vm_intrinsics.atomic_compare_and_swap_scm = atomic_compare_and_swap_scm; + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_intrinsics", + (scm_t_extension_init_func)scm_init_intrinsics, + NULL); +} + +void +scm_init_intrinsics (void) +{ +#ifndef SCM_MAGIC_SNARFER +#include "intrinsics.x" +#endif +} |