narju/floor/

mod.rs

pub mod host;
pub mod machine;
pub mod read;

use std::collections::HashMap;
use std::fmt;

use smol_str::SmolStr;

pub use std::sync::Arc as Shared;

pub use host::Atom;

pub type RcExp = Shared<Exp>;

/// A newtype so the drop can be iterative: lists are unbounded in depth and
/// derived glue overflows. On the pointer, since on `Val` it would forbid
/// destructuring.
#[derive(Clone)]
pub struct RcVal(Shared<Val>);

impl RcVal {
    pub fn new(v: Val) -> RcVal {
        RcVal(Shared::new(v))
    }

    /// Other threads only push the count up, so a low reading is a fact about
    /// this graph rather than a race.
    pub fn refs(&self) -> usize {
        Shared::strong_count(&self.0)
    }

    pub fn unwrap_or_clone(mut self) -> Val {
        match Shared::get_mut(&mut self.0) {
            Some(v) => std::mem::replace(v, Val::Nil),
            None => Val::clone(&self.0),
        }
    }
}

/// `Code` and `Clo` are not walked: they hold an [`Exp`], which detaches
/// itself.
fn detach(slot: &mut Shared<Val>, out: &mut Vec<RcVal>) {
    // `get_mut` costs a compare-exchange; most drops are not of the last
    // reference, so filter on a plain load first.
    if Shared::strong_count(slot) != 1 {
        return;
    }
    let Some(v) = Shared::get_mut(slot) else {
        return;
    };
    if !matches!(v, Val::Pair(_, _) | Val::Raise(_)) {
        return;
    }
    // Swapping the value out of the allocation rather than the allocation out
    // of the slot is what keeps this allocation-free.
    let (a, b) = match std::mem::replace(v, Val::Nil) {
        Val::Pair(a, b) => (a, Some(b)),
        Val::Raise(a) => (a, None),
        _ => unreachable!("guarded above"),
    };
    for c in std::iter::once(a).chain(b) {
        if matches!(&*c, Val::Pair(_, _) | Val::Raise(_)) {
            out.push(c);
        }
    }
}

impl Drop for RcVal {
    fn drop(&mut self) {
        let mut stack: Vec<RcVal> = Vec::new();
        detach(&mut self.0, &mut stack);
        while let Some(mut rc) = stack.pop() {
            // `rc` drops holding a leaf, so the recursion stops one deep.
            detach(&mut rc.0, &mut stack);
        }
    }
}

impl std::ops::Deref for RcVal {
    type Target = Val;
    #[inline]
    fn deref(&self) -> &Val {
        &self.0
    }
}

impl From<Val> for RcVal {
    fn from(v: Val) -> RcVal {
        RcVal::new(v)
    }
}

impl AsRef<Val> for RcVal {
    #[inline]
    fn as_ref(&self) -> &Val {
        &self.0
    }
}

impl PartialEq for RcVal {
    fn eq(&self, other: &RcVal) -> bool {
        Shared::ptr_eq(&self.0, &other.0) || **self == **other
    }
}

impl fmt::Debug for RcVal {
    fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result {
        fmt::Debug::fmt(&**self, f)
    }
}

impl fmt::Display for RcVal {
    fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result {
        fmt::Display::fmt(&**self, f)
    }
}

/// The value graph crosses worker threads. An `Rc` or bare `Cell` slipping
/// into these fails the build rather than surfacing at runtime.
const _: fn() = || {
    fn assert_send_sync<T: Send + Sync>() {}
    assert_send_sync::<Exp>();
    assert_send_sync::<Val>();
    assert_send_sync::<Env>();
};

/// Grouped under one variant because every member obeys the same staging rule
/// (residualize if the argument is `Code`, otherwise compute), so the
/// specializer states that rule once.
#[derive(Debug, Clone, Copy, PartialEq, Eq)]
pub enum Prim1 {
    Car,
    Cdr,
    IsNum,
    IsSym,
    IsNil,
    IsPair,

    CellNew,
    CellRead,

    Spawn,
    /// Unary because the floor is; the argument is ignored.
    Receive,
    Monitor,
    /// Not sugar: a turn ends wherever the step budget runs out, so a separate
    /// `spawn` and `monitor` can be parted by it, letting the child die before
    /// the watch registers and the watcher hear `noproc` rather than the cause.
    SpawnMonitor,

    /// The two exceptions to the staging rule above. A raise reaches these
    /// rather than propagating past them, and neither residualizes - which is
    /// what folds an interpreter's raise test away during compilation, leaving
    /// the emitted code to get the floor's own discipline instead.
    IsRaise,
    RaiseValue,

    /// Applying a code operator commits to the floor's calling convention,
    /// sound only for functions the floor lifted itself. Scoped per region.
    IsCodeFun,
}

#[derive(Debug, Clone, Copy, PartialEq, Eq)]
pub enum Prim2 {
    Cons,
    Plus,
    Minus,
    Times,
    Div,
    Mod,
    Lt,
    Eq,

    CellSet,
    Send,
    /// Imposed from outside because a task whose tower diverges cannot report
    /// its own failure - reporting requires evaluating. Off by default.
    LimitTurns,
}

impl Prim1 {
    const NAMES: [(Prim1, &'static str); 15] = [
        (Prim1::Car, "car"),
        (Prim1::Cdr, "cdr"),
        (Prim1::IsNum, "num?"),
        (Prim1::IsSym, "sym?"),
        (Prim1::IsNil, "nil?"),
        (Prim1::IsPair, "pair?"),
        (Prim1::CellNew, "cell-new"),
        (Prim1::CellRead, "cell-read"),
        (Prim1::Spawn, "spawn"),
        (Prim1::Receive, "receive"),
        (Prim1::Monitor, "monitor"),
        (Prim1::SpawnMonitor, "spawn-monitor"),
        (Prim1::IsRaise, "raise?"),
        (Prim1::RaiseValue, "raise-value"),
        (Prim1::IsCodeFun, "code-fun?"),
    ];

    pub fn from_name(s: &str) -> Option<Prim1> {
        Prim1::NAMES.iter().find(|(_, n)| *n == s).map(|(p, _)| *p)
    }

    pub fn name(self) -> &'static str {
        Prim1::NAMES
            .iter()
            .find_map(|(p, n)| (*p == self).then_some(*n))
            .expect("every primitive is named")
    }

    /// Distinguishes what may be folded or shared from what may only be
    /// residualized in place.
    pub fn pure(self) -> bool {
        !matches!(
            self,
            Prim1::CellNew
                | Prim1::CellRead
                | Prim1::Spawn
                | Prim1::Receive
                | Prim1::Monitor
                | Prim1::SpawnMonitor
        )
    }
}

impl Prim2 {
    const NAMES: [(Prim2, &'static str); 11] = [
        (Prim2::Cons, "cons"),
        (Prim2::Plus, "+"),
        (Prim2::Minus, "-"),
        (Prim2::Times, "*"),
        (Prim2::Div, "/"),
        (Prim2::Mod, "%"),
        (Prim2::Lt, "<"),
        (Prim2::Eq, "eq?"),
        (Prim2::CellSet, "cell-set!"),
        (Prim2::Send, "send"),
        (Prim2::LimitTurns, "limit-turns"),
    ];

    pub fn from_name(s: &str) -> Option<Prim2> {
        Prim2::NAMES.iter().find(|(_, n)| *n == s).map(|(p, _)| *p)
    }

    pub fn name(self) -> &'static str {
        Prim2::NAMES
            .iter()
            .find_map(|(p, n)| (*p == self).then_some(*n))
            .expect("every primitive is named")
    }

    pub fn pure(self) -> bool {
        !matches!(self, Prim2::CellSet | Prim2::Send | Prim2::LimitTurns)
    }
}

#[derive(Debug, Clone, PartialEq)]
pub enum Exp {
    Lit(i64),
    /// In the core rather than behind [`host`] because boxing a
    /// register-sized scalar is not a constant factor. Costs one match arm.
    Flo(f64),
    Sym(SmolStr),
    Atom(Atom),
    Nil,
    /// De Bruijn index, counted from the outermost binding
    Var(usize),
    /// Binds its own name and then `arity` parameters, so the body sees
    /// `arity + 1` bindings. A closure carries this node rather than just the
    /// body, which is how the arity reaches the call.
    Lam(u16, RcExp),
    App(RcExp, Box<[RcExp]>),
    /// Application at an arity not known until the call: the operands arrive
    /// as a list value rather than as syntax, which is what an n-ary
    /// interpreter has, and [`Exp::App`] fixes its arity when it is read.
    Apply(RcExp, RcExp),
    Let(RcExp, RcExp),
    If(RcExp, RcExp, RcExp),

    Prim1(Prim1, RcExp),
    Prim2(Prim2, RcExp, RcExp),
    /// A call into the host op table, resolved to an index by the reader
    Op(u16, Vec<RcExp>),

    Lift(RcExp),
    /// Eta-expand at a *stated* arity, since an interpreter compiling an object
    /// function has no floor closure to take one from. Variables as a list,
    /// self first.
    LiftFun(RcExp, RcExp),
    /// Cross-stage persistence: carry a value into the next stage by
    /// reference rather than by structure
    LiftRef(RcExp, RcExp),
    /// A persisted value, the residue of [`Exp::LiftRef`]. Syntax that is
    /// not syntax: it holds a value the next stage may only pass along.
    Proc(RcVal),
    Run(RcExp, RcExp),
    IsCode(RcExp, RcExp),

    /// The one way to animate code compiled against a scope other than the
    /// current one, which is what loading a module amounts to.
    Evalms(RcExp, RcExp),

    Catch(RcExp),
    Throw(RcExp),
}

impl Exp {
    /// The only place a new variant has to be remembered: `Drop`,
    /// `count_nodes` and the specializer's walk all read this.
    fn children(&self) -> ([Option<&RcExp>; 3], &[RcExp]) {
        const NONE: [Option<&RcExp>; 3] = [None, None, None];
        match self {
            Exp::Lit(_)
            | Exp::Flo(_)
            | Exp::Sym(_)
            | Exp::Atom(_)
            | Exp::Nil
            | Exp::Var(_)
            | Exp::Proc(_) => (NONE, &[]),
            Exp::Lam(_, a) | Exp::Prim1(_, a) | Exp::Lift(a) | Exp::Catch(a) | Exp::Throw(a) => {
                ([Some(a), None, None], &[])
            }
            Exp::Let(a, b)
            | Exp::Apply(a, b)
            | Exp::LiftFun(a, b)
            | Exp::Prim2(_, a, b)
            | Exp::LiftRef(a, b)
            | Exp::Run(a, b)
            | Exp::IsCode(a, b)
            | Exp::Evalms(a, b) => ([Some(a), Some(b), None], &[]),
            Exp::If(c, t, e) => ([Some(c), Some(t), Some(e)], &[]),
            Exp::App(f, args) => ([Some(f), None, None], args.as_ref()),
            Exp::Op(_, args) => (NONE, args.as_slice()),
        }
    }

    pub fn iter_children(&self) -> impl Iterator<Item = &RcExp> {
        let (slots, rest) = self.children();
        slots.into_iter().flatten().chain(rest)
    }
}

/// Deep trees are ordinary in staged output, so recursive drop glue would
/// overflow on residuals the specializer routinely produces.
impl Drop for Exp {
    fn drop(&mut self) {
        let mut stack: Vec<RcExp> = Vec::new();
        take_children(self, &mut stack);
        while let Some(rc) = stack.pop() {
            if let Ok(mut e) = RcExp::try_unwrap(rc) {
                take_children(&mut e, &mut stack);
            }
        }
    }
}

fn take_children(e: &mut Exp, out: &mut Vec<RcExp>) {
    let mut grab = |slot: &mut RcExp| out.push(std::mem::replace(slot, rc_exp(Exp::Nil)));
    match e {
        Exp::Lit(_)
        | Exp::Flo(_)
        | Exp::Sym(_)
        | Exp::Atom(_)
        | Exp::Nil
        | Exp::Var(_)
        | Exp::Proc(_) => {}
        Exp::Op(_, args) => out.append(args),
        Exp::Lam(_, a) | Exp::Prim1(_, a) | Exp::Lift(a) | Exp::Catch(a) | Exp::Throw(a) => grab(a),
        Exp::App(f, args) => {
            grab(f);
            for slot in args.iter_mut() {
                grab(slot);
            }
        }
        Exp::Let(a, b)
        | Exp::Apply(a, b)
        | Exp::LiftFun(a, b)
        | Exp::Prim2(_, a, b)
        | Exp::LiftRef(a, b)
        | Exp::Run(a, b)
        | Exp::IsCode(a, b)
        | Exp::Evalms(a, b) => {
            grab(a);
            grab(b);
        }
        Exp::If(c, t, f) => {
            grab(c);
            grab(t);
            grab(f);
        }
    }
}

pub fn count_nodes(e: &Exp) -> usize {
    let mut count = 0usize;
    let mut stack: Vec<&Exp> = vec![e];
    while let Some(node) = stack.pop() {
        count += 1;
        stack.extend(node.iter_children().map(|c| c.as_ref()));
    }
    count
}

#[derive(Debug, Clone)]
pub enum Val {
    Num(i64),
    Flo(f64),
    Sym(SmolStr),
    /// A host value. Opaque to the floor, data to a channel.
    Atom(Atom),
    Nil,
    Pair(RcVal, RcVal),
    Clo(Env, RcExp),
    Code(RcExp),
    /// Index into the heap's cell arena
    Cell(usize),
    /// A value, not a fault, so it survives being returned - `attempt` must
    /// observe one without a floor frame, which would delimit a suspension.
    /// Propagates where a value is inspected, inert where it is only bound.
    Raise(RcVal),
}

pub fn raise(v: Val) -> Val {
    Val::Raise(rc_val(v))
}

impl PartialEq for Val {
    /// A shared allocation is skipped rather than walked, so two large values
    /// cost their difference. The specializer's occurs check depends on it.
    fn eq(&self, other: &Self) -> bool {
        let mut work: Vec<(&RcVal, &RcVal)> = Vec::new();
        let (mut a, mut b) = (self, other);
        loop {
            match (a, b) {
                (Val::Num(x), Val::Num(y)) if x == y => {}
                (Val::Flo(x), Val::Flo(y)) if x == y => {}
                (Val::Sym(x), Val::Sym(y)) if x == y => {}
                (Val::Atom(x), Val::Atom(y)) if x == y => {}
                (Val::Nil, Val::Nil) => {}
                (Val::Cell(x), Val::Cell(y)) if x == y => {}
                (Val::Pair(x1, x2), Val::Pair(y1, y2)) => {
                    work.push((x1, y1));
                    work.push((x2, y2));
                }
                (Val::Raise(x), Val::Raise(y)) => work.push((x, y)),
                (Val::Code(x), Val::Code(y)) | (Val::Clo(_, x), Val::Clo(_, y)) => {
                    if !ptr_eq(x, y) && x != y {
                        return false;
                    }
                }
                _ => return false,
            }
            loop {
                match work.pop() {
                    None => return true,
                    Some((x, y)) if ptr_eq(&x.0, &y.0) => {}
                    Some((x, y)) => {
                        (a, b) = (x, y);
                        break;
                    }
                }
            }
        }
    }
}

#[inline]
pub fn rc_exp(e: Exp) -> RcExp {
    RcExp::new(e)
}

#[inline]
pub fn rc_val(v: Val) -> RcVal {
    RcVal::new(v)
}

#[inline]
pub fn ptr_eq<T: ?Sized>(a: &Shared<T>, b: &Shared<T>) -> bool {
    Shared::ptr_eq(a, b)
}

#[inline]
pub fn pair(a: Val, b: Val) -> Val {
    Val::Pair(rc_val(a), rc_val(b))
}

#[inline]
pub fn code(e: Exp) -> Val {
    Val::Code(rc_exp(e))
}

pub fn list(items: &[Val]) -> Val {
    items.iter().rev().fold(Val::Nil, |t, h| pair(h.clone(), t))
}

pub fn list_elements(v: &Val) -> Option<Vec<Val>> {
    let mut out = Vec::new();
    let mut cur = v;
    loop {
        match cur {
            Val::Nil => return Some(out),
            Val::Pair(h, t) => {
                out.push((**h).clone());
                cur = t;
            }
            _ => return None,
        }
    }
}

/// A persistent spine of chunks, each owning `[base, base + vals.len())`.
/// Extending a shared one links rather than copies: applying a closure always
/// shares its environment, so a flat copy-on-write vector copied every call.
#[derive(Clone)]
pub struct Env(Shared<EnvChunk>);

/// Shape only: printing the bindings recurses through every closure they
/// hold, burying whatever the caller was trying to read.
impl fmt::Debug for Env {
    fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result {
        write!(f, "Env(len={})", self.len())
    }
}

struct EnvChunk {
    parent: Option<Env>,
    base: usize,
    vals: Vec<Val>,
}

impl Env {
    pub fn new(vals: Vec<Val>) -> Env {
        Env(Shared::new(EnvChunk {
            parent: None,
            base: 0,
            vals,
        }))
    }

    pub fn len(&self) -> usize {
        self.0.base + self.0.vals.len()
    }

    pub fn is_empty(&self) -> bool {
        self.len() == 0
    }

    pub fn get(&self, i: usize) -> Option<&Val> {
        let mut cur = self;
        loop {
            let chunk = &*cur.0;
            if i >= chunk.base {
                return chunk.vals.get(i - chunk.base);
            }
            cur = chunk.parent.as_ref()?;
        }
    }

    /// Yields bindings in de Bruijn order. Each step re-walks the spine, so
    /// this is for cold paths (structural equality, printing) only.
    pub fn iter(&self) -> impl Iterator<Item = &Val> + '_ {
        (0..self.len()).map(|i| self.get(i).expect("index below len"))
    }

    pub fn ptr_eq(a: &Env, b: &Env) -> bool {
        Shared::ptr_eq(&a.0, &b.0)
    }

    fn link(self, val: Val) -> Env {
        let base = self.len();
        Env(Shared::new(EnvChunk {
            parent: Some(self),
            base,
            vals: vec![val],
        }))
    }

    /// Always links: the caller holds only a borrow, so the existing chunk may
    /// not be disturbed.
    pub fn push(&self, val: Val) -> Env {
        Env::clone(self).link(val)
    }

    /// A whole frame at once. Entering a closure binds self and arguments
    /// together, and a push apiece regrows the vector once per binding.
    pub fn frame(self, vals: Vec<Val>) -> Env {
        let base = self.len();
        Env(Shared::new(EnvChunk {
            parent: Some(self),
            base,
            vals,
        }))
    }

    pub fn push_owned(mut self, val: Val) -> Env {
        match Shared::get_mut(&mut self.0) {
            Some(chunk) => {
                chunk.vals.push(val);
                self
            }
            None => self.link(val),
        }
    }
}

impl Default for Env {
    fn default() -> Self {
        Env::new(Vec::new())
    }
}

/// A value is a graph: twenty pairs sharing their way down are a million nodes
/// expanded. The refcount sieves, but a second handle may be elsewhere
/// entirely, so the count decides rather than the refcount.
fn repeats(v: &Val) -> HashMap<*const Val, usize> {
    let mut seen: HashMap<*const Val, usize> = HashMap::new();
    let mut work: Vec<&Val> = vec![v];
    while let Some(x) = work.pop() {
        let kids: &[&RcVal] = match x {
            Val::Pair(a, b) => &[a, b],
            Val::Raise(a) => &[a],
            _ => continue,
        };
        for c in kids {
            // A leaf is never worth a name: `#3=nil` is longer than what it
            // stands for.
            if c.refs() == 1 || !matches!(&***c, Val::Pair(_, _) | Val::Raise(_)) {
                work.push(c);
                continue;
            }
            let n = seen.entry(&***c as *const Val).or_insert(0);
            *n += 1;
            // Its subtree was walked the first time and has not changed.
            if *n == 1 {
                work.push(c);
            }
        }
    }
    seen
}

enum Say<'a> {
    Val(&'a Val),
    /// Tail position of a list being flattened
    Tail(&'a Val),
    Text(&'static str),
}

/// Iterative: a value has no depth bound and no *size* bound as a tree, so a
/// shared subtree would exhaust memory. Answered with datum labels `#0=`/`#0#`,
/// which [`read`] deliberately does not accept - the codec carries sharing.
impl fmt::Display for Val {
    fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result {
        let repeated = repeats(self);
        let mut named: HashMap<*const Val, usize> = HashMap::new();
        let mut stack = vec![Say::Val(self)];

        while let Some(step) = stack.pop() {
            let v = match step {
                Say::Text(s) => {
                    f.write_str(s)?;
                    continue;
                }
                Say::Tail(v) => {
                    // A named node cannot flatten into the spine: the name is
                    // written where a value goes, so the list turns improper.
                    if !is_repeated(v, &repeated) {
                        match v {
                            Val::Nil => continue,
                            Val::Pair(h, t) => {
                                f.write_str(" ")?;
                                stack.push(Say::Tail(t));
                                stack.push(Say::Val(h));
                                continue;
                            }
                            _ => {}
                        }
                    }
                    f.write_str(" . ")?;
                    v
                }
                Say::Val(v) => v,
            };

            if is_repeated(v, &repeated) {
                let at = v as *const Val;
                if let Some(n) = named.get(&at) {
                    write!(f, "#{n}#")?;
                    continue;
                }
                let n = named.len();
                named.insert(at, n);
                write!(f, "#{n}=")?;
            }

            match v {
                Val::Num(n) => write!(f, "{n}")?,
                Val::Flo(x) => write!(f, "{x:?}")?,
                Val::Nil => f.write_str("nil")?,
                Val::Sym(s) => write!(f, "'{s}")?,
                Val::Atom(a) => write!(f, "{a}")?,
                Val::Clo(_, _) => f.write_str("#<closure>")?,
                Val::Code(e) => write!(f, "#<code {e}>")?,
                Val::Cell(i) => write!(f, "#<cell {i}>")?,
                Val::Raise(a) => {
                    f.write_str("#<raised ")?;
                    stack.push(Say::Text(">"));
                    stack.push(Say::Val(a));
                }
                Val::Pair(h, t) => {
                    f.write_str("(")?;
                    stack.push(Say::Text(")"));
                    stack.push(Say::Tail(t));
                    stack.push(Say::Val(h));
                }
            }
        }
        Ok(())
    }
}

fn is_repeated(v: &Val, repeated: &HashMap<*const Val, usize>) -> bool {
    repeated.get(&(v as *const Val)).is_some_and(|&n| n > 1)
}

/// Floor source as read, except the three things with no syntax: a de Bruijn
/// variable, a persisted value, a host atom. Iterative for `Drop`'s reason.
impl fmt::Display for Exp {
    fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result {
        let mut stack = vec![Tok::Node(self)];
        while let Some(tok) = stack.pop() {
            let e = match tok {
                Tok::Text(s) => {
                    f.write_str(s)?;
                    continue;
                }
                Tok::Node(e) => e,
            };
            match e {
                Exp::Lit(n) => write!(f, "{n}")?,
                Exp::Flo(x) => write!(f, "{x:?}")?,
                Exp::Sym(s) => write!(f, "'{s}")?,
                Exp::Atom(a) => write!(f, "{a}")?,
                Exp::Nil => f.write_str("()")?,
                Exp::Var(i) => write!(f, "x{i}")?,
                // The bracket says "value, not source", so it goes only on the
                // ones that would otherwise read as a literal.
                Exp::Proc(v) => match &**v {
                    Val::Clo(_, _) | Val::Code(_) | Val::Cell(_) | Val::Raise(_) => {
                        write!(f, "{v}")?
                    }
                    v => write!(f, "#<{v}>")?,
                },

                // Binders have no names, so a unary lambda prints as bare
                // `lambda` and any other arity says how many it takes.
                Exp::Lam(1, b) => form(f, "lambda", &[b], &mut stack)?,
                Exp::Lam(n, b) => {
                    write!(f, "(lambda/{n} ")?;
                    stack.push(Tok::Text(")"));
                    stack.push(Tok::Node(b));
                }
                // An application has no head word; the operator is it.
                Exp::App(g, args) => {
                    stack.push(Tok::Text(")"));
                    for a in args.iter().rev() {
                        stack.push(Tok::Node(a));
                        stack.push(Tok::Text(" "));
                    }
                    stack.push(Tok::Node(g));
                    f.write_str("(")?;
                }
                Exp::Apply(g, args) => form(f, "apply", &[g, args], &mut stack)?,
                Exp::Let(a, b) => form(f, "let", &[a, b], &mut stack)?,
                Exp::If(c, t, o) => form(f, "if", &[c, t, o], &mut stack)?,
                Exp::Prim1(p, a) => form(f, p.name(), &[a], &mut stack)?,
                Exp::Prim2(p, a, b) => form(f, p.name(), &[a, b], &mut stack)?,
                Exp::Op(idx, args) => {
                    let kids: Vec<&RcExp> = args.iter().collect();
                    form(f, host::registry().get(*idx).name, &kids, &mut stack)?
                }
                Exp::Lift(a) => form(f, "lift", &[a], &mut stack)?,
                Exp::LiftFun(a, b) => form(f, "lift-fun", &[a, b], &mut stack)?,
                Exp::LiftRef(a, b) => form(f, "lift-ref", &[a, b], &mut stack)?,
                Exp::Run(a, b) => form(f, "run", &[a, b], &mut stack)?,
                Exp::IsCode(a, b) => form(f, "code?", &[a, b], &mut stack)?,
                Exp::Evalms(a, b) => form(f, "evalms", &[a, b], &mut stack)?,
                Exp::Catch(a) => form(f, "catch", &[a], &mut stack)?,
                Exp::Throw(a) => form(f, "throw", &[a], &mut stack)?,
            }
        }
        Ok(())
    }
}

enum Tok<'a> {
    Node(&'a Exp),
    Text(&'static str),
}

/// The stack is LIFO, so the children go on backwards.
fn form<'a>(
    f: &mut fmt::Formatter<'_>,
    head: &str,
    kids: &[&'a RcExp],
    stack: &mut Vec<Tok<'a>>,
) -> fmt::Result {
    stack.push(Tok::Text(")"));
    for k in kids.iter().rev() {
        stack.push(Tok::Node(k));
        stack.push(Tok::Text(" "));
    }
    write!(f, "({head}")
}

#[cfg(test)]
mod tests {
    use super::*;

    #[test]
    fn a_long_list_costs_no_stack() {
        let build = || (0..10_000).fold(Val::Nil, |t, i| pair(Val::Num(i), t));
        assert_eq!(build(), build());
    }

    #[test]
    fn a_deep_car_chain_costs_no_stack() {
        let build = || (0..10_000).fold(Val::Nil, |t, _| pair(t, Val::Nil));
        assert_eq!(build(), build());
    }

    #[test]
    fn printing_costs_no_stack() {
        let deep = (0..10_000).fold(Val::Nil, |t, _| pair(t, Val::Nil));
        assert_eq!(deep.to_string().len(), 20_003);
        let long = (0..10_000).fold(Val::Nil, |t, _| pair(Val::Num(1), t));
        assert_eq!(long.to_string().len(), 20_001);
    }

    #[test]
    fn a_shared_subgraph_is_named_rather_than_repeated() {
        let one = pair(Val::Num(1), Val::Nil);
        let wide = (0..20).fold(one, |v, _| pair(Val::clone(&v), v));
        let s = wide.to_string();
        assert!(s.len() < 600, "{} chars", s.len());
        assert!(s.starts_with("((#0=(#1="), "{s}");
        assert!(s.ends_with(" #0# . #37#)"), "{s}");

        // Sharing is a shared `RcVal`, not an equal `Val`: `pair` wraps afresh,
        // so two clones of one value are two nodes and print as two.
        let leaf = rc_val(pair(Val::Sym("a".into()), Val::Nil));
        let two = |a: &RcVal, b: &RcVal| Val::Pair(RcVal::clone(a), RcVal::clone(b));

        // A leaf is never named: it cannot amplify, and the name would be
        // longer than the thing.
        let nil = rc_val(Val::Nil);
        assert_eq!(two(&nil, &nil).to_string(), "(nil)");

        // Naming happens where a value goes, so a spine that reaches a
        // named node stops being flattened there.
        assert_eq!(two(&leaf, &leaf).to_string(), "(#0=('a) . #0#)");
    }
}