/* StarForth — Steady-State Virtual Machine Runtime Copyright (c) 2023–2025 Robert A. James All rights reserved. This file is part of the StarForth project. Licensed under the StarForth License, Version 1.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: https://github.com/star.4th@proton.me/StarForth/LICENSE.txt This 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. See the License for the specific language governing permissions and limitations under the License. */ /** * @file mama_forth_words.c * @brief Mama FORTH vocabulary implementation for kernel capsule system (M7.1) * * Implements the MAMA vocabulary - kernel-only words for the LithosAnanke * capsule birth protocol. This file is ONLY compiled for __STARKERNEL__ builds. * * The MAMA vocabulary provides: * - Capsule directory enumeration * - Baby VM birth from production capsules * - Experiment execution on Mama * - VM registry queries */ #ifdef __STARKERNEL__ #include "platform_alloc.h" #include #include "starkernel/capsule.h" #include "starkernel/capsule_birth.h" #include "starkernel/capsule_runcap.h" #include "starkernel/capsule_console.h" #include "starkernel/capsule_wirebind.h" #include "starkernel/capsule_zuse_boot.h" /* capsule_zuse_boot_logout() -- FABRIC-2.md §I.8 EJECT */ #include "starkernel/homeblocks_sig.h" #include "freestanding/stdio.h" #include "starkernel/capsule_mint.h" #include "starkernel/user_identity_seed.h" #include "starkernel/zuse_eligibility.h" #include "starkernel/capsule_loader.h" #include "starkernel/capsule_run.h" #include "starkernel/capsule_loader.h" #include "starkernel/capsule_vm_physics.h" #include "starkernel/vm/vm_internal.h" #include "starkernel/vm/stadium.h" /* item 4.2 -- STADIUM-* words */ #include "starkernel/vm/stadium_words.h" /* item 4.2 -- stadium_words_resident_heat() */ #include "starkernel/repl.h" #include "starkernel/capsule_generated.h" #include "starkernel/console.h" #include "starkernel/arch.h" #include "starkernel/timer.h" #include "log.h" #include "vm.h" #include "word_registry.h" #include "word_source/include/vocabulary_words.h" /* Forward declarations for functions defined in vm_bootstrap.c and vocabulary_words.c */ extern void vm_bootstrap_root_vocabulary(VM *vm, const char *name); extern void vocabulary_word_forth(VM *vm); extern void vocabulary_word_definitions(VM *vm); /* ============================================================================ * Capsule Directory Words * ============================================================================ */ /** * @brief CAPSULE-COUNT ( -- n ) * Push number of capsules in the capsule directory. */ void mama_word_capsule_count(VM *vm) { vm_push(vm, (cell_t)capsule_get_desc_count()); } /** * @brief CAPSULE@ ( idx -- desc ) * Get capsule descriptor address by index. * Returns 0 if index is out of bounds. */ void mama_word_capsule_fetch(VM *vm) { if (vm->dsp < 0) { vm->error = 1; return; } cell_t idx = vm_pop(vm); if ((uint32_t)idx >= capsule_get_desc_count()) { vm_push(vm, 0); /* Out of bounds */ return; } /* Push address of descriptor */ vm_push(vm, (cell_t)(uintptr_t)&capsule_get_descriptors()[idx]); } /** * @brief CAPSULE-HASH@ ( desc -- hash ) * Get content hash from capsule descriptor. */ void mama_word_capsule_hash_fetch(VM *vm) { if (vm->dsp < 0) { vm->error = 1; return; } cell_t desc_addr = vm_pop(vm); const CapsuleDesc *desc = (const CapsuleDesc *)(uintptr_t)desc_addr; if (!desc) { vm_push(vm, 0); return; } vm_push(vm, (cell_t)desc->content_hash); } /** * @brief CAPSULE-FLAGS@ ( desc -- flags ) * Get flags from capsule descriptor. */ void mama_word_capsule_flags_fetch(VM *vm) { if (vm->dsp < 0) { vm->error = 1; return; } cell_t desc_addr = vm_pop(vm); const CapsuleDesc *desc = (const CapsuleDesc *)(uintptr_t)desc_addr; if (!desc) { vm_push(vm, 0); return; } vm_push(vm, (cell_t)desc->flags); } /** * @brief CAPSULE-LEN@ ( desc -- len ) * Get payload length from capsule descriptor. */ void mama_word_capsule_len_fetch(VM *vm) { if (vm->dsp < 0) { vm->error = 1; return; } cell_t desc_addr = vm_pop(vm); const CapsuleDesc *desc = (const CapsuleDesc *)(uintptr_t)desc_addr; if (!desc) { vm_push(vm, 0); return; } vm_push(vm, (cell_t)desc->length); } /* ============================================================================ * VM Lifecycle State Stack * * Save/restore Hera's ECW interpreter state around lifecycle primitives * (BIRTH, VM-EXEC, START). ECW pushes a resume IP onto vm->rsp before * each word call and pops it after; if any lifecycle primitive corrupts * vm->rsp the pop returns garbage and ip → fault. The state stack is * dynamically allocated (sf_realloc) so its depth is unbounded. * ============================================================================ */ static int vm_state_push(VM *vm) { if (vm->call_sp >= vm->call_stack_cap) { int new_cap = vm->call_stack_cap ? vm->call_stack_cap * 2 : 8; VMCallState *ns = (VMCallState *)sf_realloc(vm->call_stack, (size_t)new_cap * sizeof(VMCallState)); if (!ns) { log_message(LOG_ERROR, "vm_state_push: allocation failed at depth %d", vm->call_sp); return 0; } vm->call_stack = ns; vm->call_stack_cap = new_cap; } VMCallState *s = &vm->call_stack[vm->call_sp++]; s->rsp = vm->rsp; s->exit_colon = vm->exit_colon; s->ecw_nesting = vm->ecw_nesting; if (vm->call_sp > vm->call_stack_max) vm->call_stack_max = vm->call_sp; return 1; } static void vm_state_pop(VM *vm) { if (vm->call_sp <= 0) return; VMCallState *s = &vm->call_stack[--vm->call_sp]; vm->rsp = s->rsp; vm->exit_colon = s->exit_colon; vm->ecw_nesting = s->ecw_nesting; } /* ============================================================================ * VM Birth and Experiment Words * ============================================================================ */ /** * @brief BIRTH ( c-addr u -- ) * Birth a named VM from its capsule. Idempotent — if a live VM with * that name already exists (case-insensitive), logs and returns. * * Name mapping: S" Artemis" → capsule "artemis:init.4th" * Exception: S" Hera" → rejected (cannot re-birth Mama) */ void mama_word_birth(VM *vm) { char name_buf[VM_NAME_MAX]; char capsule_name[VM_NAME_MAX + 12]; /* name + ":init.4th" + NUL */ VMRegistryEntry existing; uint32_t i, j; cell_t u, caddr; const char *src; char lower[VM_NAME_MAX]; CapsuleRunResult result; VMUuid new_vm_id; if (vm->dsp < 1) { vm->error = 1; return; } u = vm_pop(vm); caddr = vm_pop(vm); if (u <= 0 || (uint32_t)u >= VM_NAME_MAX) { console_println("BIRTH: name too long or empty"); return; } /* caddr is a VM address; S" ( -- c-addr u ) stores chars directly at caddr */ { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)u; i++) name_buf[i] = src[i]; name_buf[u] = '\0'; /* Idempotency: live VM with same name → skip */ if (capsule_vm_find_by_name_nocase(name_buf, &existing) == 0 && existing.state == VM_STATE_LIVE) { console_puts("BIRTH: "); console_puts(name_buf); console_println(" already live (idempotent)"); return; } /* Lowercase name for capsule path */ for (i = 0; name_buf[i]; i++) { char c = name_buf[i]; lower[i] = (c >= 'A' && c <= 'Z') ? (char)(c + 32) : c; } lower[i] = '\0'; /* Hera cannot be re-birthed */ if (lower[0]=='h' && lower[1]=='e' && lower[2]=='r' && lower[3]=='a' && lower[4]=='\0') { console_println("BIRTH: cannot re-birth Hera"); return; } /* Build "lower:init.4th" */ j = 0; for (i = 0; lower[i]; i++) capsule_name[j++] = lower[i]; capsule_name[j++] = ':'; { const char *suf = "init.4th"; for (i = 0; suf[i]; i++) capsule_name[j++] = suf[i]; } capsule_name[j] = '\0'; new_vm_id = vm_uuid_none(); /* Switch console prefix to the baby's name so its init capsule output * appears tagged [Hermes] / [Artemis] rather than [Hera]. */ { char saved_prefix[VM_NAME_MAX]; console_save_vm_name(saved_prefix, sizeof(saved_prefix)); console_set_vm_name(name_buf); vm_state_push(vm); result = capsule_birth_baby( capsule_name, capsule_get_directory(), capsule_get_descriptors(), capsule_get_names(), capsule_get_arena(), vm->stadium_vm_id, /* §H.12 step 7: who is birthing this VM */ 0, /* skip_pki_sig: normal build-time capsule */ &new_vm_id, (void **)0 ); vm_state_pop(vm); console_set_vm_name(saved_prefix); /* restore [Hera] (or whoever called BIRTH) */ } if (result == CAPSULE_RUN_OK) { capsule_vm_registry_set_name(new_vm_id, name_buf); vm_physics_init(new_vm_id); console_puts("BIRTH: "); console_puts(name_buf); console_println(" live"); } else { console_puts("BIRTH: "); console_puts(name_buf); console_println(" FAILED"); } /* D3: stack clean on exit */ } /** * @brief START ( c-addr u -- ) * Enter a named VM's REPL loop synchronously. The calling VM blocks * inside sk_repl_run() until the target halts (via STOP or BYE). * Cannot start a LIVE, DEAD, or STILLBORN VM. */ void mama_word_start(VM *vm) { char name_buf[VM_NAME_MAX]; VMRegistryEntry entry; uint32_t i; cell_t u, caddr; const char *src; const char *caller_name; VM *target; if (vm->dsp < 1) { vm->error = 1; return; } u = vm_pop(vm); caddr = vm_pop(vm); if (u <= 0 || (uint32_t)u >= VM_NAME_MAX) { console_println("START: name too long or empty"); return; } /* caddr is a VM address; S" ( -- c-addr u ) stores chars directly at caddr */ { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)u; i++) name_buf[i] = src[i]; name_buf[u] = '\0'; if (capsule_vm_find_by_name_nocase(name_buf, &entry) != 0) { console_puts("START: "); console_puts(name_buf); console_println(" not found"); return; } if (entry.state == VM_STATE_LIVE) { console_puts("START: "); console_puts(name_buf); console_println(" already live"); return; } if (entry.state == VM_STATE_DEAD || entry.state == VM_STATE_STILLBORN) { console_puts("START: "); console_puts(name_buf); console_println(" dead/stillborn — BIRTH first"); return; } target = (VM *)entry.vm_ptr; if (!target) { console_puts("START: "); console_puts(name_buf); console_println(" no VM pointer"); return; } /* Switch console prefix to target VM's name */ caller_name = console_get_vm_name(); console_set_vm_name(entry.name); capsule_vm_set_state(entry.vm_id, VM_STATE_LIVE); console_puts("START: entering "); console_println(entry.name); /* Run target's REPL — blocks until target->halted */ vm_state_push(vm); sk_repl_run(target); vm_state_pop(vm); /* Target halted (STOP or BYE) — restore caller's context */ capsule_vm_set_state(entry.vm_id, VM_STATE_STOPPED); console_set_vm_name(caller_name); console_puts("START: "); console_puts(entry.name); console_println(" stopped"); /* Stack clean on exit */ } /** * @brief STOP ( -- ) * Self-stop: set vm->halted so sk_repl_run() exits on the next iteration. * State is updated to VM_STATE_STOPPED by the START word after the REPL * returns. STOP is registered in every VM's dictionary (including children) * so any VM can stop itself. */ void mama_word_stop(VM *vm) { vm->halted = 1; /* sk_repl_run's while(!vm->halted) loop exits after this word returns */ } /** * @brief USE ( c-addr u -- ) * Redirect system-wide REPL input to a named VM without touching the C * call stack. The console prefix changes to [VMName]. * USE Hera (vm_id 0) resets dispatch to the default (Mama's VM, NULL slot). */ void mama_word_use(VM *vm) { char name_buf[VM_NAME_MAX]; VMRegistryEntry entry; uint32_t i; cell_t u, caddr; const char *src; if (vm->dsp < 1) { vm->error = 1; return; } u = vm_pop(vm); caddr = vm_pop(vm); if (u <= 0 || (uint32_t)u >= VM_NAME_MAX) { console_println("USE: name too long or empty"); return; } /* caddr is a VM address; S" ( -- c-addr u ) stores chars directly at caddr */ { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)u; i++) name_buf[i] = src[i]; name_buf[u] = '\0'; if (capsule_vm_find_by_name_nocase(name_buf, &entry) != 0) { console_puts("USE: "); console_puts(name_buf); console_println(" not found"); return; } if (entry.state == VM_STATE_DEAD || entry.state == VM_STATE_STILLBORN) { console_puts("USE: "); console_puts(name_buf); console_println(" dead/stillborn"); return; } /* Found live 2026-09-10: WIREBIND announces "attached and ready -- * USE it to begin" the moment the target VM is registered, but * vm_enable_interpreter() is a separate, later step of that same * birth sequence. USE redirecting here before that step lands means * the very next line typed hits vm_assert_interpreter_enabled() * inside vm_interpret() and calls host->panic() -- a hard, whole- * machine halt, not the per-session-recoverable fault path the REPL * loop otherwise gives a redirected VM. Refuse the redirect instead; * the caller can just retry USE a moment later once birth finishes. */ if (entry.vm_ptr && !((VM *)entry.vm_ptr)->interpreter_enabled) { console_puts("USE: "); console_puts(name_buf); console_println(" not ready yet -- still bootstrapping, try again"); return; } /* BINDSTEP (FABRIC-2.md §F.9/§F.24): if the target has a real * installed identity (WIREBIND set this at attach time), re-verify * it against whatever drive is CURRENTLY attached -- live, not * cached (decision 1: this is a rare, human-triggered, interactive * operation, the re-verify cost is a non-issue, and it avoids any * staleness question if a drive was swapped without a clean * detach). A target with installed=0 (Hera/Hermes/Artemis today, * or any VM WIREBIND never touched) stays freely targetable, no * check applied -- decision 2, preserves USE's existing behavior * exactly for VMs that were never in scope for this lock. */ if (entry.vm_ptr && ((VM *)entry.vm_ptr)->identity.installed) { struct blkio_dev *bdev = sk_repl_get_attached_blk_dev(); homeblocks_sig_t live_sig; VMIdentity live_identity; int ok = 0; if (bdev && homeblocks_sig_check(bdev, HOMEBLOCKS_SIG_START_FBLOCK, &live_sig) == HOMEBLOCKS_SIG_OK && capsule_wirebind_verify_cert(bdev, &live_sig, vm, &live_identity) == 0 && memcmp(live_identity.owner_pubkey, ((VM *)entry.vm_ptr)->identity.owner_pubkey, 32) == 0) { ok = 1; } if (!ok) { console_puts("USE: "); console_puts(name_buf); console_println(" refused -- no matching identity currently attached"); return; } } /* Hera — restore default dispatch (NULL = use REPL's own vm) */ if (vm_uuid_is_hera(entry.vm_id)) { sk_repl_set_active_vm((void *)0); } else { sk_repl_set_active_vm((VM *)entry.vm_ptr); } console_set_vm_name(entry.name); console_puts("USE: now using "); console_println(entry.name); /* Stack clean on exit */ } /** * @brief KILL ( c-addr u -- ) * Destroy a named VM unconditionally. Hera cannot be killed. * Idempotent: killing an already-dead VM is a no-op. */ void mama_word_kill(VM *vm) { char name_buf[VM_NAME_MAX]; uint32_t i; cell_t u, caddr; const char *src; if (vm->dsp < 1) { vm->error = 1; return; } u = vm_pop(vm); caddr = vm_pop(vm); if (u <= 0 || (uint32_t)u >= VM_NAME_MAX) { console_println("KILL: name too long or empty"); return; } /* caddr is a VM address; S" ( -- c-addr u ) stores chars directly at caddr */ { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)u; i++) name_buf[i] = src[i]; name_buf[u] = '\0'; /* Resolve vm_id and fan out its heat to survivors before the registry * entry is torn down -- capsule_vm_kill() only takes a name and * leaves no live entry to query afterward. Excludes Hera: her * self-referential parent_vm_id makes vm_physics_retire() treat her * as her own unreachable root and zero the fleet's entire heat sum, * before capsule_vm_kill()'s own Hera guard below ever runs. */ { VMRegistryEntry entry; if (capsule_vm_find_by_name_nocase(name_buf, &entry) == 0 && entry.state == VM_STATE_LIVE) { if (!vm_uuid_is_hera(entry.vm_id)) { vm_physics_retire(entry.vm_id); } /* FABRIC-2.md §F.10, real bug found and reported 2026-08-27, * fixed 2026-09-05: capsule_vm_kill() never touches * g_repl_active_vm -- killing the VM the console is currently * USE'd onto left it dangling (the REPL would fault on the * next command dispatched through it). EJECT/UNCLEAN * (capsule_wirebind.c) already reset-before-kill this way; * plain KILL's own call site never did. */ if (entry.vm_ptr && sk_repl_get_active_vm() == (VM *) entry.vm_ptr) { sk_repl_set_active_vm((VM *) 0); } } } capsule_vm_kill(name_buf); /* Stack clean on exit */ } /** * @brief EJECT ( -- ) * Graceful detach of whatever identity is currently attached via the * home-blocks USB path (FABRIC-2.md §F.10, extended §I.8 2026-09-04) -- * a regular WIREBIND user VM or Zuse herself, no identity handled any * differently. Single-USB-device constraint (§F.8) means there is only * ever one candidate, so at most one of the two calls below actually * does anything; the other is a no-op. capsule_wirebind_eject() flushes, * resets the console's active VM if bound to it, then kills a user VM; * capsule_zuse_boot_logout() clears zuse_session (no flush/kill -- Zuse * owns no separate VM or blocks of her own). */ void mama_word_eject(VM *vm) { capsule_wirebind_eject(); /* FABRIC-3.md §VII follow-on, 2026-09-06: capsule_zuse_boot_logout() * now requires the departing device to match the one tracked as * hers (the abrupt hot-unplug path's own fix) -- EJECT isn't reacting * to any specific device's detach event, so it passes her own tracked * device straight back in, which trivially matches when she's * genuinely attached and no-ops via the existing g_zuse_attached_ * this_device check otherwise. */ capsule_zuse_boot_logout(vm, capsule_zuse_boot_attached_dev()); /* Stack clean on exit */ } /** * @brief VM-STEP ( c-addr u -- ) * Give one REPL quantum to a named VM. * Prints the VM's prompt, reads one line, executes it, returns to caller. * This is the Compudynamics context-switch primitive — Hera yields one * REPL turn to the named VM without surrendering the outer loop. */ static void mama_word_vm_step(VM *vm) { char name_buf[VM_NAME_MAX]; uint32_t i; cell_t u, caddr; const char *src; VMRegistryEntry entry; VM *target; char saved_name[VM_NAME_MAX]; if (vm->dsp < 1) { vm->error = 1; return; } u = vm_pop(vm); caddr = vm_pop(vm); if (u <= 0 || (uint32_t)u >= VM_NAME_MAX) { console_println("VM-STEP: name too long or empty"); return; } { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)u; i++) name_buf[i] = src[i]; name_buf[u] = '\0'; if (capsule_vm_find_by_name_nocase(name_buf, &entry) != 0) { console_puts("VM-STEP: VM not found: "); console_println(name_buf); return; } target = (VM *)entry.vm_ptr; if (!target || entry.state == VM_STATE_DEAD || entry.state == VM_STATE_STILLBORN) { console_puts("VM-STEP: VM not available: "); console_println(name_buf); return; } vm_physics_touch(entry.vm_id); console_save_vm_name(saved_name, sizeof(saved_name)); console_set_vm_name(entry.name); sk_repl_step(target); console_set_vm_name(saved_name); /* Stack clean on exit */ } /** * @brief VM-EXEC ( cmd-caddr cmd-u vm-name-caddr vm-name-u -- ) * Inject a command string into a named VM and execute it immediately — * no readline, no blocking. This is the autonomous Compudynamics primitive: * Hera can drive a FORTH command into any child VM without surrendering the * outer loop. Console prefix is saved/restored around the call. * * Stack order: push cmd string first, then VM name. Example: * S" DOE-WORK" S" Hermes" VM-EXEC */ static void mama_word_vm_exec(VM *vm) { char vm_name[VM_NAME_MAX]; char cmd_buf[INPUT_BUFFER_SIZE]; uint32_t i; cell_t vm_u, vm_caddr, cmd_u, cmd_caddr; const char *src; VMRegistryEntry entry; VM *target; char saved_name[VM_NAME_MAX]; if (vm->dsp < 3) { vm->error = 1; return; } /* TOS: vm-name-u, vm-name-caddr, cmd-u, cmd-caddr */ vm_u = vm_pop(vm); vm_caddr = vm_pop(vm); cmd_u = vm_pop(vm); cmd_caddr = vm_pop(vm); if (vm_u <= 0 || (uint32_t)vm_u >= VM_NAME_MAX) { console_println("VM-EXEC: VM name too long or empty"); return; } if (cmd_u < 0 || (uint32_t)cmd_u >= INPUT_BUFFER_SIZE) { console_println("VM-EXEC: command too long"); return; } { const uint8_t *p = vm_ptr(vm, (vaddr_t)vm_caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)vm_u; i++) vm_name[i] = src[i]; vm_name[vm_u] = '\0'; { const uint8_t *p = vm_ptr(vm, (vaddr_t)cmd_caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)cmd_u; i++) cmd_buf[i] = src[i]; cmd_buf[cmd_u] = '\0'; if (capsule_vm_find_by_name_nocase(vm_name, &entry) != 0) { console_puts("VM-EXEC: VM not found: "); console_println(vm_name); return; } target = (VM *)entry.vm_ptr; if (!target || entry.state == VM_STATE_DEAD || entry.state == VM_STATE_STILLBORN) { console_puts("VM-EXEC: VM not available: "); console_println(vm_name); return; } vm_physics_touch(entry.vm_id); log_message(LOG_INFO, "VM-EXEC: '%s' -> '%s'", cmd_buf, vm_name); console_save_vm_name(saved_name, sizeof(saved_name)); console_set_vm_name(entry.name); vm_state_push(vm); vm_interpret(target, cmd_buf); vm_state_pop(vm); console_set_vm_name(saved_name); if (target->error) { console_puts("VM-EXEC: ERROR in "); console_println(vm_name); target->error = 0; } /* Stack clean on exit */ } /** * @brief VM-CALL ( cmd-caddr cmd-u vm-name-caddr vm-name-u -- n ) * Like VM-EXEC but pops one cell from the target VM's TOS and pushes * it onto the caller's stack after execution. Used for cross-VM * queries (e.g. HERMES-K in K-FLEET). Pushes 0 on error or empty * target stack and sets vm->error if target left nothing. */ static void mama_word_vm_call(VM *vm) { char vm_name[VM_NAME_MAX]; char cmd_buf[INPUT_BUFFER_SIZE]; uint32_t i; cell_t vm_u, vm_caddr, cmd_u, cmd_caddr; const char *src; VMRegistryEntry entry; VM *target; char saved_name[VM_NAME_MAX]; if (vm->dsp < 3) { vm->error = 1; return; } vm_u = vm_pop(vm); vm_caddr = vm_pop(vm); cmd_u = vm_pop(vm); cmd_caddr = vm_pop(vm); if (vm_u <= 0 || (uint32_t)vm_u >= VM_NAME_MAX) { console_println("VM-CALL: VM name too long or empty"); vm_push(vm, 0); return; } if (cmd_u < 0 || (uint32_t)cmd_u >= INPUT_BUFFER_SIZE) { console_println("VM-CALL: command too long"); vm_push(vm, 0); return; } { const uint8_t *p = vm_ptr(vm, (vaddr_t)vm_caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)vm_u; i++) vm_name[i] = src[i]; vm_name[vm_u] = '\0'; { const uint8_t *p = vm_ptr(vm, (vaddr_t)cmd_caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)cmd_u; i++) cmd_buf[i] = src[i]; cmd_buf[cmd_u] = '\0'; if (capsule_vm_find_by_name_nocase(vm_name, &entry) != 0) { console_puts("VM-CALL: VM not found: "); console_println(vm_name); vm_push(vm, 0); return; } target = (VM *)entry.vm_ptr; if (!target || entry.state == VM_STATE_DEAD || entry.state == VM_STATE_STILLBORN) { console_puts("VM-CALL: VM not available: "); console_println(vm_name); vm_push(vm, 0); return; } vm_physics_touch(entry.vm_id); log_message(LOG_DEBUG, "VM-CALL: '%s' -> '%s'", cmd_buf, vm_name); console_save_vm_name(saved_name, sizeof(saved_name)); console_set_vm_name(entry.name); vm_state_push(vm); vm_interpret(target, cmd_buf); vm_state_pop(vm); console_set_vm_name(saved_name); if (target->error) { console_puts("VM-CALL: ERROR in "); console_println(vm_name); target->error = 0; vm_push(vm, 0); return; } if (target->dsp >= 0) { vm_push(vm, vm_pop(target)); } else { console_println("VM-CALL: target left empty stack"); vm->error = 1; vm_push(vm, 0); } } /** * @brief VM-HEAT ( c-addr u -- heat-q48 ) * Push the named VM's current execution_heat_q48 (Q48.16, 0 if the VM is * unknown/dead), via vm_physics_heat_of() -- previously C-internal only * (doe_log_heat_by_name(), doe_log.c), never exposed to FORTH. Added * 2026-09-12 for a compudynamic turn-attractor (FABRIC-3.md §XIX): "whose * turn is next" decided by comparing live candidates' own current heat via * this word, the same density-comparison judgment stadium_admit() already * makes for eviction, rather than a fixed round-robin order. Silent on an * unknown name (returns 0, does not print/error) -- callers scanning many * VM names each turn to find the coolest one should not have to filter * console noise for names that are simply not currently live. */ static void mama_word_vm_heat(VM *vm) { char vm_name[VM_NAME_MAX]; uint32_t i; cell_t vm_u, vm_caddr; const char *src; VMRegistryEntry entry; if (vm->dsp < 1) { vm->error = 1; return; } vm_u = vm_pop(vm); vm_caddr = vm_pop(vm); if (vm_u <= 0 || (uint32_t)vm_u >= VM_NAME_MAX) { vm_push(vm, 0); return; } { const uint8_t *p = vm_ptr(vm, (vaddr_t)vm_caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)vm_u; i++) vm_name[i] = src[i]; vm_name[vm_u] = '\0'; if (capsule_vm_find_by_name_nocase(vm_name, &entry) != 0) { vm_push(vm, 0); return; } vm_push(vm, (cell_t)vm_physics_heat_of(entry.vm_id)); } /** * @brief MINT ( -- ok? ) * Mint a fresh identity onto the currently attached USB drive * (FABRIC-2.md §F.8/§F.19). Deliberately no name/string argument despite * F.8's original "S\" name\" MINT" sketch: this design never binds a VM * name at mint time -- the drive holds an anonymous, self-contained * identity, and a name is only assigned later, at RUNCAP birth (a * WIREBIND decision, not MINT's). Refuses cleanly (prints why) if * there's no attached drive, the drive already reads as a recognized * home-blocks drive, Zuse has no installed cert to sign with, or there's * no entropy source. Real, working code -- not the eventual Console * onboarding flow (§D.6), which will call this same C function. */ /* Pop one ( caddr u ) string pair and copy it, NUL-terminated, into * dst (capacity dst_cap). Returns 0 on success, -1 on underflow/bounds/ * unmapped-address failure (vm->error is set in that case). */ static int mint_pop_string(VM *vm, char *dst, size_t dst_cap) { if (vm->dsp < 1) { vm->error = 1; return -1; } cell_t u = vm_pop(vm); cell_t caddr = vm_pop(vm); if (u < 0 || (size_t)u >= dst_cap) { vm->error = 1; return -1; } if (u > 0) { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return -1; } memcpy(dst, p, (size_t)u); } dst[u] = '\0'; return 0; } /** * @brief MINT ( fname-c fname-u uname-c uname-u email-c email-u phone-c phone-u restrict? -- ok? ) * Mint a fresh identity onto the currently attached USB drive, with a * real human profile (FABRIC-2.md §F.20). full_name/username required * and non-empty; pass a zero-length string (S" ") for email/phone to * leave them null. restrict? nonzero mints with the FORTH-79/83-only * lockdown personality (MINT_PERSONALITY_STD79_LOCKDOWN, * capsules/acl-std79.4th applies the actual restriction at that VM's own * first birth) instead of the default, unrestricted one -- Captain Bob, * 2026-09-07: "give access only to FORTH 79 and 83 standard words, * everything else is locked down." */ static void mama_word_mint(VM *vm) { char phone[USER_IDENTITY_PHONE_MAX]; char email[USER_IDENTITY_EMAIL_MAX]; char username[USER_IDENTITY_USERNAME_MAX]; char full_name[USER_IDENTITY_FULL_NAME_MAX]; /* Stack order: fname pushed first, restrict? last -- pop in reverse. */ if (vm->dsp < 0) { vm->error = 1; return; } cell_t restrict_flag = vm_pop(vm); if (mint_pop_string(vm, phone, sizeof(phone)) != 0) return; if (mint_pop_string(vm, email, sizeof(email)) != 0) return; if (mint_pop_string(vm, username, sizeof(username)) != 0) return; if (mint_pop_string(vm, full_name, sizeof(full_name)) != 0) return; struct blkio_dev *dev = sk_repl_get_attached_blk_dev(); if (!dev) { console_println("MINT: no drive attached"); vm_push(vm, 0); return; } MintPersonality personality = restrict_flag ? MINT_PERSONALITY_STD79_LOCKDOWN : MINT_PERSONALITY_DEFAULT; MintResult r = capsule_mint_identity(dev, vm, full_name, username, email, phone, (uint8_t *)0, (uint8_t *)0, personality, 0 /* not pre-checked -- keep the safety check */); switch (r) { case MINT_OK: console_println("MINT: identity minted"); vm_push(vm, 1); return; case MINT_ERR_ALREADY_MINTED: console_println("MINT: refused -- drive already a recognized home-blocks drive"); break; case MINT_ERR_NO_ZUSE_CERT: console_println("MINT: refused -- Zuse has no installed cert to sign with"); break; case MINT_ERR_NO_ENTROPY: console_println("MINT: refused -- no entropy source"); break; case MINT_ERR_CERT_BUILD: console_println("MINT: FAILED -- cert construction error"); break; case MINT_ERR_WRITE_FAIL: console_println("MINT: FAILED -- devblock write error (drive may be partially minted)"); break; case MINT_ERR_INVALID_PROFILE: console_println("MINT: refused -- full_name/username missing or a field too long"); break; case MINT_ERR_VERIFY_FAILED: console_println("MINT: FAILED -- wrote identity but post-write verification failed " "(see log for which check)"); break; } vm_push(vm, 0); } /** * @brief ZUSE-ELIGIBILITY-ADD ( c-addr -- ok? ) * Add the 32-byte Ed25519 public key at c-addr to Zuse's elevation * eligibility list (FABRIC-2.md §H.5/§H.12 item 19). Plain, unconditional * primitive -- no authorization check here or anywhere else in this * codebase gates on vm->zuse_session. Zuse's authority is the *absence* * of any ACL restricting her, not a bit this or any other word checks; * restricting who may call this word, if ever wanted, is the same * standing word-level ACL mechanism (acl_allow/ACL-PIN in ACL.4th) any * other word would use, applied later if and when actually needed -- * not invented here. */ static void mama_word_zuse_eligibility_add(VM *vm) { if (vm->dsp < 0) { vm->error = 1; vm_push(vm, 0); return; } cell_t caddr = vm_pop(vm); const uint8_t *pubkey = vm_ptr(vm, (vaddr_t)caddr); if (!pubkey) { vm->error = 1; vm_push(vm, 0); return; } if (zuse_eligibility_add(pubkey) != 0) { console_println("ZUSE-ELIGIBILITY-ADD: FAILED -- fence write error"); vm_push(vm, 0); return; } vm_push(vm, 1); } /** * @brief ZUSE-ELIGIBLE? ( c-addr -- flag ) * Membership check over Zuse's elevation eligibility list (FABRIC-2.md * §H.5/§H.12 item 21). Plain, unconditional wrapper over * zuse_eligibility_is_member() -- same "no bespoke gate" convention as * ZUSE-ELIGIBILITY-ADD above; is_member() itself is already fail-closed. */ static void mama_word_zuse_eligible_query(VM *vm) { if (vm->dsp < 0) { vm->error = 1; vm_push(vm, 0); return; } cell_t caddr = vm_pop(vm); const uint8_t *pubkey = vm_ptr(vm, (vaddr_t)caddr); if (!pubkey) { vm->error = 1; vm_push(vm, 0); return; } vm_push(vm, zuse_eligibility_is_member(pubkey) ? -1 : 0); } /** * @brief NAME>XT ( c-addr u -- xt|0 ) * Dynamic dictionary lookup for a name already sitting in a data buffer * (e.g. a message payload's argument), as opposed to `FIND`/`'` which * parse the next word from the live input stream -- FIND itself is never * modified, per this project's standing rule; this is a separate, * mechanism-only primitive for the same lookup from a data-stack string. * Miss (word not found) is not an error: pushes 0, matching FIND's own * "miss is NOT an error" convention. */ static void mama_word_name_to_xt(VM *vm) { if (vm->dsp < 1) { vm->error = 1; vm_push(vm, 0); return; } cell_t u = vm_pop(vm); cell_t caddr = vm_pop(vm); if (u < 0 || u > 127) { vm_push(vm, 0); return; } const uint8_t *name = vm_ptr(vm, (vaddr_t)caddr); if (!name) { vm->error = 1; vm_push(vm, 0); return; } DictEntry *e = vm_find_word(vm, (const char *)name, (size_t)u); vm_push(vm, (cell_t)(uintptr_t)e); } /** * @brief ELEVATE-PUBKEY-UNPACK ( pk0 pk1 pk2 pk3 buf-addr -- ) * Reconstructs a 32-byte Ed25519 pubkey from 4 cells into the 32-byte * buffer at buf-addr, matching ZUSE-PUBKEY@'s own convention exactly: * chunk i (0..3) is the 8-byte little-endian encoding of pubkey bytes * [i*8 .. i*8+7] -- this is that packing's inverse, so a pubkey sent as * 4 cells (see common:messaging.4th's SEND-ELEVATE-REQUEST) round-trips * byte-exact regardless of any individual chunk's sign bit. */ static void mama_word_elevate_pubkey_unpack(VM *vm) { if (vm->dsp < 4) { vm->error = 1; return; } cell_t buf_addr = vm_pop(vm); cell_t pk[4]; for (int i = 3; i >= 0; i--) pk[i] = vm_pop(vm); uint8_t *buf = vm_ptr(vm, (vaddr_t)buf_addr); if (!buf) { vm->error = 1; return; } for (int i = 0; i < 4; i++) { uint64_t chunk = (uint64_t)pk[i]; for (int b = 0; b < 8; b++) { buf[i * 8 + b] = (uint8_t)(chunk >> (8 * b)); } } } /** * @brief RUNCAP-TEST ( caddr u -- ok? rc ) * Diagnostic-only word (FABRIC-2.md §F.6/§F.18): calls * capsule_runcap_birth() against whatever drive sk_repl_get_homeblocks_ * dev()/sig() currently report, naming the new VM from the given string. * Not the real RUNCAP call site -- that's WIREBIND (still unbuilt); this * exists to exercise capsule_runcap_birth() live before WIREBIND exists. * ok? is 1/0; rc is the raw CapsuleRunResult for diagnosis either way. */ static void mama_word_runcap_test(VM *vm) { char vm_name[VM_NAME_MAX]; cell_t u, caddr; uint32_t i; if (vm->dsp < 1) { vm->error = 1; return; } u = vm_pop(vm); caddr = vm_pop(vm); if (u <= 0 || (uint32_t)u >= VM_NAME_MAX) { console_println("RUNCAP-TEST: name too long or empty"); vm_push(vm, 0); vm_push(vm, (cell_t)CAPSULE_RUN_ERR_INVALID); return; } { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return; } for (i = 0; i < (uint32_t)u; i++) vm_name[i] = (char)p[i]; } vm_name[u] = '\0'; struct blkio_dev *dev = sk_repl_get_homeblocks_dev(); const homeblocks_sig_t *sig = sk_repl_get_homeblocks_sig(); if (!dev || !sig) { console_println("RUNCAP-TEST: no home-blocks drive attached"); vm_push(vm, 0); vm_push(vm, (cell_t)CAPSULE_RUN_ERR_INVALID); return; } VMUuid new_vm_id; CapsuleRunResult r = capsule_runcap_birth(dev, sig, vm_name, vm->stadium_vm_id, &new_vm_id, (void **)0); vm_push(vm, r == CAPSULE_RUN_OK ? 1 : 0); vm_push(vm, (cell_t)r); } /** * @brief PAIR-TEST ( caddr u -- ok? ) * Diagnostic-only word (FABRIC-2.md Phase F, 2026-08-28): births a * console VM (bare, capsule_console.h) named by the given string, and a * user VM (capsule_runcap_birth(), from whatever drive sk_repl_get_ * homeblocks_dev()/sig() currently report) named "~user" -- * the pairing convention sk_repl_dispatch_line() (repl.c) looks for. * Registers the pairing in the console's own VM-name routing table at * the fixed index (3) that relay uses. Not the real pairing call site * -- that's the eventual attach/onboarding flow; this exists to * exercise the console-VM + user-VM relay live before that exists. */ static void mama_word_pair_test(VM *vm) { char console_name[VM_NAME_MAX]; char user_name[VM_NAME_MAX + 8]; cell_t u, caddr; uint32_t i; if (vm->dsp < 1) { vm->error = 1; return; } u = vm_pop(vm); caddr = vm_pop(vm); if (u <= 0 || (uint32_t)u >= VM_NAME_MAX) { console_println("PAIR-TEST: name too long or empty"); vm_push(vm, 0); return; } { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return; } for (i = 0; i < (uint32_t)u; i++) console_name[i] = (char)p[i]; } console_name[u] = '\0'; memcpy(user_name, console_name, (size_t)u); memcpy(user_name + u, "~user", 6); /* includes NUL */ struct blkio_dev *dev = sk_repl_get_homeblocks_dev(); const homeblocks_sig_t *sig = sk_repl_get_homeblocks_sig(); if (!dev || !sig) { console_println("PAIR-TEST: no home-blocks drive attached"); vm_push(vm, 0); return; } VMUuid console_id, user_id; void *console_ctx = (void *)0; if (capsule_console_birth(console_name, vm->stadium_vm_id, &console_id, &console_ctx) != CAPSULE_RUN_OK) { console_println("PAIR-TEST: console birth FAILED"); vm_push(vm, 0); return; } if (capsule_runcap_birth(dev, sig, user_name, vm->stadium_vm_id, &user_id, (void **)0) != CAPSULE_RUN_OK) { console_println("PAIR-TEST: user birth FAILED"); vm_push(vm, 0); return; } /* Register the pairing in the console's own routing table, index 3 * -- the fixed convention sk_repl_dispatch_line()'s constructed * MSG-SEND text uses. */ { char reg_cmd[VM_NAME_MAX + 32]; int n = snprintf(reg_cmd, sizeof(reg_cmd), "S\" %s\" 3 VM-NAME-REG", user_name); if (n > 0 && (size_t)n < sizeof(reg_cmd)) { vm_interpret((VM *)console_ctx, reg_cmd); } } console_println("PAIR-TEST: console + user VM pair live"); vm_push(vm, 1); } /** * @brief CAPSULE-BIRTH ( capsule-id -- vm-id-hi vm-id-lo ) * Birth a baby VM from a production (p) capsule. * Returns the new VM's 128-bit ID as a double (item 3.8 -- FORTH already * has double-cell words for exactly this), high cell on top, or * vm_uuid_none()'s hi/lo (both all-ones) on failure. */ void mama_word_capsule_birth(VM *vm) { if (vm->dsp < 0) { vm->error = 1; return; } cell_t capsule_idx = vm_pop(vm); VMUuid new_vm_id = vm_uuid_none(); if ((uint64_t)capsule_idx >= capsule_get_desc_count()) { vm_push(vm, (cell_t)new_vm_id.lo); vm_push(vm, (cell_t)new_vm_id.hi); return; } const char *cap_name = capsule_get_names()[(uint32_t)capsule_idx].name; CapsuleRunResult result = capsule_birth_baby( cap_name, capsule_get_directory(), capsule_get_descriptors(), capsule_get_names(), capsule_get_arena(), vm->stadium_vm_id, /* §H.12 step 7: who is birthing this VM */ 0, /* skip_pki_sig: normal build-time capsule */ &new_vm_id, (void **)0 /* Don't need VM context back */ ); if (result != CAPSULE_RUN_OK) { new_vm_id = vm_uuid_none(); /* Birth failed */ } vm_push(vm, (cell_t)new_vm_id.lo); vm_push(vm, (cell_t)new_vm_id.hi); } /** * @brief CAPSULE-RUN ( capsule-id -- ) * Run an experiment (e) capsule on Mama. */ void mama_word_capsule_run(VM *vm) { if (vm->dsp < 0) { vm->error = 1; return; } cell_t capsule_idx = vm_pop(vm); if ((uint64_t)capsule_idx >= capsule_get_desc_count()) { vm->error = 1; return; } const char *cap_name = capsule_get_names()[(uint32_t)capsule_idx].name; /* Run experiment on Mama (this VM) */ capsule_run_experiment( vm, cap_name, capsule_get_directory(), capsule_get_descriptors(), capsule_get_names(), capsule_get_arena(), (uint64_t *)0 /* Don't need run_id back */ ); } /* ============================================================================ * VM Registry Words * ============================================================================ */ /** * @brief MAMA-VM-ID ( -- 0 0 ) * Push Mama's VM ID as a double (item 3.8): vm_uuid_hera() is all-zero, * so both cells are 0. High cell on top, matching CAPSULE-BIRTH. */ void mama_word_mama_vm_id(VM *vm) { vm_push(vm, 0); vm_push(vm, 0); } /** * @brief VM-COUNT ( -- n ) * Push number of registered VMs. */ void mama_word_vm_count(VM *vm) { vm_push(vm, (cell_t)capsule_vm_registry_count()); } /** * @brief VM-CONSERVED? ( -- flag ) * FORTH-79 boolean: TRUE (-1) if |fleet_heat_sum - Q.1| < epsilon, else * FALSE (0). Replaces fleet-k.4th's K-CONSERVED?. */ static void mama_word_vm_conserved(VM *vm) { vm_push(vm, vm_physics_conserved() ? (cell_t)-1 : (cell_t)0); } /** * @brief VM-PHYSICS-STATUS ( -- ) * Print the fleet physics diagnostic report. Replaces fleet-k.4th's * K-STATUS and compudynamics.4th's VM-STATUS. */ static void mama_word_vm_physics_status(VM *vm) { (void)vm; vm_physics_status(); } /* ============================================================================ * Diagnostic Words * ============================================================================ */ /** * @brief CAPSULE-TEST ( -- ) * Print diagnostic message confirming capsule system is active. */ void mama_word_capsule_test(VM *vm) { (void)vm; console_println("Mama FORTH Capsule System (M7.1)"); console_puts(" Capsules: "); console_println(""); console_puts(" VMs: "); console_println(""); } /* ============================================================================ * Vocabulary Registration * ============================================================================ */ /** * @brief EXEC ( c-addr u -- ) * Execute a named capsule in the current VM — same path as mama init auto-run. */ void mama_word_exec(VM *vm) { char name_buf[VM_NAME_MAX]; uint32_t i; cell_t u, caddr; const char *src; CapsuleRunResult result; int saved_dsp; int saved_rsp; if (vm->dsp < 1) { vm->error = 1; return; } u = vm_pop(vm); caddr = vm_pop(vm); if (u <= 0 || (uint32_t)u >= VM_NAME_MAX) { console_println("EXEC: name too long or empty"); return; } { const uint8_t *p = vm_ptr(vm, (vaddr_t)caddr); if (!p) { vm->error = 1; return; } src = (const char *)p; } for (i = 0; i < (uint32_t)u; i++) name_buf[i] = src[i]; name_buf[u] = '\0'; /* Save both stacks so a crashing capsule cannot corrupt the caller. * DSP: any partial pushes by the capsule are discarded. * RSP: DO-LOOP indices pushed by the caller (e.g. the DoE loop) are * preserved; a capsule that crashed mid->R/R> cannot corrupt them. */ saved_dsp = vm->dsp; saved_rsp = vm->rsp; log_message(LOG_INFO, "EXEC: capsule '%s'", name_buf); result = capsule_exec_init( vm, name_buf, capsule_get_directory(), capsule_get_descriptors(), capsule_get_names(), capsule_get_arena()); /* Restore stacks and clear error/exit flags so the DoE loop survives * a workload crash and continues cleanly to the next run. */ vm->dsp = saved_dsp; vm->rsp = saved_rsp; vm->error = 0; vm->exit_colon = 0; if (result != CAPSULE_RUN_OK) { console_puts("EXEC: failed: "); console_println(name_buf); } } /** * @brief CONNECT-ARTEMIS ( -- ) — Enter Artemis's REPL, birthing it first if needed. */ static void mama_word_connect_artemis(VM *vm) { VMRegistryEntry entry; VM *artemis; char saved_name[VM_NAME_MAX]; if (capsule_vm_find_by_name_nocase("Artemis", &entry) != 0 || entry.state == VM_STATE_DEAD || entry.state == VM_STATE_STILLBORN) { VMUuid new_vm_id = vm_uuid_none(); char saved[VM_NAME_MAX]; console_save_vm_name(saved, sizeof(saved)); CapsuleRunResult r; console_set_vm_name("Artemis"); r = capsule_birth_baby( "artemis:init.4th", capsule_get_directory(), capsule_get_descriptors(), capsule_get_names(), capsule_get_arena(), vm->stadium_vm_id, /* §H.12 step 7: who is birthing this VM */ 0, /* skip_pki_sig: normal build-time capsule */ &new_vm_id, (void **)0); console_set_vm_name(saved); if (r != CAPSULE_RUN_OK) { console_println("CONNECT-ARTEMIS: birth failed"); return; } capsule_vm_registry_set_name(new_vm_id, "Artemis"); if (capsule_vm_find_by_name_nocase("Artemis", &entry) != 0) { console_println("CONNECT-ARTEMIS: registry error"); return; } } artemis = (VM *)entry.vm_ptr; if (!artemis) { console_println("CONNECT-ARTEMIS: no VM pointer"); return; } console_save_vm_name(saved_name, sizeof(saved_name)); console_set_vm_name(entry.name); capsule_vm_set_state(entry.vm_id, VM_STATE_LIVE); sk_repl_run(artemis); capsule_vm_set_state(entry.vm_id, VM_STATE_STOPPED); console_set_vm_name(saved_name); } /** * @brief BYE ( -- ) — Hera-only: reap all children then cold-restart the machine. * * In child VMs this word is never registered; children use the standard * system_word_bye which sets vm->halted and returns to the parent's REPL. */ static void mama_word_bye(VM *vm __attribute__((unused))) { console_println("BYE: reaping children"); capsule_vm_kill_all_nonmama(); console_println("BYE: cold restart"); arch_cold_reset(); } /** * @brief CONNECT-HERMES ( -- ) — Enter Hermes's REPL, birthing it first if needed. * * Idempotent: if Hermes is already born (LIVE or STOPPED) it is entered * directly without re-birthing. On BYE from Hermes, control returns here. */ static void mama_word_connect_hermes(VM *vm) { VMRegistryEntry entry; VM *hermes; char saved_name[VM_NAME_MAX]; /* Birth if not found or previously dead/stillborn */ if (capsule_vm_find_by_name_nocase("Hermes", &entry) != 0 || entry.state == VM_STATE_DEAD || entry.state == VM_STATE_STILLBORN) { VMUuid new_vm_id = vm_uuid_none(); char saved[VM_NAME_MAX]; console_save_vm_name(saved, sizeof(saved)); CapsuleRunResult r; console_set_vm_name("Hermes"); r = capsule_birth_baby( "hermes:init.4th", capsule_get_directory(), capsule_get_descriptors(), capsule_get_names(), capsule_get_arena(), vm->stadium_vm_id, /* §H.12 step 7: who is birthing this VM */ 0, /* skip_pki_sig: normal build-time capsule */ &new_vm_id, (void **)0); console_set_vm_name(saved); if (r != CAPSULE_RUN_OK) { console_println("CONNECT-HERMES: birth failed"); return; } capsule_vm_registry_set_name(new_vm_id, "Hermes"); if (capsule_vm_find_by_name_nocase("Hermes", &entry) != 0) { console_println("CONNECT-HERMES: registry error"); return; } } hermes = (VM *)entry.vm_ptr; if (!hermes) { console_println("CONNECT-HERMES: no VM pointer"); return; } console_save_vm_name(saved_name, sizeof(saved_name)); console_set_vm_name(entry.name); capsule_vm_set_state(entry.vm_id, VM_STATE_LIVE); sk_repl_run(hermes); capsule_vm_set_state(entry.vm_id, VM_STATE_STOPPED); console_set_vm_name(saved_name); } /* Forward declarations: these 8 are defined later in this file (originally * only ever used from register_child_vm_words(), which comes after them), * but FABRIC-3.md SXX now also registers them here, earlier in the file. */ static void mama_word_stadium_admit(VM *vm); static void mama_word_stadium_evict(VM *vm); static void mama_word_stadium_res_fetch(VM *vm); static void mama_word_stadium_res_pull(VM *vm); static void mama_word_stadium_res_push(VM *vm); static void mama_word_stadium_heat_fetch(VM *vm); static void mama_word_stadium_heat_store(VM *vm); static void mama_word_stadium_word_heat(VM *vm); /** * @brief Register Mama FORTH vocabulary words with the VM * * Creates the MAMA vocabulary and registers all capsule-related words. * * @param vm Pointer to the VM instance */ void register_mama_forth_words(VM *vm) { /* Register words in FORTH vocabulary first */ register_word(vm, "BYE", mama_word_bye); register_word(vm, "CONNECT-HERMES", mama_word_connect_hermes); register_word(vm, "CONNECT-ARTEMIS", mama_word_connect_artemis); register_word(vm, "BIRTH", mama_word_birth); register_word(vm, "KILL", mama_word_kill); register_word(vm, "EJECT", mama_word_eject); register_word(vm, "START", mama_word_start); register_word(vm, "STOP", mama_word_stop); register_word(vm, "USE", mama_word_use); register_word(vm, "EXEC", mama_word_exec); register_word(vm, "CAPSULE-COUNT", mama_word_capsule_count); register_word(vm, "CAPSULE@", mama_word_capsule_fetch); register_word(vm, "CAPSULE-HASH@", mama_word_capsule_hash_fetch); register_word(vm, "CAPSULE-FLAGS@", mama_word_capsule_flags_fetch); register_word(vm, "CAPSULE-LEN@", mama_word_capsule_len_fetch); register_word(vm, "CAPSULE-BIRTH", mama_word_capsule_birth); register_word(vm, "CAPSULE-RUN", mama_word_capsule_run); register_word(vm, "MINT", mama_word_mint); register_word(vm, "ZUSE-ELIGIBILITY-ADD", mama_word_zuse_eligibility_add); register_word(vm, "ZUSE-ELIGIBLE?", mama_word_zuse_eligible_query); register_word(vm, "NAME>XT", mama_word_name_to_xt); register_word(vm, "ELEVATE-PUBKEY-UNPACK", mama_word_elevate_pubkey_unpack); register_word(vm, "RUNCAP-TEST", mama_word_runcap_test); register_word(vm, "PAIR-TEST", mama_word_pair_test); register_word(vm, "MAMA-VM-ID", mama_word_mama_vm_id); register_word(vm, "VM-COUNT", mama_word_vm_count); register_word(vm, "VM-CONSERVED?", mama_word_vm_conserved); register_word(vm, "VM-PHYSICS-STATUS", mama_word_vm_physics_status); register_word(vm, "VM-STEP", mama_word_vm_step); register_word(vm, "VM-EXEC", mama_word_vm_exec); register_word(vm, "VM-CALL", mama_word_vm_call); register_word(vm, "VM-HEAT", mama_word_vm_heat); /* FABRIC-3.md SXX: the 8 STADIUM-* primitives register_child_vm_words() * gives every other VM, added here too -- root cause of "Hera cannot * load common:messaging.4th" (kernel_main.c's old Phase C comment): * messaging.4th's own colon-definitions (MSG-HEAT@, CH-HEAT@, * MSG-COOL-ALL, MSG-TICK, etc.) reference these, and referencing an * undefined word during compilation silently drops the definition * rather than raising a compile error -- not a messaging bug, a * missing-primitive gap in Hera's own dictionary specifically. Fixed * by symmetry, not a special case: Hera's dictionary is now a proper * superset of every child VM's, plus her own extra privileges * (BIRTH, the capsule-repository words, MINT) -- not structurally * different from any other VM, just additionally privileged. */ register_word(vm, "STADIUM-ADMIT", mama_word_stadium_admit); register_word(vm, "STADIUM-EVICT", mama_word_stadium_evict); register_word(vm, "STADIUM-RES@", mama_word_stadium_res_fetch); register_word(vm, "STADIUM-RES-PULL", mama_word_stadium_res_pull); register_word(vm, "STADIUM-RES-PUSH", mama_word_stadium_res_push); register_word(vm, "STADIUM-HEAT@", mama_word_stadium_heat_fetch); register_word(vm, "STADIUM-HEAT!", mama_word_stadium_heat_store); register_word(vm, "STADIUM-WORD-HEAT", mama_word_stadium_word_heat); register_word(vm, "CAPSULE-TEST", mama_word_capsule_test); /* Create and switch to MAMA vocabulary */ vm_bootstrap_root_vocabulary(vm, "MAMA"); /* Re-register in MAMA vocabulary context */ register_word(vm, "BYE", mama_word_bye); register_word(vm, "CONNECT-HERMES", mama_word_connect_hermes); register_word(vm, "CONNECT-ARTEMIS", mama_word_connect_artemis); register_word(vm, "BIRTH", mama_word_birth); register_word(vm, "KILL", mama_word_kill); register_word(vm, "EJECT", mama_word_eject); register_word(vm, "START", mama_word_start); register_word(vm, "STOP", mama_word_stop); register_word(vm, "USE", mama_word_use); register_word(vm, "EXEC", mama_word_exec); register_word(vm, "CAPSULE-COUNT", mama_word_capsule_count); register_word(vm, "CAPSULE@", mama_word_capsule_fetch); register_word(vm, "CAPSULE-HASH@", mama_word_capsule_hash_fetch); register_word(vm, "CAPSULE-FLAGS@", mama_word_capsule_flags_fetch); register_word(vm, "CAPSULE-LEN@", mama_word_capsule_len_fetch); register_word(vm, "CAPSULE-BIRTH", mama_word_capsule_birth); register_word(vm, "CAPSULE-RUN", mama_word_capsule_run); register_word(vm, "MINT", mama_word_mint); register_word(vm, "ZUSE-ELIGIBILITY-ADD", mama_word_zuse_eligibility_add); register_word(vm, "ZUSE-ELIGIBLE?", mama_word_zuse_eligible_query); register_word(vm, "NAME>XT", mama_word_name_to_xt); register_word(vm, "ELEVATE-PUBKEY-UNPACK", mama_word_elevate_pubkey_unpack); register_word(vm, "RUNCAP-TEST", mama_word_runcap_test); register_word(vm, "PAIR-TEST", mama_word_pair_test); register_word(vm, "MAMA-VM-ID", mama_word_mama_vm_id); register_word(vm, "VM-COUNT", mama_word_vm_count); register_word(vm, "VM-CONSERVED?", mama_word_vm_conserved); register_word(vm, "VM-PHYSICS-STATUS", mama_word_vm_physics_status); register_word(vm, "VM-STEP", mama_word_vm_step); register_word(vm, "VM-EXEC", mama_word_vm_exec); register_word(vm, "VM-CALL", mama_word_vm_call); register_word(vm, "VM-HEAT", mama_word_vm_heat); /* FABRIC-3.md SXX: the 8 STADIUM-* primitives register_child_vm_words() * gives every other VM, added here too -- root cause of "Hera cannot * load common:messaging.4th" (kernel_main.c's old Phase C comment): * messaging.4th's own colon-definitions (MSG-HEAT@, CH-HEAT@, * MSG-COOL-ALL, MSG-TICK, etc.) reference these, and referencing an * undefined word during compilation silently drops the definition * rather than raising a compile error -- not a messaging bug, a * missing-primitive gap in Hera's own dictionary specifically. Fixed * by symmetry, not a special case: Hera's dictionary is now a proper * superset of every child VM's, plus her own extra privileges * (BIRTH, the capsule-repository words, MINT) -- not structurally * different from any other VM, just additionally privileged. */ register_word(vm, "STADIUM-ADMIT", mama_word_stadium_admit); register_word(vm, "STADIUM-EVICT", mama_word_stadium_evict); register_word(vm, "STADIUM-RES@", mama_word_stadium_res_fetch); register_word(vm, "STADIUM-RES-PULL", mama_word_stadium_res_pull); register_word(vm, "STADIUM-RES-PUSH", mama_word_stadium_res_push); register_word(vm, "STADIUM-HEAT@", mama_word_stadium_heat_fetch); register_word(vm, "STADIUM-HEAT!", mama_word_stadium_heat_store); register_word(vm, "STADIUM-WORD-HEAT", mama_word_stadium_word_heat); register_word(vm, "CAPSULE-TEST", mama_word_capsule_test); register_word(vm, "EXEC", mama_word_exec); /* Return to FORTH vocabulary */ vocabulary_word_forth(vm); vocabulary_word_definitions(vm); } /* ============================================================================ * Stadium Words (FABRIC-0.md punch list item 4.2) * * The entire C surface item 4.2 is permitted to add, per HERMES.md's * language constraint: all eight operate on the CALLING VM's own identity * (vm->stadium_vm_id) implicitly, never a FORTH-supplied vm-id. A * stack-passed vm-id could only ever be the caller's own (redundant) or * another VM's (stadium_admit()/stadium_evict() would refuse it via quota * isolation, except STADIUM-RES-PUSH, which has no such guard and would be * an outright heat-forgery primitive against another VM's reservoir). * Conservation is the invariant this item is verified against, so implicit * self is not an optimization -- it's the only version that can't break it. * * STADIUM-ADMIT does not itself pull the candidate's heat from the * reservoir -- that's STADIUM-RES-PULL's job, composed in FORTH by the * caller (e.g. a rewritten MSG-ALLOC): pull first, admit with the pulled * amount, and STADIUM-RES-PUSH it back if admission refuses. Mirrors * stadium_words.c's C-side Option B starter-grant pattern, but the * composition itself lives in StarForth, not here, per HERMES.md. * ============================================================================ */ /** * @brief STADIUM-ADMIT ( identity heat behaviour -- cell | -1 ) * Admits a mass-1 patron into the calling VM's own Stadium quota. * `behaviour` must be a valid StadiumBehaviour tag (0..3); anything else * refuses without calling stadium_admit() at all. `contains` is always * explicitly STADIUM_CONTAINS_NONE -- stadium_admit()'s own doc warns a * zero-initialized `contains` reads as "contains Hera" (index 0) and * permanently blocks eviction, so this is never left to a zero-fill. */ static void mama_word_stadium_admit(VM *vm) { cell_t behaviour_cell, heat_cell, identity_cell; StadiumPatronHeader candidate; uint8_t *raw = (uint8_t *)&candidate; size_t i; size_t idx; if (vm->dsp < 2) { vm->error = 1; return; } behaviour_cell = vm_pop(vm); heat_cell = vm_pop(vm); identity_cell = vm_pop(vm); if (behaviour_cell < STADIUM_BEHAVIOUR_MIGRATE || behaviour_cell > STADIUM_BEHAVIOUR_COOL) { vm_push(vm, (cell_t)-1); return; } for (i = 0; i < sizeof(candidate); i++) raw[i] = 0; candidate.identity = (uint64_t)identity_cell; candidate.heat = (uint64_t)heat_cell; candidate.ttl = 0; candidate.link = 0; candidate.contains = STADIUM_CONTAINS_NONE; candidate.mass = 1; candidate.flags = 0; candidate.behaviour = (uint8_t)behaviour_cell; idx = stadium_admit(vm->stadium_vm_id, &candidate); vm_push(vm, (idx == STADIUM_CELL_NONE) ? (cell_t)-1 : (cell_t)idx); } /** * @brief STADIUM-EVICT ( cell -- flag ) * Reaps the patron header at `cell`. flag is FORTH true (-1) on success, * false (0) if refused (out of range, not resident, pinned, or contains- * gated) -- stadium_evict()'s own refusal set, unchanged here. */ static void mama_word_stadium_evict(VM *vm) { cell_t cell_cell; if (vm->dsp < 0) { vm->error = 1; return; } cell_cell = vm_pop(vm); if (cell_cell < 0) { vm_push(vm, (cell_t)0); return; } vm_push(vm, (stadium_evict((size_t)cell_cell) == 0) ? (cell_t)-1 : (cell_t)0); } /** * @brief STADIUM-RES@ ( -- heat ) * Read-only peek at the calling VM's own reservoir balance (Q48.16). */ static void mama_word_stadium_res_fetch(VM *vm) { vm_push(vm, (cell_t)stadium_reservoir_peek(vm->stadium_vm_id)); } /** * @brief STADIUM-WORD-HEAT ( -- heat ) * Sum of heat held by the calling VM's own word-execution residents * (item 4.1's cells) -- the term a VM's own application-level conservation * check (e.g. Hermes's HERMES-K) needs to close exactly, since word patrons * are otherwise invisible to FORTH (FABRIC-0.md §25.7, ruling 2026-08-06). */ static void mama_word_stadium_word_heat(VM *vm) { vm_push(vm, (cell_t)stadium_words_resident_heat(vm->stadium_vm_id)); } /** * @brief STADIUM-RES-PULL ( qty -- heat ) * Pulls up to `qty` (Q48.16) from the calling VM's own reservoir. Returns * the amount actually pulled, which may be less than requested -- never * negative, never invents heat, mirrors stadium_reservoir_pull()'s own * clamping exactly. */ static void mama_word_stadium_res_pull(VM *vm) { cell_t qty_cell; if (vm->dsp < 0) { vm->error = 1; return; } qty_cell = vm_pop(vm); if (qty_cell < 0) { vm_push(vm, (cell_t)0); return; } vm_push(vm, (cell_t)stadium_reservoir_pull(vm->stadium_vm_id, (uint64_t)qty_cell)); } /** * @brief STADIUM-RES-PUSH ( heat -- ) * Credits `heat` (Q48.16) back into the calling VM's own reservoir -- the * other half of every reservoir transfer (cooling, refused-admission * rollback, or a departing patron's remaining heat after eviction). */ static void mama_word_stadium_res_push(VM *vm) { cell_t heat_cell; if (vm->dsp < 0) { vm->error = 1; return; } heat_cell = vm_pop(vm); if (heat_cell < 0) return; stadium_reservoir_push(vm->stadium_vm_id, (uint64_t)heat_cell); } /** * @brief STADIUM-HEAT@ ( cell -- heat ) * Reads a resident cell's own heat. Requires the cell to be resident and * owned by the calling VM's own quota -- returns 0 otherwise (out of range, * not resident, or belongs to a different VM). */ static void mama_word_stadium_heat_fetch(VM *vm) { cell_t cell_cell; if (vm->dsp < 0) { vm->error = 1; return; } cell_cell = vm_pop(vm); if (cell_cell < 0) { vm_push(vm, (cell_t)0); return; } vm_push(vm, (cell_t)stadium_cell_heat_get(vm->stadium_vm_id, (size_t)cell_cell)); } /** * @brief STADIUM-HEAT! ( new-heat cell -- ) * Writes a resident cell's own heat, reconciling the reservoir delta * atomically in C (pulls on an increase, refusing silently if the * calling VM's reservoir can't cover it; pushes back on a decrease). * Requires the cell to be resident and owned by the calling VM's own * quota -- silently refused otherwise, same as every other write here. */ static void mama_word_stadium_heat_store(VM *vm) { cell_t cell_cell, new_heat_cell; if (vm->dsp < 1) { vm->error = 1; return; } cell_cell = vm_pop(vm); new_heat_cell = vm_pop(vm); if (cell_cell < 0 || new_heat_cell < 0) return; (void)stadium_cell_heat_set(vm->stadium_vm_id, (size_t)cell_cell, (uint64_t)new_heat_cell); } /** * register_child_vm_words - Register the minimal word set needed by child VMs. * * Child VMs are not bootstrapped through sk_vm_bootstrap_parity, so they * do not get register_mama_forth_words(). They only need STOP (self-halt) * and EXEC (load a capsule) -- plus, as of item 4.2, the eight STADIUM-* * primitives Hermes needs to migrate her message/channel lifecycle onto the * Stadium. Keeping the registrations here — in the same translation unit * as the word functions — avoids cross-TU function-pointer loads that * produce R_X86_64_REX_GOTPCRELX relocations; those are not relaxed by the * PE32+ linker, causing the function code bytes to be read as the pointer * value instead of the actual address. * * Deliberately NOT added to register_mama_forth_words(): that would put * these words in Hera's own dictionary too and move dict_hash off item * 4.1's baseline (0x3d4e1daf289da94f) -- a deliberate baseline change to * state this item does not make as a side effect. */ void register_child_vm_words(VM *vm) { register_word(vm, "STOP", mama_word_stop); register_word(vm, "EXEC", mama_word_exec); register_word(vm, "VM-EXEC", mama_word_vm_exec); register_word(vm, "VM-CALL", mama_word_vm_call); register_word(vm, "VM-HEAT", mama_word_vm_heat); /* USE (FABRIC-2.md §F.24): not console-specific -- any VM can * redirect the physical REPL to any other VM it has ACL access to * (BINDSTEP re-verifies on every call, §F.9), including a console * VM switching back to Hera or to a different session entirely. * mama_word_use() itself is already VM-agnostic (sk_repl_set_ * active_vm() is a plain C global, capsule_vm_find_by_name_nocase() * likewise) -- this was simply never registered here before. */ register_word(vm, "USE", mama_word_use); register_word(vm, "STADIUM-ADMIT", mama_word_stadium_admit); register_word(vm, "STADIUM-EVICT", mama_word_stadium_evict); register_word(vm, "STADIUM-RES@", mama_word_stadium_res_fetch); register_word(vm, "STADIUM-RES-PULL", mama_word_stadium_res_pull); register_word(vm, "STADIUM-RES-PUSH", mama_word_stadium_res_push); register_word(vm, "STADIUM-HEAT@", mama_word_stadium_heat_fetch); register_word(vm, "STADIUM-HEAT!", mama_word_stadium_heat_store); register_word(vm, "STADIUM-WORD-HEAT", mama_word_stadium_word_heat); /* FABRIC-3.md SXXV (2026-09-12): BIRTH/CAPSULE-BIRTH were Hera-only by * registration alone -- both mama_word_birth() and mama_word_capsule_ * birth() were already genuinely VM-agnostic underneath (the latter * explicitly passes vm->stadium_vm_id, "who is birthing this VM," not * a hardcoded Hera constant -- confirmed by reading the C before * assuming it). Symmetric registration alone can't weaken any * personality's own ACL lockdown: acl-std79.4th's ACL-LOCKDOWN-STD79 * is allowlist-based, deny-by-default -- it walks the WHOLE * dictionary and denies+pins anything not on ACL-STD79-LIST, so a * newly-registered word is auto-denied there unless a human * deliberately adds it (which acl-std79.4th now does, explicitly, * for exactly these two -- see its own updated comment). */ register_word(vm, "BIRTH", mama_word_birth); register_word(vm, "CAPSULE-BIRTH", mama_word_capsule_birth); } #endif /* __STARKERNEL__ */