fix(lisp): charge READ text, EQUAL string bytes, SETVAR and ENTMAKE copies, and nested callbacks against one budget

Every SORTENTSTABLE rebuilt its whole entity store, so many small tables naming one large space made import quadratic. Each space is now sorted once, by the last table naming it, which already decided its order.

Co-authored-by: Brandon Thomas <echelon@gmail.com>

crates/engine/src/lisp.rs

@@ -123,6 +123,12 @@ pub struct LispState {
     acad_loaded: bool,
     /// Memory caps (lowered by tests).
     pub(crate) limits: Limits,
+    /// Interpreter steps all synchronous callbacks have run, nested ones included. A callback's
+    /// allowance counts what ran since it started, so the callbacks it calls spend its steps.
+    pub(crate) callback_used: u64,
+    /// The `callback_used` value the callback running now (and so every one it calls) must not
+    /// pass: the lowest of its own and its callers' allowances.
+    pub(crate) callback_ceiling: Option<u64>,
 }
 
 /// What U and REDO inside the running routine take back: the commands it ran, each as the drawing

crates/engine/src/lisp/builtins/strings.rs

@@ -1,5 +1,5 @@
 use super::args::{R, arity, int, list_arg, string};
-use super::{LispError, OsStr, Value, check_string_len, read, to_text};
+use super::{LispError, OsStr, Value, charge_bytes, check_string_len, read, to_text};
 
 // ---------------- strings ----------------
 
@@ -114,7 +114,13 @@ pub(super) fn read_fn(a: &[Value]) -> R {
     arity(a, 0, 1)?;
     match a.first() {
         None | Some(Value::Nil) => Ok(Value::Nil),
-        Some(v) => read::read_one(&string(v)?),
+        Some(v) => {
+            // The strings in the list it makes are new, each as long as its text at most: the
+            // text is charged, though a list result isn't inspected by `charge_result`.
+            let text = string(v)?;
+            charge_bytes(text.len())?;
+            read::read_one(&text)
+        }
     }
 }
 

crates/engine/src/lisp/drawing.rs

@@ -179,7 +179,12 @@ fn to_json_bounded(v: &Value, depth: usize, budget: &mut u64) -> Option<serde_js
         Value::Nil => serde_json::Value::Null,
         Value::Int(i) => serde_json::json!(i),
         Value::Real(r) => serde_json::json!(r),
-        Value::Str(s) => serde_json::json!(&**s),
+        Value::Str(s) => {
+            // A string is copied whole each time it occurs: it spends the allowance by its length
+            // (one unit per 16 bytes, so about 32 MB in all), shared or not.
+            *budget = budget.checked_sub(s.len() as u64 / 16)?;
+            serde_json::json!(&**s)
+        }
         Value::Cons(_) => {
             let mut arr = Vec::new();
             for x in v.iter() {
@@ -296,12 +301,16 @@ fn groups_to_list(tags: &[Tag]) -> Vec<Value> {
     out
 }
 
+/// The most string bytes an entity list may hold (counted per occurrence, shared or not).
+const MAX_GROUP_TEXT: usize = 32 << 20;
+
 /// An association list back to DXF groups (points split into x, y, z groups). The type
 /// (`0`), the entity name (`-1`), the handle (`5`), the owner (`330`) and the layout (`410`) are
 /// left out: they aren't the entity's to set.
 fn list_to_groups(list: &Value) -> Result<(String, Vec<Tag>), LispError> {
     let mut kind = None;
     let mut tags = Vec::new();
+    let mut text_left = MAX_GROUP_TEXT;
     for item in list.iter() {
         let Value::Cons(c) = &item else { return Err(LispError::bad_arg("listp", &item)) };
         let Value::Int(code) = c.car else { return Err(LispError::bad_arg("fixnump", &c.car)) };
@@ -323,7 +332,11 @@ fn list_to_groups(list: &Value) -> Result<(String, Vec<Tag>), LispError> {
             _ => tags.push(match &v {
                 Value::Int(i) => Tag::i(code, i64::from(*i)),
                 Value::Real(r) => Tag::f(code, *r),
-                Value::Str(s) => Tag::s(code, &**s),
+                Value::Str(s) => {
+                    // Each occurrence of a shared string becomes its own copy in the tag.
+                    text_left = text_left.checked_sub(s.len()).ok_or_else(|| LispError::new("out of memory: the entity list holds too much text"))?;
+                    Tag::s(code, &**s)
+                }
                 Value::Ename(h) => Tag::s(code, h.hex()),
                 other => return Err(LispError::bad_arg("DXF group value", other)),
             }),
@@ -1125,3 +1138,27 @@ pub fn load_source(s: &Session, name: &str) -> Option<String> {
         s.lisp_support_dir().map(|d| candidates.iter().map(|c| d.join(c).to_string_lossy().into_owned()).collect::<Vec<_>>()).unwrap_or_default();
     candidates.iter().chain(&support).find_map(super::builtins::read_text_file)
 }
+
+#[cfg(test)]
+mod budget_tests {
+    use super::*;
+
+    /// One 64 KB string occurring many times is charged by its length each time.
+    #[test]
+    fn shared_strings_spend_the_conversion_budgets() {
+        let big = Value::str(&"x".repeat(64 << 10));
+        // 600 x 64 KB is over the 32 MiB an entity list may hold; 100 x 64 KB is not.
+        let list = |n: usize| {
+            let mut items = vec![Value::cons(Value::Int(0), Value::str("TEXT"))];
+            items.extend(std::iter::repeat_n(Value::cons(Value::Int(1), big.clone()), n));
+            Value::list(items)
+        };
+        assert!(list_to_groups(&list(600)).is_err());
+        assert!(list_to_groups(&list(100)).is_ok());
+        // 1,000 x 64 KB is 4,096,000 units of the 2,000,000 SETVAR allows; 100 x 64 KB is not.
+        let mut budget = TO_JSON_BUDGET;
+        assert!(to_json_bounded(&Value::list(vec![big.clone(); 1_000]), 0, &mut budget).is_none());
+        let mut budget = TO_JSON_BUDGET;
+        assert!(to_json_bounded(&Value::list(vec![big; 100]), 0, &mut budget).is_some());
+    }
+}

crates/engine/src/lisp/eval.rs

@@ -175,17 +175,19 @@ pub struct Machine {
     stack: Vec<Frame>,
     state: State,
     need: Option<Need>,
+    /// Steps the last [`Machine::run`] took.
+    last_steps: u64,
 }
 
 impl Machine {
     /// A machine evaluating `forms` in turn.
     pub fn forms(forms: Vec<Value>) -> Machine {
-        Machine { stack: vec![Frame::Forms { rest: forms.into_iter().rev().collect() }], state: State::Ret(Value::Nil), need: None }
+        Machine { stack: vec![Frame::Forms { rest: forms.into_iter().rev().collect() }], state: State::Ret(Value::Nil), need: None, last_steps: 0 }
     }
 
     /// A machine calling `f` with `args`.
     pub fn calling(f: Value, args: Vec<Value>) -> Machine {
-        Machine { stack: Vec::new(), state: State::Call(f, args), need: None }
+        Machine { stack: Vec::new(), state: State::Call(f, args), need: None, last_steps: 0 }
     }
 
     /// Give the value a [`Need`] waited for, and carry on.
@@ -196,9 +198,15 @@ impl Machine {
     /// Run until done, waiting, or `budget` steps.
     pub fn run(&mut self, ctx: &mut Ctx<'_>, budget: u64) -> Outcome {
         let mut n = 0u64;
+        let outcome = self.run_counted(ctx, budget, &mut n);
+        self.last_steps = n.min(budget);
+        outcome
+    }
+
+    fn run_counted(&mut self, ctx: &mut Ctx<'_>, budget: u64, n: &mut u64) -> Outcome {
         loop {
-            n += 1;
-            if n > budget {
+            *n += 1;
+            if *n > budget {
                 return Outcome::Wait(Need::Yield);
             }
             let r = match std::mem::replace(&mut self.state, State::Ret(Value::Nil)) {
@@ -646,29 +654,41 @@ impl Ctx<'_> {
             super::value::charge_result(&v)?;
             return Ok(v);
         }
+        let cap = self.s.lisp.limits.callback_steps;
+        let start = self.s.lisp.callback_used;
+        // This callback may run until `callback_used` reaches `ceiling`: `cap` steps from now, or
+        // sooner where a caller's allowance ends, so callbacks nested in callbacks share one
+        // allowance instead of each taking a fresh one (an exponential tree otherwise).
+        let outer = self.s.lisp.callback_ceiling;
+        let ceiling = start.saturating_add(cap).min(outer.unwrap_or(u64::MAX));
+        self.s.lisp.callback_ceiling = Some(ceiling);
+        let r = self.drive_callback(f, args, ceiling);
+        self.s.lisp.callback_ceiling = outer;
+        r
+    }
+
+    /// Run callback `f` in slices until it finishes or `callback_used` reaches `ceiling`.
+    fn drive_callback(&mut self, f: &Value, args: Vec<Value>, ceiling: u64) -> Result<Value, LispError> {
         let cap = self.s.lisp.limits.callback_steps;
         let mut m = Machine::calling(f.clone(), args);
         let mut sub = Ctx { s: &mut *self.s, env: &mut *self.env, depth: self.depth + 1 };
         // Drive the callback in bounded slices instead of granting it `u64::MAX` fuel. A `Yield`
-        // (the step budget ran out) is retried until a hard cap, so a constant-memory infinite
+        // (the step budget ran out) is retried until the ceiling, so a constant-memory infinite
         // loop inside a comparator or predicate terminates with an error rather than hanging the
-        // thread and bypassing the blocking execution cap (CWE-400).
-        let mut spent: u64 = 0;
+        // thread and bypassing the blocking execution cap (CWE-400). The steps of callbacks this
+        // one calls are counted in `callback_used` too.
         loop {
-            let remaining = cap.saturating_sub(spent);
+            let remaining = ceiling.saturating_sub(sub.s.lisp.callback_used);
             if remaining == 0 {
                 return Err(LispError::new(format!("callback stopped after {cap} steps")));
             }
             let slice = remaining.min(SYNC_SLICE);
-            match m.run(&mut sub, slice) {
+            let outcome = m.run(&mut sub, slice);
+            sub.s.lisp.callback_used = sub.s.lisp.callback_used.saturating_add(m.last_steps);
+            match outcome {
                 Outcome::Done(v) => return Ok(v),
                 Outcome::Error(e) => return Err(e),
-                Outcome::Wait(Need::Yield) => {
-                    spent = spent.saturating_add(slice);
-                    if spent >= cap {
-                        return Err(LispError::new(format!("callback stopped after {cap} steps")));
-                    }
-                }
+                Outcome::Wait(Need::Yield) => {}
                 Outcome::Wait(_) => return Err(LispError::new("this function can't ask for input here")),
             }
         }

crates/engine/src/lisp/tests.rs

@@ -286,6 +286,20 @@ fn reaching_a_callback_slice_boundary_does_not_grant_another_slice() {
     assert!(counts[1] >= counts[0] && counts[1] - counts[0] <= 1, "{counts:?}");
 }
 
+/// Callbacks that call callbacks share one allowance: a branching routine can't multiply it.
+#[test]
+fn nested_callbacks_share_one_step_allowance() {
+    let mut s = session();
+    s.lisp.limits.callback_steps = 1_000_000;
+    // 4^14 leaf calls if every callback took a fresh allowance; the whole tree gets one.
+    let started = std::time::Instant::now();
+    let e = eval(&mut s, "(defun f (n) (if (> n 0) (vl-every '(lambda (x) (f (1- n)) t) '(1 2 3 4)) t)) (f 14)").unwrap_err();
+    assert!(e.contains("callback stopped after 1000000 steps"), "{e}");
+    assert!(started.elapsed() < std::time::Duration::from_secs(60));
+    // The next run starts afresh.
+    assert_eq!(ok(&mut s, "(f 1)"), "T");
+}
+
 /// System-variable conversion rejects a shared list whose owned JSON expansion would exceed its budget.
 #[test]
 fn setvar_rejects_an_oversized_shared_structure() {
@@ -977,6 +991,9 @@ fn strings_are_capped() {
     assert!(e.contains("too much text"), "{e}");
     let e = eval(&mut s, "(repeat 200000 (princ \"0123456789\"))").unwrap_err();
     assert!(e.contains("too much text"), "{e}");
+    // READ makes new strings inside the list it returns: they count, though the result is a list.
+    let e = eval(&mut s, "(setq a \"(\\\"0123456789\\\")\") (repeat 100000 (setq b (read a)))").unwrap_err();
+    assert!(e.contains("too much text"), "{e}");
     // The budget is per run: the next one starts afresh.
     assert_eq!(ok(&mut s, "(strcat \"a\" \"b\")"), "\"ab\"");
 }

crates/engine/src/lisp/value.rs

@@ -346,7 +346,11 @@ pub fn equal(a: &Value, b: &Value, fuzz: f64) -> bool {
     // A shared cons DAG can expand into exponentially many node visits when compared as a tree.
     // Bound the total comparisons so `equal` on adversarial shared structure cannot monopolise the
     // thread (CWE-407); exhausting the budget reports "not equal" rather than looping.
-    let mut budget: u64 = EQUAL_BUDGET;
+    equal_within(a, b, fuzz, EQUAL_BUDGET)
+}
+
+/// [`equal`] with its work allowance (node visits plus string bytes / 64) given.
+fn equal_within(a: &Value, b: &Value, fuzz: f64, mut budget: u64) -> bool {
     equal_depth(a, b, fuzz, 0, &mut budget)
 }
 
@@ -373,7 +377,19 @@ fn equal_depth(a: &Value, b: &Value, fuzz: f64, depth: usize, budget: &mut u64)
                 a = na;
                 b = nb;
             }
-            _ => return atom_equal(&a, &b, fuzz),
+            _ => {
+                // Comparing two strings costs their length, not one visit: a shared list of long
+                // equal strings must spend the allowance by the bytes it compares (one unit per 64).
+                if let (Value::Str(x), Value::Str(y)) = (&a, &b) {
+                    let cost = (x.len().min(y.len()) / 64) as u64;
+                    if cost >= *budget {
+                        *budget = 0;
+                        return false;
+                    }
+                    *budget -= cost;
+                }
+                return atom_equal(&a, &b, fuzz);
+            }
         }
     }
 }
@@ -540,6 +556,20 @@ fn write_value(out: &mut String, v: &Value, escape: bool, depth: usize) {
 mod tests {
     use super::*;
 
+    /// `equal` charges the bytes of the strings it compares: a list of long equal strings fits a
+    /// big allowance but not a small one, though it has few nodes.
+    #[test]
+    fn equal_spends_its_allowance_on_string_bytes() {
+        let long = Value::str(&"x".repeat(6_400));
+        let other = Value::str(&"x".repeat(6_400));
+        let list = |v: &Value| Value::list(vec![v.clone(); 100]);
+        let (a, b) = (list(&long), list(&other));
+        // 100 strings x 100 units each, plus about 100 node visits.
+        assert!(equal_within(&a, &b, 0.0, 20_000));
+        assert!(!equal_within(&a, &b, 0.0, 5_000));
+        assert!(equal(&a, &b, 0.0));
+    }
+
     #[test]
     fn reals_print_with_six_significant_digits() {
         assert_eq!(real_text(1.0), "1.0");

crates/io/src/dxf_read/document.rs

@@ -333,7 +333,17 @@ pub(super) fn apply_sortents(
     paper_for: &HashMap<String, String>,
     first_layout: &str,
 ) {
-    for (owner, map) in tables {
+    // Each sort rebuilds its whole space, so a space named by many tables is sorted once, by the
+    // last of them (which decided its order anyway); repeated tables made import quadratic.
+    let target = |owner: &String| {
+        let up = brs.get(owner)?.to_ascii_uppercase();
+        Some(if up.starts_with("*PAPER_SPACE") { paper_for.get(&up).cloned().unwrap_or_else(|| first_layout.to_string()) + "\0paper" } else { up })
+    };
+    let last: HashMap<String, usize> = tables.iter().enumerate().filter_map(|(i, (owner, _))| Some((target(owner)?, i))).collect();
+    for (i, (owner, map)) in tables.iter().enumerate() {
+        if target(owner).and_then(|t| last.get(&t)) != Some(&i) {
+            continue;
+        }
         let Some(name) = brs.get(owner) else { continue };
         let up = name.to_ascii_uppercase();
         // A sort handle of 0 draws last (ezdxf `reorder`, which notes AutoCAD defines it, undocumented).

crates/io/src/tests.rs

@@ -337,6 +337,28 @@ fn entity_transparency_roundtrips_as_group_440() {
     assert_eq!(d.model.iter().map(|e| e.common.transparency).collect::<Vec<_>>(), [Transparency::ByLayer, Transparency::Percent(90)]);
 }
 
+/// Several SORTENTSTABLEs for one space sort it once, in the last table's order.
+#[test]
+fn repeated_sortents_tables_use_the_last() {
+    let table =
+        |a: u32, b: u32| format!("0\nSORTENTSTABLE\n5\n{:X}\n100\nAcDbSortentsTable\n330\n1F\n331\nA\n5\n{a:X}\n331\nB\n5\n{b:X}\n", 0x100 + a);
+    let mut t = String::from(
+        "0\nSECTION\n2\nTABLES\n0\nTABLE\n2\nBLOCK_RECORD\n0\nBLOCK_RECORD\n5\n1F\n2\n*Model_Space\n0\nENDTAB\n0\nENDSEC\n\
+         0\nSECTION\n2\nENTITIES\n0\nLINE\n5\nA\n330\n1F\n10\n0\n20\n0\n11\n1\n21\n1\n0\nLINE\n5\nB\n330\n1F\n10\n0\n20\n0\n11\n2\n21\n2\n0\nENDSEC\n\
+         0\nSECTION\n2\nOBJECTS\n0\nDICTIONARY\n5\nC\n",
+    );
+    for _ in 0..1000 {
+        t.push_str(&table(2, 1));
+    }
+    t.push_str(&table(1, 2));
+    t.push_str("0\nENDSEC\n0\nEOF\n");
+    let d = read(t.as_bytes(), "s.dxf").unwrap();
+    assert_eq!(d.model.iter().map(|e| e.handle.0).collect::<Vec<_>>(), [0xA, 0xB]);
+    let reversed = t.replacen(&table(1, 2), &table(2, 1), 1);
+    let d = read(reversed.as_bytes(), "s.dxf").unwrap();
+    assert_eq!(d.model.iter().map(|e| e.handle.0).collect::<Vec<_>>(), [0xB, 0xA]);
+}
+
 /// A table declaring 10 000 rows and no columns (or the reverse) is read as an empty table.
 #[test]
 fn table_with_an_empty_dimension_allocates_nothing() {