1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963 |
- /* Copyright 2001,2009-2015,2017-2020,2022
- 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 <alignof.h>
- #include <alloca.h>
- #include <errno.h>
- #include <math.h>
- #include <stdint.h>
- #include <stdio.h>
- #include <stdlib.h>
- #include <string.h>
- #include <unistd.h>
- #ifdef HAVE_SYS_MMAN_H
- #include <sys/mman.h>
- #endif
- #include "alist.h"
- #include "async.h"
- #include "atomic.h"
- #include "atomics-internal.h"
- #include "bdw-gc.h"
- #include "cache-internal.h"
- #include "continuations.h"
- #include "control.h"
- #include "dynwind.h"
- #include "eval.h"
- #include "extensions.h"
- #include "foreign.h"
- #include "frames.h"
- #include "gc-inline.h"
- #include "gsubr.h"
- #include "hooks.h"
- #include "instructions.h"
- #include "intrinsics.h"
- #include "jit.h"
- #include "keywords.h"
- #include "list.h"
- #include "loader.h"
- #include "modules.h"
- #include "numbers.h"
- #include "pairs.h"
- #include "ports.h"
- #include "procprop.h"
- #include "programs.h"
- #include "simpos.h"
- #include "smob.h"
- #include "stackchk.h"
- #include "symbols.h"
- #include "values.h"
- #include "vectors.h"
- #include "version.h"
- #include "vm-builtins.h"
- #include "vm.h"
- #include <gc/gc_mark.h>
- #if (defined __GNUC__)
- # define SCM_NOINLINE __attribute__ ((__noinline__))
- #else
- # define SCM_NOINLINE /* noinline */
- #endif
- static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
- /* Unfortunately we can't snarf these: snarfed things are only loaded up from
- (system vm vm), which might not be loaded before an error happens. */
- static SCM sym_keyword_argument_error;
- static SCM sym_regular;
- static SCM sym_debug;
- /* The page size. */
- static size_t page_size;
- /* The VM has a number of internal assertions that shouldn't normally be
- necessary, but might be if you think you found a bug in the VM. */
- /* #define VM_ENABLE_ASSERTIONS */
- static void vm_expand_stack (struct scm_vm *vp,
- union scm_vm_stack_element *new_sp) SCM_NOINLINE;
- /* RESTORE is for the case where we know we have done a PUSH of equal or
- greater stack size in the past. Otherwise PUSH is the thing, which
- may expand the stack. */
- enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE };
- static inline void
- vm_increase_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp,
- enum vm_increase_sp_kind kind)
- {
- if (kind == VM_SP_PUSH && new_sp < vp->stack_limit)
- vm_expand_stack (vp, new_sp);
- else
- vp->sp = new_sp;
- }
- static inline void
- vm_push_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp)
- {
- vm_increase_sp (vp, new_sp, VM_SP_PUSH);
- }
- static inline void
- vm_restore_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp)
- {
- vm_increase_sp (vp, new_sp, VM_SP_RESTORE);
- }
- /*
- * VM Continuation
- */
- void
- scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
- {
- scm_puts ("#<vm-continuation ", port);
- scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
- }
- int
- scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame)
- {
- struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont);
- frame->stack_holder = data;
- frame->fp_offset = data->fp_offset;
- frame->sp_offset = data->stack_size;
- frame->ip = data->vra;
- return 1;
- }
- /* Ideally we could avoid copying the C stack if the continuation root
- is inside VM code, and call/cc was invoked within that same call to
- vm_run. That's currently not implemented. */
- static SCM
- capture_stack (union scm_vm_stack_element *stack_top,
- union scm_vm_stack_element *fp,
- union scm_vm_stack_element *sp,
- uint32_t *vra,
- uint8_t *mra,
- scm_t_dynstack *dynstack, uint32_t flags)
- {
- struct scm_vm_cont *p;
- size_t stack_size;
- stack_size = stack_top - sp;
- /* Allocate the 'scm_vm_cont' struct and the stack at once. That way,
- keeping a pointer to 'p->stack_bottom' around won't retain it.
- See <https://bugs.gnu.org/59021>. */
- p = scm_gc_malloc (sizeof (*p) + stack_size * sizeof (*p->stack_bottom),
- "capture_vm_cont");
- p->stack_size = stack_size;
- p->stack_bottom = (void *) ((char *) p + sizeof (*p));
- p->vra = vra;
- p->mra = mra;
- p->fp_offset = stack_top - fp;
- memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom));
- p->dynstack = dynstack;
- p->flags = flags;
- return scm_cell (scm_tc7_vm_cont, (scm_t_bits) p);
- }
- SCM
- scm_i_capture_current_stack (void)
- {
- scm_thread *thread;
- struct scm_vm *vp;
- thread = SCM_I_CURRENT_THREAD;
- vp = &thread->vm;
- return capture_stack (vp->stack_top, vp->fp, vp->sp, vp->ip, NULL,
- scm_dynstack_capture_all (&thread->dynstack),
- 0);
- }
- #define FOR_EACH_HOOK(M) \
- M(apply) \
- M(return) \
- M(next) \
- M(abort)
- static void
- vm_hook_compute_enabled (scm_thread *thread, SCM hook, uint8_t *enabled)
- {
- if (thread->vm.trace_level <= 0
- || thread->vm.engine == SCM_VM_REGULAR_ENGINE
- || scm_is_false (hook)
- || scm_is_true (scm_hook_empty_p (hook)))
- *enabled = 0;
- else
- *enabled = 1;
- }
- static void
- vm_recompute_disable_mcode (scm_thread *thread)
- {
- #if ENABLE_JIT
- /* FIXME: Some of this logic works for ahead-of-time compilation
- too. */
- uint8_t was_disabled = thread->vm.disable_mcode;
- thread->vm.disable_mcode = 0;
- #define DISABLE_MCODE_IF_HOOK_ENABLED(h) \
- if (thread->vm.h##_hook_enabled) \
- thread->vm.disable_mcode = 1;
- FOR_EACH_HOOK (DISABLE_MCODE_IF_HOOK_ENABLED);
- #undef DISABLE_MCODE_IF_HOOK_ENABLED
- if (thread->vm.disable_mcode && !was_disabled)
- scm_jit_clear_mcode_return_addresses (thread);
- #endif
- }
- static int
- set_vm_trace_level (scm_thread *thread, int level)
- {
- int old_level;
- struct scm_vm *vp = &thread->vm;
- old_level = vp->trace_level;
- vp->trace_level = level;
- vp->disable_mcode = 0;
- #define RESET_LEVEL(h) \
- vm_hook_compute_enabled (thread, vp->h##_hook, &vp->h##_hook_enabled);
- FOR_EACH_HOOK (RESET_LEVEL);
- #undef RESET_LEVEL
- vm_recompute_disable_mcode (thread);
- return old_level;
- }
- /* Return the first integer greater than or equal to LEN such that
- LEN % ALIGN == 0. Return LEN if ALIGN is zero. */
- #define ROUND_UP(len, align) \
- ((align) ? (((len) - 1UL) | ((align) - 1UL)) + 1UL : (len))
- static void
- invoke_hook (scm_thread *thread, SCM hook)
- {
- struct scm_vm *vp = &thread->vm;
- struct scm_frame c_frame;
- scm_t_cell *frame;
- SCM scm_frame;
- int saved_trace_level;
- uint8_t saved_compare_result;
- if (scm_is_false (hook) || scm_is_null (SCM_HOOK_PROCEDURES (hook)))
- return;
- saved_trace_level = set_vm_trace_level (thread, 0);
- saved_compare_result = vp->compare_result;
- /* Allocate a frame object on the stack. This is more efficient than calling
- `scm_c_make_frame ()' to allocate on the heap, but it forces hooks to not
- capture frame objects.
- At the same time, procedures such as `frame-procedure' make sense only
- while the stack frame represented by the frame object is visible, so it
- seems reasonable to limit the lifetime of frame objects. */
- c_frame.stack_holder = vp;
- c_frame.fp_offset = vp->stack_top - vp->fp;
- c_frame.sp_offset = vp->stack_top - vp->sp;
- c_frame.ip = vp->ip;
- /* Arrange for FRAME to be 8-byte aligned, like any other cell. */
- frame = alloca (sizeof (*frame) + 8);
- frame = (scm_t_cell *) ROUND_UP ((uintptr_t) frame, 8UL);
- frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8));
- frame->word_1 = SCM_PACK_POINTER (&c_frame);
- scm_frame = SCM_PACK_POINTER (frame);
- scm_c_run_hookn (hook, &scm_frame, 1);
- vp->compare_result = saved_compare_result;
- set_vm_trace_level (thread, saved_trace_level);
- }
- #define DEFINE_INVOKE_HOOK(h) \
- static void \
- invoke_##h##_hook (scm_thread *thread) SCM_NOINLINE; \
- static void \
- invoke_##h##_hook (scm_thread *thread) \
- { \
- if (thread->vm.h##_hook_enabled) \
- return invoke_hook (thread, thread->vm.h##_hook); \
- }
- FOR_EACH_HOOK (DEFINE_INVOKE_HOOK)
- #undef DEFINE_INVOKE_HOOK
- /*
- * VM Error Handling
- */
- static void vm_error_bad_instruction (uint32_t inst) SCM_NORETURN SCM_NOINLINE;
- static void
- vm_error_bad_instruction (uint32_t inst)
- {
- fprintf (stderr, "VM: Bad instruction: %x\n", inst);
- abort ();
- }
- static SCM vm_boot_continuation;
- #define DECLARE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
- static SCM vm_builtin_##builtin; \
- static uint32_t *vm_builtin_##builtin##_code;
- FOR_EACH_VM_BUILTIN (DECLARE_BUILTIN)
- #undef DECLARE_BUILTIN
- static const uint32_t vm_boot_continuation_code[] = {
- SCM_PACK_OP_24 (halt, 0)
- };
- int
- scm_i_vm_is_boot_continuation_code (uint32_t *ip)
- {
- return ip == vm_boot_continuation_code;
- }
- SCM
- scm_vm_builtin_ref (unsigned idx)
- {
- switch (idx)
- {
- #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
- case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
- FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
- #undef INDEX_TO_NAME
- default: abort();
- }
- }
- SCM scm_sym_apply;
- static SCM scm_sym_values;
- static SCM scm_sym_abort_to_prompt;
- static SCM scm_sym_call_with_values;
- static SCM scm_sym_call_with_current_continuation;
- SCM
- scm_vm_builtin_name_to_index (SCM name)
- #define FUNC_NAME "builtin-name->index"
- {
- SCM_VALIDATE_SYMBOL (1, name);
- #define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
- if (scm_is_eq (name, scm_sym_##builtin)) \
- return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
- FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
- #undef NAME_TO_INDEX
- return SCM_BOOL_F;
- }
- #undef FUNC_NAME
- SCM
- scm_vm_builtin_index_to_name (SCM index)
- #define FUNC_NAME "builtin-index->name"
- {
- unsigned idx;
- SCM_VALIDATE_UINT_COPY (1, index, idx);
- switch (idx)
- {
- #define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
- case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
- FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
- #undef INDEX_TO_NAME
- default: return SCM_BOOL_F;
- }
- }
- #undef FUNC_NAME
- static void
- scm_init_vm_builtins (void)
- {
- scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
- scm_vm_builtin_name_to_index);
- scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
- scm_vm_builtin_index_to_name);
- }
- static uint32_t*
- instrumented_code (const uint32_t *code, size_t byte_size)
- {
- uint32_t *ret, *write;
- ret = scm_i_alloc_primitive_code_with_instrumentation (byte_size / 4, &write);
- memcpy (write, code, byte_size);
- return ret;
- }
- static void
- define_vm_builtins (void)
- {
- const uint32_t apply_code[] = {
- SCM_PACK_OP_24 (assert_nargs_ge, 3),
- SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
- SCM_PACK_OP_24 (expand_apply_argument, 0),
- SCM_PACK_OP_24 (tail_call, 0),
- };
- const uint32_t values_code[] = {
- SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
- SCM_PACK_OP_24 (return_values, 0)
- };
- const uint32_t abort_to_prompt_code[] = {
- SCM_PACK_OP_24 (assert_nargs_ge, 2),
- SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
- /* FIXME: Partial continuation should capture caller regs. */
- SCM_PACK_OP_24 (return_values, 0) /* vals from r0 */
- };
- const uint32_t call_with_values_code[] = {
- SCM_PACK_OP_24 (assert_nargs_ee, 3),
- SCM_PACK_OP_24 (alloc_frame, 8),
- SCM_PACK_OP_12_12 (mov, 0, 6),
- SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1),
- SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2),
- SCM_PACK_OP_12_12 (shuffle_down, 7, 1),
- SCM_PACK_OP_24 (tail_call, 0)
- };
- const uint32_t call_with_current_continuation_code[] = {
- SCM_PACK_OP_24 (assert_nargs_ee, 2),
- SCM_PACK_OP_12_12 (mov, 1, 0),
- SCM_PACK_OP_24 (capture_continuation, 0),
- SCM_PACK_OP_24 (tail_call, 0)
- };
- /* This one isn't exactly a builtin but we still handle it here. */
- const uint32_t handle_interrupt_code[] = {
- SCM_PACK_OP_24 (alloc_frame, 4),
- SCM_PACK_OP_12_12 (mov, 0, 3),
- SCM_PACK_OP_24 (call, 3), SCM_PACK_OP_ARG_8_24 (0, 1),
- SCM_PACK_OP_24 (return_from_interrupt, 0)
- };
- #define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
- { \
- size_t sz = sizeof (builtin##_code); \
- vm_builtin_##builtin##_code = instrumented_code (builtin##_code, sz); \
- vm_builtin_##builtin = \
- scm_cell (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE, \
- (scm_t_bits)vm_builtin_##builtin##_code); \
- }
- FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
- #undef INDEX_TO_NAME
- scm_vm_intrinsics.handle_interrupt_code =
- instrumented_code (handle_interrupt_code, sizeof (handle_interrupt_code));
- }
- SCM
- scm_i_call_with_current_continuation (SCM proc)
- {
- return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
- }
- /*
- * VM
- */
- #define VM_NAME vm_regular_engine
- #define VM_USE_HOOKS 0
- #define FUNC_NAME "vm-regular-engine"
- #include "vm-engine.c"
- #undef FUNC_NAME
- #undef VM_USE_HOOKS
- #undef VM_NAME
- #define VM_NAME vm_debug_engine
- #define VM_USE_HOOKS 1
- #define FUNC_NAME "vm-debug-engine"
- #include "vm-engine.c"
- #undef FUNC_NAME
- #undef VM_USE_HOOKS
- #undef VM_NAME
- typedef SCM (*scm_t_vm_engine) (scm_thread *current_thread);
- static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] =
- { vm_regular_engine, vm_debug_engine };
- static union scm_vm_stack_element*
- allocate_stack (size_t size)
- {
- void *ret;
- if (size >= ((size_t) -1) / sizeof (union scm_vm_stack_element))
- abort ();
- size *= sizeof (union scm_vm_stack_element);
- #if HAVE_SYS_MMAN_H
- ret = mmap (NULL, size, PROT_READ | PROT_WRITE,
- MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
- if (ret == NULL)
- /* Shouldn't happen. */
- abort ();
- if (ret == MAP_FAILED)
- ret = NULL;
- #else
- ret = malloc (size);
- #endif
- if (!ret)
- perror ("allocate_stack failed");
- return (union scm_vm_stack_element *) ret;
- }
- static void
- free_stack (union scm_vm_stack_element *stack, size_t size)
- {
- size *= sizeof (*stack);
- #if HAVE_SYS_MMAN_H
- munmap (stack, size);
- #else
- free (stack);
- #endif
- }
- /* Ideally what we would like is an mremap or a realloc that grows at
- the bottom, not the top. Oh well; mmap and memcpy are fast enough,
- considering that they run very infrequently. */
- static union scm_vm_stack_element*
- expand_stack (union scm_vm_stack_element *old_bottom, size_t old_size,
- size_t new_size)
- #define FUNC_NAME "expand_stack"
- {
- union scm_vm_stack_element *new_bottom;
- size_t extension_size;
- if (new_size >= ((size_t) -1) / sizeof (union scm_vm_stack_element))
- abort ();
- if (new_size <= old_size)
- abort ();
- extension_size = new_size - old_size;
- if ((size_t)old_bottom < extension_size * sizeof (union scm_vm_stack_element))
- abort ();
- new_bottom = allocate_stack (new_size);
- if (!new_bottom)
- return NULL;
- memcpy (new_bottom + extension_size,
- old_bottom,
- old_size * sizeof (union scm_vm_stack_element));
- free_stack (old_bottom, old_size);
- return new_bottom;
- }
- #undef FUNC_NAME
- void
- scm_i_vm_prepare_stack (struct scm_vm *vp)
- {
- /* Not racey, as this will be run the first time a thread enters
- Guile. */
- if (page_size == 0)
- {
- page_size = getpagesize ();
- /* page_size should be a power of two. */
- if (page_size & (page_size - 1))
- abort ();
- }
- vp->stack_size = page_size / sizeof (union scm_vm_stack_element);
- vp->stack_bottom = allocate_stack (vp->stack_size);
- if (!vp->stack_bottom)
- /* As in expand_stack, we don't have any way to throw an exception
- if we can't allocate one measely page -- there's no stack to
- handle it. For now, abort. */
- abort ();
- vp->stack_top = vp->stack_bottom + vp->stack_size;
- vp->stack_limit = vp->stack_bottom;
- vp->overflow_handler_stack = SCM_EOL;
- vp->ip = NULL;
- vp->sp = vp->stack_top;
- vp->fp = vp->stack_top;
- vp->compare_result = SCM_F_COMPARE_NONE;
- vp->engine = vm_default_engine;
- vp->trace_level = 0;
- #define INIT_HOOK(h) vp->h##_hook = SCM_BOOL_F;
- FOR_EACH_HOOK (INIT_HOOK)
- #undef INIT_HOOK
- }
- static void
- return_unused_stack_to_os (struct scm_vm *vp)
- {
- #if HAVE_SYS_MMAN_H
- uintptr_t lo = (uintptr_t) vp->stack_bottom;
- uintptr_t hi = (uintptr_t) vp->sp;
- lo &= ~(page_size - 1U); /* round down */
- hi &= ~(page_size - 1U); /* round down */
- /* Return these pages to the OS. The next time they are paged in,
- they will be zeroed. */
- if (lo < hi)
- {
- int ret = 0;
- do
- ret = madvise ((void *) lo, hi - lo, MADV_DONTNEED);
- while (ret && errno == EAGAIN);
- /* If the OS doesn't implement 'madvise' (as is currently the case
- for GNU/Hurd), don't warn the user since there's nothing they
- can do about it. */
- if (ret && errno != ENOSYS)
- perror ("madvise failed");
- }
- #endif
- }
- #define SLOT_MAP_CACHE_SIZE 32U
- struct slot_map_cache_entry
- {
- uint32_t *ip;
- const uint8_t *map;
- };
- struct slot_map_cache
- {
- struct slot_map_cache_entry entries[SLOT_MAP_CACHE_SIZE];
- };
- static const uint8_t *
- find_slot_map (uint32_t *ip, struct slot_map_cache *cache)
- {
- /* The lower two bits should be zero. FIXME: Use a better hash
- function; we don't expose scm_raw_hashq currently. */
- size_t slot = (((uintptr_t) ip) >> 2) % SLOT_MAP_CACHE_SIZE;
- const uint8_t *map;
- if (cache->entries[slot].ip == ip)
- map = cache->entries[slot].map;
- else
- {
- map = scm_find_slot_map_unlocked (ip);
- cache->entries[slot].ip = ip;
- cache->entries[slot].map = map;
- }
- return map;
- }
- enum slot_desc
- {
- SLOT_DESC_DEAD = 0,
- SLOT_DESC_LIVE_RAW = 1,
- SLOT_DESC_LIVE_GC = 2,
- SLOT_DESC_UNUSED = 3
- };
- /* Mark the active VM stack region. */
- struct GC_ms_entry *
- scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
- struct GC_ms_entry *mark_stack_limit)
- {
- union scm_vm_stack_element *sp, *fp;
- /* The first frame will be marked conservatively (without a slot map).
- This is because GC can happen at any point within the hottest
- activation, due to multiple threads or per-instruction hooks, and
- providing slot maps for all points in a program would take a
- prohibitive amount of space. */
- const uint8_t *slot_map = NULL;
- void *upper = (void *) GC_greatest_plausible_heap_addr;
- void *lower = (void *) GC_least_plausible_heap_addr;
- struct slot_map_cache cache;
- memset (&cache, 0, sizeof (cache));
- for (fp = vp->fp, sp = vp->sp;
- fp < vp->stack_top;
- fp = SCM_FRAME_DYNAMIC_LINK (fp))
- {
- ptrdiff_t nlocals = SCM_FRAME_NUM_LOCALS (fp, sp);
- size_t slot = nlocals - 1;
- for (slot = nlocals - 1; sp < fp; sp++, slot--)
- {
- enum slot_desc desc = SLOT_DESC_LIVE_GC;
- if (slot_map)
- desc = (slot_map[slot / 4U] >> ((slot % 4U) * 2)) & 3U;
- switch (desc)
- {
- case SLOT_DESC_LIVE_RAW:
- break;
- case SLOT_DESC_UNUSED:
- case SLOT_DESC_LIVE_GC:
- if (SCM_NIMP (sp->as_scm) &&
- sp->as_ptr >= lower && sp->as_ptr <= upper)
- mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
- mark_stack_ptr,
- mark_stack_limit,
- NULL);
- break;
- case SLOT_DESC_DEAD:
- /* This value may become dead as a result of GC,
- so we can't just leave it on the stack. */
- sp->as_scm = SCM_UNSPECIFIED;
- break;
- }
- }
- sp = SCM_FRAME_PREVIOUS_SP (fp);
- /* Inner frames may have a dead slots map for precise marking.
- Note that there may be other reasons to not have a dead slots
- map, e.g. if all of the frame's slots below the callee frame
- are live. */
- slot_map = find_slot_map (SCM_FRAME_VIRTUAL_RETURN_ADDRESS (fp), &cache);
- }
- return_unused_stack_to_os (vp);
- return mark_stack_ptr;
- }
- /* Free the VM stack, as this thread is exiting. */
- void
- scm_i_vm_free_stack (struct scm_vm *vp)
- {
- free_stack (vp->stack_bottom, vp->stack_size);
- /* Not strictly necessary, but good to avoid confusion when debugging
- thread-related GC issues. */
- memset (vp, 0, sizeof (*vp));
- }
- struct vm_expand_stack_data
- {
- struct scm_vm *vp;
- size_t stack_size;
- union scm_vm_stack_element *new_sp;
- };
- static void *
- vm_expand_stack_inner (void *data_ptr)
- {
- struct vm_expand_stack_data *data = data_ptr;
- struct scm_vm *vp = data->vp;
- union scm_vm_stack_element *old_top, *new_bottom;
- size_t new_size;
- ptrdiff_t reloc;
- old_top = vp->stack_top;
- new_size = vp->stack_size;
- while (new_size < data->stack_size)
- new_size *= 2;
- new_bottom = expand_stack (vp->stack_bottom, vp->stack_size, new_size);
- if (!new_bottom)
- return NULL;
- vp->stack_bottom = new_bottom;
- vp->stack_size = new_size;
- vp->stack_top = vp->stack_bottom + new_size;
- vp->stack_limit = vp->stack_bottom;
- reloc = vp->stack_top - old_top;
- if (vp->fp)
- vp->fp += reloc;
- data->new_sp += reloc;
- return new_bottom;
- }
- static ptrdiff_t
- current_overflow_size (struct scm_vm *vp)
- {
- if (scm_is_pair (vp->overflow_handler_stack))
- return scm_to_ptrdiff_t (scm_caar (vp->overflow_handler_stack));
- return -1;
- }
- static int
- should_handle_stack_overflow (struct scm_vm *vp, ptrdiff_t stack_size)
- {
- ptrdiff_t overflow_size = current_overflow_size (vp);
- return overflow_size >= 0 && stack_size >= overflow_size;
- }
- static void
- reset_stack_limit (struct scm_vm *vp)
- {
- if (should_handle_stack_overflow (vp, vp->stack_size))
- vp->stack_limit = vp->stack_top - current_overflow_size (vp);
- else
- vp->stack_limit = vp->stack_bottom;
- }
- struct overflow_handler_data
- {
- struct scm_vm *vp;
- SCM overflow_handler_stack;
- };
- static void
- wind_overflow_handler (void *ptr)
- {
- struct overflow_handler_data *data = ptr;
- data->vp->overflow_handler_stack = data->overflow_handler_stack;
- reset_stack_limit (data->vp);
- }
- static void
- unwind_overflow_handler (void *ptr)
- {
- struct overflow_handler_data *data = ptr;
- data->vp->overflow_handler_stack = scm_cdr (data->overflow_handler_stack);
- reset_stack_limit (data->vp);
- }
- static void
- vm_expand_stack (struct scm_vm *vp, union scm_vm_stack_element *new_sp)
- {
- ptrdiff_t stack_size = vp->stack_top - new_sp;
- if (stack_size > vp->stack_size)
- {
- struct vm_expand_stack_data data;
- data.vp = vp;
- data.stack_size = stack_size;
- data.new_sp = new_sp;
-
- if (!GC_call_with_alloc_lock (vm_expand_stack_inner, &data))
- /* Throw an unwind-only exception. */
- scm_report_stack_overflow ();
- new_sp = data.new_sp;
- }
- vp->sp = new_sp;
- if (should_handle_stack_overflow (vp, stack_size))
- {
- SCM more_stack, new_limit;
- struct overflow_handler_data data;
- data.vp = vp;
- data.overflow_handler_stack = vp->overflow_handler_stack;
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (unwind_overflow_handler, &data,
- SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (wind_overflow_handler, &data,
- SCM_F_WIND_EXPLICITLY);
- /* Call the overflow handler. */
- more_stack = scm_call_0 (scm_cdar (data.overflow_handler_stack));
- /* If the overflow handler returns, its return value should be an
- integral number of words from the outer stack limit to transfer
- to the inner limit. */
- if (scm_to_ptrdiff_t (more_stack) <= 0)
- scm_out_of_range (NULL, more_stack);
- new_limit = scm_sum (scm_caar (data.overflow_handler_stack), more_stack);
- if (scm_is_pair (scm_cdr (data.overflow_handler_stack)))
- new_limit = scm_min (new_limit,
- scm_caadr (data.overflow_handler_stack));
- /* Ensure the new limit is in range. */
- scm_to_ptrdiff_t (new_limit);
- /* Increase the limit that we will restore. */
- scm_set_car_x (scm_car (data.overflow_handler_stack), new_limit);
- scm_dynwind_end ();
- /* Recurse. */
- return vm_expand_stack (vp, new_sp);
- }
- }
- static uint32_t
- frame_locals_count (scm_thread *thread)
- {
- return SCM_FRAME_NUM_LOCALS (thread->vm.fp, thread->vm.sp);
- }
- static void
- thread_expand_stack (scm_thread *thread, union scm_vm_stack_element *new_sp)
- {
- vm_expand_stack (&thread->vm, new_sp);
- }
- /* This duplicates the inlined "ALLOC_FRAME" macro from vm-engine.c, but
- it seems to be necessary for perf; the inlined version avoids the
- needs to flush IP in the common case. */
- static void
- alloc_frame (scm_thread *thread, uint32_t nlocals)
- {
- union scm_vm_stack_element *sp = thread->vm.fp - nlocals;
- if (SCM_UNLIKELY (sp < thread->vm.stack_limit))
- thread_expand_stack (thread, sp);
- else
- thread->vm.sp = sp;
- }
- static uint32_t
- compute_kwargs_npositional (scm_thread *thread, uint32_t nreq, uint32_t nopt)
- {
- uint32_t npositional, nargs;
- nargs = frame_locals_count (thread);
- /* look in optionals for first keyword or last positional */
- /* starting after the last required positional arg */
- npositional = nreq;
- while (/* while we have args */
- npositional < nargs
- /* and we still have positionals to fill */
- && npositional < nreq + nopt
- /* and we haven't reached a keyword yet */
- && !scm_is_keyword (SCM_FRAME_LOCAL (thread->vm.fp, npositional)))
- /* bind this optional arg (by leaving it in place) */
- npositional++;
- return npositional;
- }
- static void
- bind_kwargs (scm_thread *thread, uint32_t npositional, uint32_t nlocals,
- SCM kwargs, uint8_t strict, uint8_t allow_other_keys)
- {
- uint32_t nargs, nkw, n;
- union scm_vm_stack_element *fp;
- nargs = frame_locals_count (thread);
- nkw = nargs - npositional;
- /* shuffle non-positional arguments above nlocals */
- alloc_frame (thread, nlocals + nkw);
- fp = thread->vm.fp;
- n = nkw;
- while (n--)
- SCM_FRAME_LOCAL (fp, nlocals + n) = SCM_FRAME_LOCAL (fp, npositional + n);
- /* Fill optionals & keyword args with SCM_UNDEFINED */
- n = npositional;
- while (n < nlocals)
- SCM_FRAME_LOCAL (fp, n++) = SCM_UNDEFINED;
- /* Now bind keywords, in the order given. */
- for (n = 0; n < nkw; n++)
- {
- SCM kw = SCM_FRAME_LOCAL (fp, nlocals + n);
- if (scm_is_keyword (kw))
- {
- SCM walk;
- for (walk = kwargs; scm_is_pair (walk); walk = SCM_CDR (walk))
- if (scm_is_eq (SCM_CAAR (walk), kw))
- {
- SCM si = SCM_CDAR (walk);
- if (n + 1 < nkw)
- SCM_FRAME_LOCAL (fp, scm_to_uint32 (si)) =
- SCM_FRAME_LOCAL (fp, nlocals + n + 1);
- else
- scm_error_scm (sym_keyword_argument_error, SCM_BOOL_F,
- scm_from_latin1_string
- ("Keyword argument has no value"),
- SCM_EOL, scm_list_1 (kw));
- break;
- }
- if (!allow_other_keys && !scm_is_pair (walk))
- scm_error_scm (sym_keyword_argument_error, SCM_BOOL_F,
- scm_from_latin1_string ("Unrecognized keyword"),
- SCM_EOL, scm_list_1 (kw));
- n++;
- }
- else if (strict)
- {
- scm_error_scm (sym_keyword_argument_error, SCM_BOOL_F,
- scm_from_latin1_string ("Invalid keyword"),
- SCM_EOL, scm_list_1 (kw));
- }
- else
- {
- /* Ignore this argument. It might get consed onto a rest list. */
- }
- }
- }
- static SCM
- cons_rest (scm_thread *thread, uint32_t base)
- {
- SCM rest = SCM_EOL;
- uint32_t n = frame_locals_count (thread) - base;
- while (n--)
- rest = scm_inline_cons (thread, SCM_FRAME_LOCAL (thread->vm.fp, base + n),
- rest);
- return rest;
- }
- static void
- push_interrupt_frame (scm_thread *thread, uint8_t *mra)
- {
- union scm_vm_stack_element *old_fp, *new_fp;
- size_t frame_overhead = 3;
- size_t old_frame_size = frame_locals_count (thread);
- SCM proc = scm_i_async_pop (thread);
- #if ENABLE_JIT
- if (!mra)
- mra = scm_jit_return_to_interpreter_trampoline;
- #endif
- /* Reserve space for frame and callee. */
- alloc_frame (thread, old_frame_size + frame_overhead + 1);
- old_fp = thread->vm.fp;
- new_fp = SCM_FRAME_SLOT (old_fp, old_frame_size + frame_overhead - 1);
- SCM_FRAME_SET_DYNAMIC_LINK (new_fp, old_fp);
- /* Arrange to return to the same handle-interrupts opcode to handle
- any additional interrupts. */
- SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (new_fp, thread->vm.ip);
- SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (new_fp, mra);
- SCM_FRAME_LOCAL (new_fp, 0) = proc;
- thread->vm.fp = new_fp;
- }
- struct return_to_continuation_data
- {
- struct scm_vm_cont *cp;
- struct scm_vm *vp;
- };
- /* Called with the GC lock to prevent the stack marker from traversing a
- stack in an inconsistent state. */
- static void *
- vm_return_to_continuation_inner (void *data_ptr)
- {
- struct return_to_continuation_data *data = data_ptr;
- struct scm_vm *vp = data->vp;
- struct scm_vm_cont *cp = data->cp;
- /* We know that there is enough space for the continuation, because we
- captured it in the past. However there may have been an expansion
- since the capture, so we may have to re-link the frame
- pointers. */
- memcpy (vp->stack_top - cp->stack_size,
- cp->stack_bottom,
- cp->stack_size * sizeof (*cp->stack_bottom));
- vp->fp = vp->stack_top - cp->fp_offset;
- vm_restore_sp (vp, vp->stack_top - cp->stack_size);
- return NULL;
- }
- static void reinstate_continuation_x (scm_thread *thread, SCM cont) SCM_NORETURN;
- static void
- reinstate_continuation_x (scm_thread *thread, SCM cont)
- {
- scm_t_contregs *continuation = scm_i_contregs (cont);
- struct scm_vm *vp = &thread->vm;
- struct scm_vm_cont *cp;
- size_t n, i, frame_overhead = 3;
- union scm_vm_stack_element *argv;
- struct return_to_continuation_data data;
- if (!scm_is_eq (continuation->root, thread->continuation_root))
- scm_misc_error
- ("%continuation-call",
- "invoking continuation would cross continuation barrier: ~A",
- scm_list_1 (cont));
- n = frame_locals_count (thread) - 1;
- argv = alloca (n * sizeof (*argv));
- memcpy (argv, vp->sp, n * sizeof (*argv));
- cp = SCM_VM_CONT_DATA (continuation->vm_cont);
- data.cp = cp;
- data.vp = vp;
- GC_call_with_alloc_lock (vm_return_to_continuation_inner, &data);
- /* Now we have the continuation properly copied over. We just need to
- copy on an empty frame and the return values, as the continuation
- expects. */
- vm_push_sp (vp, vp->sp - frame_overhead - n);
- for (i = 0; i < frame_overhead; i++)
- vp->sp[n+i].as_scm = SCM_BOOL_F;
- memcpy(vp->sp, argv, n * sizeof (union scm_vm_stack_element));
- vp->ip = cp->vra;
- scm_i_reinstate_continuation (cont, cp->mra);
- }
- static SCM
- capture_continuation (scm_thread *thread)
- {
- struct scm_vm *vp = &thread->vm;
- void *mra = SCM_FRAME_MACHINE_RETURN_ADDRESS (vp->fp);
- #if ENABLE_JIT
- if (mra == scm_jit_return_to_interpreter_trampoline)
- mra = NULL;
- #endif
- SCM vm_cont = capture_stack (vp->stack_top,
- SCM_FRAME_DYNAMIC_LINK (vp->fp),
- SCM_FRAME_PREVIOUS_SP (vp->fp),
- SCM_FRAME_VIRTUAL_RETURN_ADDRESS (vp->fp),
- mra,
- scm_dynstack_capture_all (&thread->dynstack),
- 0);
- return scm_i_make_continuation (thread, vm_cont);
- }
- struct compose_continuation_data
- {
- struct scm_vm *vp;
- struct scm_vm_cont *cp;
- };
- static void *
- compose_continuation_inner (void *data_ptr)
- {
- struct compose_continuation_data *data = data_ptr;
- struct scm_vm *vp = data->vp;
- struct scm_vm_cont *cp = data->cp;
- memcpy (vp->fp - cp->stack_size,
- cp->stack_bottom,
- cp->stack_size * sizeof (*cp->stack_bottom));
- vp->fp -= cp->fp_offset;
- vp->ip = cp->vra;
- return cp->mra;
- }
- static uint8_t*
- compose_continuation (scm_thread *thread, SCM cont)
- {
- struct scm_vm *vp = &thread->vm;
- size_t nargs;
- struct compose_continuation_data data;
- struct scm_vm_cont *cp;
- union scm_vm_stack_element *args;
- ptrdiff_t old_fp_offset;
- uint8_t *mra;
- if (SCM_UNLIKELY (! SCM_VM_CONT_REWINDABLE_P (cont)))
- scm_wrong_type_arg_msg (NULL, 0, cont, "resumable continuation");
- #if ENABLE_JIT
- if (!SCM_FRAME_MACHINE_RETURN_ADDRESS (vp->fp))
- SCM_FRAME_SET_MACHINE_RETURN_ADDRESS
- (vp->fp, scm_jit_return_to_interpreter_trampoline);
- #endif
- nargs = frame_locals_count (thread) - 1;
- args = alloca (nargs * sizeof (*args));
- memcpy (args, vp->sp, nargs * sizeof (*args));
- cp = SCM_VM_CONT_DATA (cont);
- old_fp_offset = vp->stack_top - vp->fp;
- vm_push_sp (vp, vp->fp - (cp->stack_size + nargs));
- data.vp = vp;
- data.cp = cp;
- mra = GC_call_with_alloc_lock (compose_continuation_inner, &data);
- /* The resumed continuation will expect ARGS on the stack as if from a
- multiple-value return. */
- memcpy (vp->sp, args, nargs * sizeof (*args));
- /* The prompt captured a slice of the dynamic stack. Here we wind
- those entries onto the current thread's stack. We also have to
- relocate any prompts that we see along the way. */
- {
- scm_t_bits *walk;
- for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
- SCM_DYNSTACK_TAG (walk);
- walk = SCM_DYNSTACK_NEXT (walk))
- {
- scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
- if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
- scm_dynstack_wind_prompt (&thread->dynstack, walk, old_fp_offset,
- thread->vm.registers);
- else
- scm_dynstack_wind_1 (&thread->dynstack, walk);
- }
- }
- return mra;
- }
- static void
- expand_apply_argument (scm_thread *thread)
- {
- SCM x = thread->vm.sp[0].as_scm;
- int len = scm_ilength (x);
- if (SCM_UNLIKELY (len < 0))
- scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
- scm_list_1 (x), scm_list_1 (x));
- alloc_frame (thread, frame_locals_count (thread) - 1 + len);
- while (len--)
- {
- thread->vm.sp[len].as_scm = SCM_CAR (x);
- x = SCM_CDR (x);
- }
- }
- /* This is here to avoid putting the code for "alloc-frame" in subr
- calls. */
- static void
- unpack_values_object (scm_thread *thread, SCM obj)
- {
- size_t n, nvals = scm_i_nvalues (obj);
- alloc_frame (thread, nvals);
- for (n = 0; n < nvals; n++)
- SCM_FRAME_LOCAL (thread->vm.fp, n) = scm_i_value_ref (obj, n);
- }
- static void
- foreign_call (scm_thread *thread, SCM cif, SCM pointer)
- {
- SCM ret;
- int err = 0;
- ret = scm_i_foreign_call (cif, pointer, &err, thread->vm.sp);
- alloc_frame (thread, 2);
- SCM_FRAME_LOCAL (thread->vm.fp, 0) = ret;
- SCM_FRAME_LOCAL (thread->vm.fp, 1) = scm_from_int (err);
- }
- static SCM
- capture_delimited_continuation (struct scm_vm *vp,
- union scm_vm_stack_element *saved_fp,
- uint8_t *saved_mra,
- jmp_buf *saved_registers,
- scm_t_dynstack *dynstack,
- jmp_buf *current_registers)
- {
- SCM vm_cont;
- uint32_t flags;
- union scm_vm_stack_element *base_fp;
- flags = SCM_F_VM_CONT_PARTIAL;
- /* If we are aborting to a prompt that has the same registers as those
- of the abort, it means there are no intervening C frames on the
- stack, and so the continuation can be relocated elsewhere on the
- stack: it is rewindable. */
- if (saved_registers && saved_registers == current_registers)
- flags |= SCM_F_VM_CONT_REWINDABLE;
- /* Walk the stack until we find the first frame newer than saved_fp.
- We will save the stack until that frame. It used to be that we
- could determine the stack base in O(1) time, but that's no longer
- the case, since the thunk application doesn't occur where the
- prompt is saved. */
- for (base_fp = vp->fp;
- SCM_FRAME_DYNAMIC_LINK (base_fp) < saved_fp;
- base_fp = SCM_FRAME_DYNAMIC_LINK (base_fp));
- if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp)
- abort();
- scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp);
- /* Capture from the base_fp to the top thunk application frame. Don't
- capture values from the most recent frame, as they are the abort
- args. */
- vm_cont = capture_stack (base_fp, vp->fp, vp->fp, vp->ip,
- saved_mra, dynstack, flags);
- return scm_i_make_composable_continuation (vm_cont);
- }
- void
- scm_i_vm_abort (SCM *tag_and_argv, size_t n)
- {
- scm_call_n (vm_builtin_abort_to_prompt, tag_and_argv, n);
- /* Unreachable. */
- abort ();
- }
- /* The same as scm_i_vm_abort(), but possibly called in response to
- resource allocation failures, so we might not be able to make a
- call, as that might require stack expansion. Grrr. */
- void
- scm_i_vm_emergency_abort (SCM *tag_and_argv, size_t n)
- {
- scm_thread *thread = SCM_I_CURRENT_THREAD;
- struct scm_vm *vp = &thread->vm;
- scm_t_dynstack *dynstack = &thread->dynstack;
- SCM tag, cont;
- size_t nargs;
- scm_t_bits *prompt;
- scm_t_dynstack_prompt_flags flags;
- ptrdiff_t fp_offset, sp_offset;
- union scm_vm_stack_element *fp, *sp;
- SCM *argv;
- uint32_t *vra;
- uint8_t *mra;
- jmp_buf *registers;
- tag = tag_and_argv[0];
- argv = tag_and_argv + 1;
- nargs = n - 1;
- prompt = scm_dynstack_find_prompt (dynstack, tag,
- &flags, &fp_offset, &sp_offset,
- &vra, &mra, ®isters);
- if (!prompt)
- {
- fprintf (stderr, "guile: fatal: emergency abort to unknown prompt\n");
- abort ();
- }
- if (!(flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY))
- {
- fprintf (stderr, "guile: fatal: emergency abort to non-linear prompt\n");
- abort ();
- }
- cont = SCM_BOOL_F;
- /* Unwind. */
- scm_dynstack_unwind (dynstack, prompt);
- fp = vp->stack_top - fp_offset;
- sp = vp->stack_top - sp_offset;
- /* Restore FP first so that a concurrent 'scm_i_vm_mark_stack' does
- not overwrite the 'abort' arguments assigned below (see
- <https://bugs.gnu.org/28211>). */
- vp->fp = fp;
- /* Continuation gets nargs+1 values: the one more is for the cont. */
- sp = sp - nargs - 1;
- /* Shuffle abort arguments down to the prompt continuation. We have
- to be jumping to an older part of the stack. */
- if (sp < vp->sp)
- abort ();
- sp[nargs].as_scm = cont;
- while (nargs--)
- sp[nargs].as_scm = *argv++;
- /* Restore VM regs */
- vp->sp = sp;
- vp->ip = vra;
- /* Jump! */
- vp->mra_after_abort = mra;
- longjmp (*registers, 1);
- }
- static uint8_t *
- abort_to_prompt (scm_thread *thread, uint8_t *saved_mra)
- {
- struct scm_vm *vp = &thread->vm;
- scm_t_dynstack *dynstack = &thread->dynstack;
- SCM tag, cont;
- size_t nargs;
- scm_t_bits *prompt;
- scm_t_dynstack_prompt_flags flags;
- ptrdiff_t fp_offset, sp_offset;
- union scm_vm_stack_element *fp, *sp;
- uint32_t *vra;
- uint8_t *mra;
- jmp_buf *registers;
- tag = SCM_FRAME_LOCAL (vp->fp, 1);
- nargs = frame_locals_count (thread) - 2;
- prompt = scm_dynstack_find_prompt (dynstack, tag,
- &flags, &fp_offset, &sp_offset,
- &vra, &mra, ®isters);
- if (!prompt)
- scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
- fp = vp->stack_top - fp_offset;
- /* Only reify if the continuation referenced in the handler. */
- if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
- cont = SCM_BOOL_F;
- else
- {
- scm_t_dynstack *captured;
- captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
- cont = capture_delimited_continuation (vp, fp, saved_mra, registers,
- captured, thread->vm.registers);
- }
- /* Unwind. */
- scm_dynstack_unwind (dynstack, prompt);
- /* Recompute FP, as scm_dynstack_unwind may have expanded the stack. */
- fp = vp->stack_top - fp_offset;
- sp = vp->stack_top - sp_offset;
- /* Continuation gets nargs+1 values: the one more is for the cont. */
- sp = sp - nargs - 1;
- /* Restore FP first so that a concurrent 'scm_i_vm_mark_stack' does
- not overwrite the 'abort' arguments assigned below (see
- <https://bugs.gnu.org/28211>). */
- vp->fp = fp;
- /* Shuffle abort arguments down to the prompt continuation. We have
- to be jumping to an older part of the stack. */
- if (sp < vp->sp)
- abort ();
- sp[nargs].as_scm = cont;
- while (nargs--)
- sp[nargs] = vp->sp[nargs];
- /* Restore VM regs */
- vp->sp = sp;
- vp->ip = vra;
- /* If there are intervening C frames, then jump over them, making a
- nonlocal exit. Otherwise fall through and let the VM pick up where
- it left off. */
- if (thread->vm.registers != registers)
- {
- vp->mra_after_abort = mra;
- longjmp (*registers, 1);
- }
- return mra;
- }
- static uint32_t *
- get_callee_vcode (scm_thread *thread)
- {
- struct scm_vm *vp = &thread->vm;
- SCM proc = SCM_FRAME_LOCAL (vp->fp, 0);
- if (SCM_LIKELY (SCM_PROGRAM_P (proc)))
- return SCM_PROGRAM_CODE (proc);
- while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
- {
- proc = SCM_STRUCT_PROCEDURE (proc);
- SCM_FRAME_LOCAL (vp->fp, 0) = proc;
- if (SCM_PROGRAM_P (proc))
- return SCM_PROGRAM_CODE (proc);
- }
- if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
- {
- uint32_t n = frame_locals_count (thread);
- alloc_frame (thread, n + 1);
- /* Although we could make VM modifications to avoid this shuffle,
- it's easier to piggy-back on the subr arg parsing machinery.
- Hopefully applicable smobs will go away in the mid-term. */
- while (n--)
- SCM_FRAME_LOCAL (vp->fp, n + 1) = SCM_FRAME_LOCAL (vp->fp, n);
- proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
- SCM_FRAME_LOCAL (vp->fp, 0) = proc;
- return SCM_PROGRAM_CODE (proc);
- }
- vp->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (vp->fp);
- scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
- scm_list_1 (proc), scm_list_1 (proc));
- }
- SCM
- scm_call_n (SCM proc, SCM *argv, size_t nargs)
- {
- scm_thread *thread;
- struct scm_vm *vp;
- union scm_vm_stack_element *return_fp, *call_fp;
- /* Since nargs can only describe the length of a valid argv array in
- elements and each element is at least 4 bytes, nargs will not be
- greater than INTMAX/2 and therefore we don't have to check for
- overflow here or below. */
- size_t return_nlocals = 0, call_nlocals = nargs + 1, frame_size = 3;
- ptrdiff_t stack_reserve_words;
- size_t i;
- thread = SCM_I_CURRENT_THREAD;
- vp = &thread->vm;
- SCM_CHECK_STACK;
- /* It's not valid for argv to point into the stack already. */
- if ((void *) argv < (void *) vp->stack_top &&
- (void *) argv >= (void *) vp->sp)
- abort();
- /* Check that we have enough space for the two stack frames: the
- innermost one that makes the call, and its continuation which
- receives the resulting value(s) and returns from the engine
- call. */
- stack_reserve_words = call_nlocals + frame_size + return_nlocals + frame_size;
- vm_push_sp (vp, vp->sp - stack_reserve_words);
- call_fp = vp->sp + call_nlocals;
- return_fp = call_fp + frame_size + return_nlocals;
- SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (return_fp, vp->ip);
- SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (return_fp, 0);
- SCM_FRAME_SET_DYNAMIC_LINK (return_fp, vp->fp);
- vp->ip = (uint32_t *) vm_boot_continuation_code;
- SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (call_fp, vp->ip);
- SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (call_fp, 0);
- SCM_FRAME_SET_DYNAMIC_LINK (call_fp, return_fp);
- SCM_FRAME_LOCAL (call_fp, 0) = proc;
- for (i = 0; i < nargs; i++)
- SCM_FRAME_LOCAL (call_fp, i + 1) = argv[i];
- vp->fp = call_fp;
- {
- jmp_buf registers;
- int resume;
- jmp_buf *prev_registers = thread->vm.registers;
- SCM ret;
- resume = setjmp (registers);
- thread->vm.registers = ®isters;
- if (SCM_UNLIKELY (resume))
- {
- uint8_t *mcode = vp->mra_after_abort;
- scm_gc_after_nonlocal_exit ();
- /* Non-local return. */
- if (vp->abort_hook_enabled)
- invoke_abort_hook (thread);
- #if ENABLE_JIT
- if (mcode && !vp->disable_mcode)
- scm_jit_enter_mcode (thread, mcode);
- #endif
- }
- else
- vp->ip = get_callee_vcode (thread);
- ret = vm_engines[vp->engine](thread);
- thread->vm.registers = prev_registers;
- return ret;
- }
- }
- /* Scheme interface */
- #define VM_ADD_HOOK(h, f) \
- { \
- scm_thread *t = SCM_I_CURRENT_THREAD; \
- SCM hook = t->vm.h##_hook; \
- if (scm_is_false (hook)) \
- hook = t->vm.h##_hook = scm_make_hook (SCM_I_MAKINUM (1)); \
- scm_add_hook_x (hook, f, SCM_UNDEFINED); \
- vm_hook_compute_enabled (t, hook, &t->vm.h##_hook_enabled); \
- vm_recompute_disable_mcode (t); \
- return SCM_UNSPECIFIED; \
- }
- #define VM_REMOVE_HOOK(h, f) \
- { \
- scm_thread *t = SCM_I_CURRENT_THREAD; \
- SCM hook = t->vm.h##_hook; \
- if (scm_is_true (hook)) \
- scm_remove_hook_x (hook, f); \
- vm_hook_compute_enabled (t, hook, &t->vm.h##_hook_enabled); \
- vm_recompute_disable_mcode (t); \
- return SCM_UNSPECIFIED; \
- }
- SCM_DEFINE (scm_vm_add_apply_hook_x, "vm-add-apply-hook!", 1, 0, 0,
- (SCM f),
- "")
- #define FUNC_NAME s_scm_vm_add_apply_hook_x
- {
- VM_ADD_HOOK (apply, f);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_vm_remove_apply_hook_x, "vm-remove-apply-hook!", 1, 0, 0,
- (SCM f),
- "")
- #define FUNC_NAME s_scm_vm_remove_apply_hook_x
- {
- VM_REMOVE_HOOK (apply, f);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_vm_add_return_hook_x, "vm-add-return-hook!", 1, 0, 0,
- (SCM f),
- "")
- #define FUNC_NAME s_scm_vm_add_return_hook_x
- {
- VM_ADD_HOOK (return, f);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_vm_remove_return_hook_x, "vm-remove-return-hook!", 1, 0, 0,
- (SCM f),
- "")
- #define FUNC_NAME s_scm_vm_remove_return_hook_x
- {
- VM_REMOVE_HOOK (return, f);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_vm_add_next_hook_x, "vm-add-next-hook!", 1, 0, 0,
- (SCM f),
- "")
- #define FUNC_NAME s_scm_vm_add_next_hook_x
- {
- VM_ADD_HOOK (next, f);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_vm_remove_next_hook_x, "vm-remove-next-hook!", 1, 0, 0,
- (SCM f),
- "")
- #define FUNC_NAME s_scm_vm_remove_next_hook_x
- {
- VM_REMOVE_HOOK (next, f);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_vm_add_abort_hook_x, "vm-add-abort-hook!", 1, 0, 0,
- (SCM f),
- "")
- #define FUNC_NAME s_scm_vm_add_abort_hook_x
- {
- VM_ADD_HOOK (abort, f);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_vm_remove_abort_hook_x, "vm-remove-abort-hook!", 1, 0, 0,
- (SCM f),
- "")
- #define FUNC_NAME s_scm_vm_remove_abort_hook_x
- {
- VM_REMOVE_HOOK (abort, f);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0,
- (void),
- "")
- #define FUNC_NAME s_scm_vm_trace_level
- {
- return scm_from_int (SCM_I_CURRENT_THREAD->vm.trace_level);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0,
- (SCM level),
- "")
- #define FUNC_NAME s_scm_set_vm_trace_level_x
- {
- scm_thread *thread = SCM_I_CURRENT_THREAD;
- return scm_from_int (set_vm_trace_level (thread, scm_to_int (level)));
- }
- #undef FUNC_NAME
- /*
- * VM engines
- */
- static int
- symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
- {
- if (scm_is_eq (engine, sym_regular))
- return SCM_VM_REGULAR_ENGINE;
- else if (scm_is_eq (engine, sym_debug))
- return SCM_VM_DEBUG_ENGINE;
- else
- SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
- }
-
- static SCM
- vm_engine_to_symbol (int engine, const char *FUNC_NAME)
- {
- switch (engine)
- {
- case SCM_VM_REGULAR_ENGINE:
- return sym_regular;
- case SCM_VM_DEBUG_ENGINE:
- return sym_debug;
- default:
- /* ? */
- SCM_MISC_ERROR ("Unknown VM engine: ~a",
- scm_list_1 (scm_from_int (engine)));
- }
- }
-
- SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0,
- (void),
- "")
- #define FUNC_NAME s_scm_vm_engine
- {
- return vm_engine_to_symbol (SCM_I_CURRENT_THREAD->vm.engine, FUNC_NAME);
- }
- #undef FUNC_NAME
- void
- scm_c_set_vm_engine_x (int engine)
- #define FUNC_NAME "set-vm-engine!"
- {
- scm_thread *thread = SCM_I_CURRENT_THREAD;
- if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
- SCM_MISC_ERROR ("Unknown VM engine: ~a",
- scm_list_1 (scm_from_int (engine)));
-
- thread->vm.engine = engine;
- /* Trigger update of the various hook_enabled flags. */
- set_vm_trace_level (thread, thread->vm.trace_level);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0,
- (SCM engine),
- "")
- #define FUNC_NAME s_scm_set_vm_engine_x
- {
- scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- void
- scm_c_set_default_vm_engine_x (int engine)
- #define FUNC_NAME "set-default-vm-engine!"
- {
- if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
- SCM_MISC_ERROR ("Unknown VM engine: ~a",
- scm_list_1 (scm_from_int (engine)));
-
- vm_default_engine = engine;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
- (SCM engine),
- "")
- #define FUNC_NAME s_scm_set_default_vm_engine_x
- {
- scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- /* FIXME: This function makes no sense, but we keep it to make sure we
- have a way of switching to the debug or regular VM. */
- SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1,
- (SCM proc, SCM args),
- "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
- "@var{vm} is the current VM.")
- #define FUNC_NAME s_scm_call_with_vm
- {
- return scm_apply_0 (proc, args);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_call_with_stack_overflow_handler,
- "call-with-stack-overflow-handler", 3, 0, 0,
- (SCM limit, SCM thunk, SCM handler),
- "Call @var{thunk} in an environment in which the stack limit has\n"
- "been reduced to @var{limit} additional words. If the limit is\n"
- "reached, @var{handler} (a thunk) will be invoked in the dynamic\n"
- "environment of the error. For the extent of the call to\n"
- "@var{handler}, the stack limit and handler are restored to the\n"
- "values that were in place when\n"
- "@code{call-with-stack-overflow-handler} was called.")
- #define FUNC_NAME s_scm_call_with_stack_overflow_handler
- {
- struct scm_thread *t = SCM_I_CURRENT_THREAD;
- ptrdiff_t c_limit, stack_size;
- struct overflow_handler_data data;
- SCM new_limit, ret;
- stack_size = t->vm.stack_top - t->vm.sp;
- c_limit = scm_to_ptrdiff_t (limit);
- if (c_limit <= 0)
- scm_out_of_range (FUNC_NAME, limit);
- new_limit = scm_sum (scm_from_ptrdiff_t (stack_size), limit);
- if (scm_is_pair (t->vm.overflow_handler_stack))
- new_limit = scm_min (new_limit, scm_caar (t->vm.overflow_handler_stack));
- /* Hacky check that the current stack depth plus the limit is within
- the range of a ptrdiff_t. */
- scm_to_ptrdiff_t (new_limit);
- data.vp = &t->vm;
- data.overflow_handler_stack =
- scm_acons (limit, handler, t->vm.overflow_handler_stack);
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (wind_overflow_handler, &data,
- SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (unwind_overflow_handler, &data,
- SCM_F_WIND_EXPLICITLY);
- ret = scm_call_0 (thunk);
- scm_dynwind_end ();
- return ret;
- }
- #undef FUNC_NAME
- /*
- * Initialize
- */
- SCM
- scm_load_compiled_with_vm (SCM file)
- {
- return scm_call_0 (scm_load_thunk_from_file (file));
- }
-
- void
- scm_init_vm_builtin_properties (void)
- {
- /* FIXME: Seems hacky to do this here, but oh well :/ */
- scm_sym_apply = scm_from_utf8_symbol ("apply");
- scm_sym_values = scm_from_utf8_symbol ("values");
- scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt");
- scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values");
- scm_sym_call_with_current_continuation =
- scm_from_utf8_symbol ("call-with-current-continuation");
- #define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
- scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
- scm_sym_##builtin);
- FOR_EACH_VM_BUILTIN (INIT_BUILTIN);
- #undef INIT_BUILTIN
- }
- void
- scm_bootstrap_vm (void)
- {
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_vm",
- (scm_t_extension_init_func)scm_init_vm, NULL);
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_vm_builtins",
- (scm_t_extension_init_func)scm_init_vm_builtins,
- NULL);
- scm_vm_intrinsics.expand_stack = thread_expand_stack;
- scm_vm_intrinsics.cons_rest = cons_rest;
- scm_vm_intrinsics.compute_kwargs_npositional = compute_kwargs_npositional;
- scm_vm_intrinsics.bind_kwargs = bind_kwargs;
- scm_vm_intrinsics.push_interrupt_frame = push_interrupt_frame;
- scm_vm_intrinsics.reinstate_continuation_x = reinstate_continuation_x;
- scm_vm_intrinsics.capture_continuation = capture_continuation;
- scm_vm_intrinsics.compose_continuation = compose_continuation;
- scm_vm_intrinsics.expand_apply_argument = expand_apply_argument;
- scm_vm_intrinsics.abort_to_prompt = abort_to_prompt;
- scm_vm_intrinsics.get_callee_vcode = get_callee_vcode;
- scm_vm_intrinsics.unpack_values_object = unpack_values_object;
- scm_vm_intrinsics.foreign_call = foreign_call;
- sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
- sym_regular = scm_from_latin1_symbol ("regular");
- sym_debug = scm_from_latin1_symbol ("debug");
- vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code);
- SCM_SET_CELL_WORD_0 (vm_boot_continuation,
- (SCM_CELL_WORD_0 (vm_boot_continuation)
- | SCM_F_PROGRAM_IS_BOOT));
- define_vm_builtins ();
- }
- void
- scm_init_vm (void)
- {
- #ifndef SCM_MAGIC_SNARFER
- #include "vm.x"
- #endif
- }
|