From fad385e979c58056f426415c479dea7057bc50e7 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 18:17:46 +0000 Subject: [PATCH 01/13] Add the packed topology, with a validating two-pass builder Co-Authored-By: Claude Opus 5 (1M context) --- cl-random-forest-test.asd | 14 ++- src/packed.lisp | 5 + src/packed/topology.lisp | 206 ++++++++++++++++++++++++++++++++++++++ t/packed.lisp | 84 ++++++++++++++++ 4 files changed, 307 insertions(+), 2 deletions(-) create mode 100644 src/packed.lisp create mode 100644 src/packed/topology.lisp create mode 100644 t/packed.lisp diff --git a/cl-random-forest-test.asd b/cl-random-forest-test.asd index 143dbe8..5a81ecd 100644 --- a/cl-random-forest-test.asd +++ b/cl-random-forest-test.asd @@ -65,6 +65,14 @@ (unless (symbol-call :rove :run c) (error "Tests failed.")))) +(defsystem "cl-random-forest-test/packed" + :description "Tests for the packed inference representation" + :depends-on ("rove" "cl-random-forest-test/fixture" "cl-random-forest/src/packed") + :components ((:module "t" :components ((:file "packed")))) + :perform (test-op (o c) (declare (ignore o)) + (unless (symbol-call :rove :run c) + (error "Tests failed.")))) + (defsystem "cl-random-forest-test" :author "Satoshi Imai" :license "MIT Licence" @@ -76,7 +84,8 @@ "cl-random-forest-test/refinement" "cl-random-forest-test/parallel" "cl-random-forest-test/regression" - "cl-random-forest-test/pruning") + "cl-random-forest-test/pruning" + "cl-random-forest-test/packed") ;; NOTE: This system has no components of its own, so rove's SYSTEM-SUITES would ;; return an empty list and (rove:run c) would silently report zero tests. ;; The feature systems must be listed explicitly. @@ -89,5 +98,6 @@ "cl-random-forest-test/refinement" "cl-random-forest-test/parallel" "cl-random-forest-test/regression" - "cl-random-forest-test/pruning")) + "cl-random-forest-test/pruning" + "cl-random-forest-test/packed")) (error "Tests failed.")))) diff --git a/src/packed.lisp b/src/packed.lisp new file mode 100644 index 0000000..18e41df --- /dev/null +++ b/src/packed.lisp @@ -0,0 +1,5 @@ +(uiop:define-package :cl-random-forest/src/packed + (:use :cl) + (:use-reexport :cl-random-forest/src/packed/topology)) + +(in-package :cl-random-forest/src/packed) diff --git a/src/packed/topology.lisp b/src/packed/topology.lisp new file mode 100644 index 0000000..198ca70 --- /dev/null +++ b/src/packed/topology.lisp @@ -0,0 +1,206 @@ +(defpackage :cl-random-forest/src/packed/topology + (:use #:cl) + (:import-from #:cl-random-forest/src/random-forest + #:forest-dtree-list + #:forest-n-tree + #:forest-datum-dim + #:dtree-root + #:node-test-attribute + #:node-test-threshold + #:node-left-node + #:node-right-node + #:node-sample-indices) + (:export #:packed-topology + #:packed-topology-p + #:packed-topology-n-tree + #:packed-topology-n-internal + #:packed-topology-n-leaf + #:packed-topology-feature + #:packed-topology-threshold + #:packed-topology-left + #:packed-topology-right + #:packed-topology-roots + #:packed-topology-tree-leaf-offsets + #:%make-packed-topology + #:build-packed-topology + #:packed-leaf + #:packed-leaf-indices + #:packed-build-error + #:packed-build-error-detail)) + +(in-package :cl-random-forest/src/packed/topology) + +(define-condition packed-build-error (error) + ((detail :initarg :detail :reader packed-build-error-detail)) + (:report (lambda (c s) + (format s "cannot pack this forest: ~A" (packed-build-error-detail c)))) + (:documentation + "Signalled for anything the packed traversal could not survive. + +The traversal runs at (safety 0) and trusts its declarations, so every assumption has to +hold before it starts. One of them is not obvious: a leaf that has lost its sample indices +would get a uniform class distribution from CLASS-DISTRIBUTION rather than an error, and +that would be frozen into the model silently.")) + +(defstruct (packed-topology (:constructor %make-packed-topology)) + "Every internal node of every tree of a forest, flattened into parallel arrays. + +A leaf is encoded as a negative child index, `~leaf`, so a walk's continuation test is its +leaf test and a leaf costs no extra read. Leaf numbers are +TREE-LEAF-OFFSETS[tree] + the tree's own leaf index, which is by construction the index +Global Refinement uses." + (n-tree 0 :type fixnum) + (n-internal 0 :type fixnum) + (n-leaf 0 :type fixnum) + (feature (make-array 0 :element-type '(unsigned-byte 32)) + :type (simple-array (unsigned-byte 32) (*))) + (threshold (make-array 0 :element-type 'single-float) + :type (simple-array single-float (*))) + (left (make-array 0 :element-type '(signed-byte 32)) + :type (simple-array (signed-byte 32) (*))) + (right (make-array 0 :element-type '(signed-byte 32)) + :type (simple-array (signed-byte 32) (*))) + (roots (make-array 0 :element-type '(signed-byte 32)) + :type (simple-array (signed-byte 32) (*))) + (tree-leaf-offsets (make-array 0 :element-type '(unsigned-byte 32)) + :type (simple-array (unsigned-byte 32) (*)))) + +(defun check-packable (forest) + "Signal PACKED-BUILD-ERROR unless FOREST can be packed." + (let ((dtrees (forest-dtree-list forest)) + (dim (forest-datum-dim forest))) + (unless (= (length dtrees) (forest-n-tree forest)) + (error 'packed-build-error + :detail (format nil "~D trees in the list, FOREST-N-TREE says ~D" + (length dtrees) (forest-n-tree forest)))) + (labels ((walk (node depth) + (cond + ((null node) + (error 'packed-build-error :detail "a nil node")) + ((node-test-attribute node) + (let ((f (node-test-attribute node))) + (unless (and (typep f 'fixnum) (<= 0 f) (< f dim)) + (error 'packed-build-error + :detail (format nil "feature ~S outside [0,~D) at depth ~D" + f dim depth)))) + (unless (typep (node-test-threshold node) 'single-float) + (error 'packed-build-error + :detail (format nil "threshold ~S is not a single-float" + (node-test-threshold node)))) + (unless (and (node-left-node node) (node-right-node node)) + (error 'packed-build-error + :detail "an internal node with only one child")) + (walk (node-left-node node) (1+ depth)) + (walk (node-right-node node) (1+ depth))) + (t + (unless (node-sample-indices node) + (error 'packed-build-error + :detail (format nil "a leaf at depth ~D has no sample indices, ~ +so its class distribution would come out uniform without any error being signalled ~ +(issue #14) -- rebuild the forest with :remove-sample-indices? nil" depth))))))) + (dolist (dtree dtrees) + (walk (dtree-root dtree) 0))))) + +(defun count-tree-nodes (dtree) + "Return (values n-internal n-leaf) for DTREE." + (let ((internal 0) (leaves 0)) + (labels ((walk (node) + (if (node-test-attribute node) + (progn (incf internal) + (walk (node-left-node node)) + (walk (node-right-node node))) + (incf leaves)))) + (walk (dtree-root dtree))) + (values internal leaves))) + +(defun build-packed-topology (forest) + "Flatten FOREST's structure into arrays. + +Two passes: count and validate, then fill exact-size arrays. Validating first matters +because the traversal runs at (safety 0)." + (check-packable forest) + (let* ((dtrees (forest-dtree-list forest)) + (n-tree (length dtrees)) + (n-internal 0) + (n-leaf 0)) + (dolist (dtree dtrees) + (multiple-value-bind (i l) (count-tree-nodes dtree) + (incf n-internal i) + (incf n-leaf l))) + (unless (< n-internal (expt 2 31)) + (error 'packed-build-error + :detail (format nil "~D internal nodes exceeds a (signed-byte 32) index" + n-internal))) + (unless (< n-leaf (expt 2 31)) + (error 'packed-build-error + :detail (format nil "~D leaves exceeds a (signed-byte 32) index" n-leaf))) + (let ((feature (make-array n-internal :element-type '(unsigned-byte 32))) + (threshold (make-array n-internal :element-type 'single-float)) + (left (make-array n-internal :element-type '(signed-byte 32))) + (right (make-array n-internal :element-type '(signed-byte 32))) + (roots (make-array n-tree :element-type '(signed-byte 32))) + (offsets (make-array n-tree :element-type '(unsigned-byte 32))) + (node-cursor 0) + (leaf-base 0)) + (loop for dtree in dtrees + for tree from 0 + do (setf (aref offsets tree) leaf-base) + (let ((local-leaf 0)) + (labels ((emit (node) + (cond + ((node-test-attribute node) + (let ((self node-cursor)) + (incf node-cursor) + (setf (aref feature self) (node-test-attribute node) + (aref threshold self) (node-test-threshold node)) + (setf (aref left self) (emit (node-left-node node))) + (setf (aref right self) (emit (node-right-node node))) + self)) + (t + (prog1 (lognot (+ leaf-base local-leaf)) + (incf local-leaf)))))) + (setf (aref roots tree) (emit (dtree-root dtree)))) + (incf leaf-base local-leaf))) + (%make-packed-topology + :n-tree n-tree :n-internal n-internal :n-leaf n-leaf + :feature feature :threshold threshold :left left :right right + :roots roots :tree-leaf-offsets offsets)))) + +(declaim (inline packed-leaf)) +(defun packed-leaf (topology datamatrix datum-index root) + "The leaf number a datum reaches from ROOT. This is the Global Refinement index." + (declare (optimize (speed 3) (safety 0)) + (type packed-topology topology) + (type (simple-array single-float (* *)) datamatrix) + (type fixnum datum-index) + (type (signed-byte 32) root)) + (let ((feature (packed-topology-feature topology)) + (threshold (packed-topology-threshold topology)) + (left (packed-topology-left topology)) + (right (packed-topology-right topology)) + (node root)) + (declare (type (simple-array (unsigned-byte 32) (*)) feature) + (type (simple-array single-float (*)) threshold) + (type (simple-array (signed-byte 32) (*)) left right) + (type (signed-byte 32) node)) + (loop while (>= node 0) + do (setf node (if (>= (aref datamatrix datum-index (aref feature node)) + (aref threshold node)) + (aref left node) + (aref right node)))) + (lognot node))) + +(defun packed-leaf-indices (topology datamatrix datum-index out) + "Fill OUT with the leaf each tree sends a datum to. OUT is (simple-array fixnum (n-tree))." + (declare (optimize (speed 3) (safety 0)) + (type packed-topology topology) + (type (simple-array single-float (* *)) datamatrix) + (type (simple-array fixnum (*)) out) + (type fixnum datum-index)) + (let ((roots (packed-topology-roots topology)) + (n-tree (packed-topology-n-tree topology))) + (declare (type (simple-array (signed-byte 32) (*)) roots) + (type fixnum n-tree)) + (dotimes (tree n-tree out) + (setf (aref out tree) + (packed-leaf topology datamatrix datum-index (aref roots tree)))))) diff --git a/t/packed.lisp b/t/packed.lisp new file mode 100644 index 0000000..def8a08 --- /dev/null +++ b/t/packed.lisp @@ -0,0 +1,84 @@ +(in-package :cl-user) + +(defpackage cl-random-forest-test/packed + (:use :cl :rove :cl-random-forest :cl-random-forest/src/packed + :cl-random-forest-test/fixture) + (:import-from #:cl-random-forest/src/random-forest + #:find-leaf + #:dtree-root + #:node-leaf-index)) +(in-package :cl-random-forest-test/packed) + +(defun synthetic-forest (&key (remove-sample-indices? nil) (n-tree 30)) + "A small forest on the fixture's deterministic classification set." + (multiple-value-bind (datamatrix target) (synthetic-classification-train) + (make-forest +synthetic-n-class+ datamatrix target + :n-tree n-tree :bagging-ratio 0.3 :max-depth 7 :n-trial 10 + :remove-sample-indices? remove-sample-indices?))) + +(deftest packed-topology-leaf-numbers-are-the-refine-index + ;; The leaf number a topology reports must be the index Global Refinement uses, so a + ;; refine dataset can be built straight from it. The spec makes this a guarantee rather + ;; than a coincidence of two traversal orders agreeing. + (with-serial-kernel + (multiple-value-bind (datamatrix target) (synthetic-classification-train) + (declare (ignore target)) + (let* ((forest (synthetic-forest)) + (topology (build-packed-topology forest)) + (offsets (forest-index-offset forest)) + (out (make-array (forest-n-tree forest) :element-type 'fixnum)) + (checked 0) + (mismatch 0)) + (dotimes (i 200) + (packed-leaf-indices topology datamatrix i out) + (loop for dtree in (forest-dtree-list forest) + for tree from 0 + do (incf checked) + (unless (= (aref out tree) + (+ (node-leaf-index + (find-leaf (dtree-root dtree) datamatrix i)) + (aref offsets tree))) + (incf mismatch)))) + (ok (plusp checked) (format nil "checked ~D (datum, tree) pairs" checked)) + (ok (zerop mismatch) + (format nil "~D leaf numbers differ from the refine index" mismatch)))))) + +(deftest packed-topology-refuses-a-forest-with-stranded-leaves + ;; CLASS-DISTRIBUTION returns a *uniform* distribution for a leaf with no sample indices + ;; rather than signalling, so a builder that read one would freeze that into the model + ;; with nothing to show for it. + ;; + ;; Pruning is what creates such a leaf, not forest construction. SET-BEST-CHILDREN! nils + ;; the indices of the node it *splits*, and DELETE-CHILDREN! later turns that node back + ;; into a leaf without restoring them (issue #14). A leaf is never split, so it keeps its + ;; indices whatever :remove-sample-indices? says -- which is why this test prunes. + (with-serial-kernel + (multiple-value-bind (datamatrix target) (synthetic-classification-train) + (let* ((forest (make-forest +synthetic-n-class+ datamatrix target + :n-tree 30 :bagging-ratio 0.3 :max-depth 7 :n-trial 10 + :remove-sample-indices? t)) + (refine-dataset (make-refine-dataset forest datamatrix)) + (learner (make-refine-learner forest))) + (ok (packed-topology-p (build-packed-topology forest)) + "before pruning, every leaf still has its indices and the forest packs") + (dotimes (epoch 3) + (train-refine-learner learner refine-dataset target)) + (pruning! forest learner 0.3) + (ok (handler-case (progn (build-packed-topology forest) nil) + (packed-build-error () t)) + "after pruning, build-packed-topology signals on the stranded leaves"))))) + +(deftest packed-topology-counts-add-up + (with-serial-kernel + (let* ((forest (synthetic-forest)) + (topology (build-packed-topology forest))) + (ok (= (packed-topology-n-tree topology) (forest-n-tree forest)) + "one root per tree") + ;; A binary tree with L leaves has L-1 internal nodes, so a forest of T trees has + ;; n-leaf - T of them. + (ok (= (packed-topology-n-internal topology) + (- (packed-topology-n-leaf topology) (packed-topology-n-tree topology))) + (format nil "~D internal, ~D leaves, ~D trees" + (packed-topology-n-internal topology) + (packed-topology-n-leaf topology) + (packed-topology-n-tree topology)))))) From cd5379e756f2eddeb67955d419c362c7db0aaf11 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 18:28:05 +0000 Subject: [PATCH 02/13] Reject leaves with a real but empty sample-indices array too CLASS-DISTRIBUTION divides by a zero sum for both NIL and a zero-length array, returning a uniform distribution without signalling either way. A split whose sampled attribute is constant over a node's rows yields threshold = min = max from MAKE-RANDOM-TEST, and with the >= convention every row goes left, leaving the right child a leaf with exactly such an empty array -- rare (3 of letter's 26936 leaves at :max-depth 20) but not hypothetical. check-packable now requires a leaf's sample-indices to be both present and non-empty, with a detail message that distinguishes the two cases. Added packed-topology-refuses-a-leaf-with-no-samples-to-count, which empties one leaf directly since the condition is too rare to provoke reliably from the synthetic fixture (0 of 5835 leaves observed there). Co-Authored-By: Claude Opus 5 (1M context) --- src/packed/topology.lisp | 20 +++++++++++++++----- t/packed.lisp | 31 ++++++++++++++++++++++++++++++- 2 files changed, 45 insertions(+), 6 deletions(-) diff --git a/src/packed/topology.lisp b/src/packed/topology.lisp index 198ca70..f1d3b56 100644 --- a/src/packed/topology.lisp +++ b/src/packed/topology.lisp @@ -93,11 +93,21 @@ Global Refinement uses." (walk (node-left-node node) (1+ depth)) (walk (node-right-node node) (1+ depth))) (t - (unless (node-sample-indices node) - (error 'packed-build-error - :detail (format nil "a leaf at depth ~D has no sample indices, ~ -so its class distribution would come out uniform without any error being signalled ~ -(issue #14) -- rebuild the forest with :remove-sample-indices? nil" depth))))))) + ;; NIL is not the only way to have nothing to count. A split whose + ;; sampled attribute is constant over the node's rows gets + ;; threshold = min = max from MAKE-RANDOM-TEST, and with the >= + ;; convention every row goes left -- leaving the right child a leaf whose + ;; SAMPLE-INDICES is a real but zero-length array. CLASS-DISTRIBUTION + ;; divides by a zero sum either way and returns a uniform distribution + ;; without signalling. Measured: 3 of letter's 26936 leaves at + ;; :max-depth 20. + (let ((indices (node-sample-indices node))) + (unless (and indices (plusp (length indices))) + (error 'packed-build-error + :detail (format nil "a leaf at depth ~D has ~:[no sample ~ +indices at all~;an empty sample-indices array~], so its class distribution would come out ~ +uniform without any error being signalled -- if the forest has been pruned, rebuild it ~ +with :remove-sample-indices? nil (issue #14)" depth indices)))))))) (dolist (dtree dtrees) (walk (dtree-root dtree) 0))))) diff --git a/t/packed.lisp b/t/packed.lisp index def8a08..f318a54 100644 --- a/t/packed.lisp +++ b/t/packed.lisp @@ -6,7 +6,10 @@ (:import-from #:cl-random-forest/src/random-forest #:find-leaf #:dtree-root - #:node-leaf-index)) + #:node-leaf-index + #:node-test-attribute + #:node-left-node + #:node-sample-indices)) (in-package :cl-random-forest-test/packed) (defun synthetic-forest (&key (remove-sample-indices? nil) (n-tree 30)) @@ -68,6 +71,32 @@ (packed-build-error () t)) "after pruning, build-packed-topology signals on the stranded leaves"))))) +(deftest packed-topology-refuses-a-leaf-with-no-samples-to-count + ;; A leaf can have nothing to count without its SAMPLE-INDICES being NIL. When a split's + ;; sampled attribute is constant over the node's rows, MAKE-RANDOM-TEST produces + ;; threshold = min = max and every row goes left, leaving the right child a leaf holding + ;; a real but zero-length array. CLASS-DISTRIBUTION divides by a zero sum in both cases + ;; and returns a uniform distribution rather than signalling, so both must be rejected. + ;; It is rare but not hypothetical: 3 of letter's 26936 leaves at :max-depth 20. + (with-serial-kernel + (multiple-value-bind (datamatrix target) (synthetic-classification-train) + (declare (ignore target)) + (declare (ignorable datamatrix)) + (let ((forest (synthetic-forest))) + (ok (packed-topology-p (build-packed-topology forest)) + "the forest packs while every leaf has samples") + ;; Empty one leaf's indices, which is what such a split leaves behind. + (labels ((leftmost-leaf (node) + (if (node-test-attribute node) + (leftmost-leaf (node-left-node node)) + node))) + (setf (node-sample-indices + (leftmost-leaf (dtree-root (first (forest-dtree-list forest))))) + (make-array 0 :element-type 'fixnum))) + (ok (handler-case (progn (build-packed-topology forest) nil) + (packed-build-error () t)) + "a leaf with an empty sample-indices array is rejected"))))) + (deftest packed-topology-counts-add-up (with-serial-kernel (let* ((forest (synthetic-forest)) From 824e6adc9cbab0b015d775a30f4c5179851f8a1c Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 18:36:25 +0000 Subject: [PATCH 03/13] Add dense and CSR packed classifiers, verified against the library Layers a class-distribution payload on the packed topology: build-packed-classifier flattens each leaf's distribution into either a dense n-leaf x n-class table or a CSR (offsets/class/probability) form chosen by row size, and packed-predict sums per-tree distributions into a caller-supplied accumulator the same way class-distribution-forest does. packed-verify checks both class and full distribution element-by-element against the library, requiring exact equality rather than argmax agreement. --- src/packed.lisp | 3 +- src/packed/classifier.lisp | 187 +++++++++++++++++++++++++++++++++++++ t/packed.lisp | 52 +++++++++++ 3 files changed, 241 insertions(+), 1 deletion(-) create mode 100644 src/packed/classifier.lisp diff --git a/src/packed.lisp b/src/packed.lisp index 18e41df..531aaf3 100644 --- a/src/packed.lisp +++ b/src/packed.lisp @@ -1,5 +1,6 @@ (uiop:define-package :cl-random-forest/src/packed (:use :cl) - (:use-reexport :cl-random-forest/src/packed/topology)) + (:use-reexport :cl-random-forest/src/packed/topology) + (:use-reexport :cl-random-forest/src/packed/classifier)) (in-package :cl-random-forest/src/packed) diff --git a/src/packed/classifier.lisp b/src/packed/classifier.lisp new file mode 100644 index 0000000..a39ad47 --- /dev/null +++ b/src/packed/classifier.lisp @@ -0,0 +1,187 @@ +(defpackage :cl-random-forest/src/packed/classifier + (:use #:cl + #:cl-random-forest/src/packed/topology) + (:import-from #:cl-random-forest/src/random-forest + #:forest-dtree-list + #:forest-n-class + #:dtree-root + #:node-test-attribute + #:node-left-node + #:node-right-node + #:node-class-distribution + #:class-distribution-forest + #:predict-forest + #:argmax) + (:export #:packed-classifier + #:packed-classifier-p + #:packed-classifier-topology + #:packed-classifier-n-class + #:packed-classifier-kind + #:packed-classifier-table + #:packed-classifier-offsets + #:packed-classifier-class + #:packed-classifier-probability + #:%make-packed-classifier + #:build-packed-classifier + #:make-packed-accumulator + #:packed-predict + #:packed-verify)) + +(in-package :cl-random-forest/src/packed/classifier) + +(defstruct (packed-classifier (:constructor %make-packed-classifier)) + "A topology plus a leaf payload. + +KIND is :DENSE, in which case TABLE is an n-leaf x n-class array and the CSR slots are +empty; or :CSR, in which case leaf L occupies [OFFSETS[L], OFFSETS[L+1]) of CLASS and +PROBABILITY and TABLE is empty. Omitting the zeros is exact, not approximate: the values +are non-negative, so leaving out a + 0.0 changes no sum." + (topology (%make-packed-topology) :type packed-topology) + (n-class 0 :type fixnum) + (kind :dense :type (member :dense :csr)) + (table (make-array '(0 0) :element-type 'single-float) + :type (simple-array single-float (* *))) + (offsets (make-array 1 :element-type '(unsigned-byte 32)) + :type (simple-array (unsigned-byte 32) (*))) + (class (make-array 0 :element-type '(unsigned-byte 16)) + :type (simple-array (unsigned-byte 16) (*))) + (probability (make-array 0 :element-type 'single-float) + :type (simple-array single-float (*)))) + +(defun leaf-distributions (forest topology) + "A simple-vector of every leaf's distribution, indexed by the topology's leaf number. + +NODE-CLASS-DISTRIBUTION hands back the dtree's shared scratch buffer, so each one is copied +before the next leaf overwrites it." + (let ((out (make-array (packed-topology-n-leaf topology))) + (offsets (packed-topology-tree-leaf-offsets topology))) + (loop for dtree in (forest-dtree-list forest) + for tree from 0 + do (let ((local 0) + (base (aref offsets tree))) + (labels ((walk (node) + (if (node-test-attribute node) + (progn (walk (node-left-node node)) + (walk (node-right-node node))) + (progn (setf (svref out (+ base local)) + (copy-seq (node-class-distribution node))) + (incf local))))) + (walk (dtree-root dtree))))) + out)) + +(defun choose-payload (n-class) + "CSR once a dense row exceeds a cache line, dense otherwise. + +The tempting rule is the compression ratio, and it picks wrong: a 10-class model compresses +2.4x and runs 0.82x as fast, because a 40-byte dense row already fits in a cache line and +CSR's offset loads and scattered writes cost more than the bytes saved." + (if (> (* 4 n-class) 64) :csr :dense)) + +(defun build-packed-classifier (forest &key (payload :auto)) + "Flatten FOREST into a packed classifier. PAYLOAD is :AUTO, :DENSE or :CSR." + (check-type payload (member :auto :dense :csr)) + (let* ((topology (build-packed-topology forest)) + (n-class (forest-n-class forest)) + (kind (if (eq payload :auto) (choose-payload n-class) payload)) + (n-leaf (packed-topology-n-leaf topology)) + (dists (leaf-distributions forest topology))) + (ecase kind + (:dense + (let ((table (make-array (list (max n-leaf 1) n-class) + :element-type 'single-float :initial-element 0.0))) + (dotimes (row n-leaf) + (let ((d (svref dists row))) + (dotimes (k n-class) (setf (aref table row k) (aref d k))))) + (%make-packed-classifier :topology topology :n-class n-class + :kind :dense :table table))) + (:csr + (unless (< n-class 65536) + (error 'packed-build-error + :detail (format nil "~D classes exceeds a (unsigned-byte 16) class index" + n-class))) + (let ((nnz 0)) + (dotimes (row n-leaf) + (let ((d (svref dists row))) + (dotimes (k n-class) (unless (zerop (aref d k)) (incf nnz))))) + (let ((offsets (make-array (1+ n-leaf) :element-type '(unsigned-byte 32))) + (class (make-array (max nnz 1) :element-type '(unsigned-byte 16))) + (probability (make-array (max nnz 1) :element-type 'single-float)) + (cursor 0)) + (dotimes (row n-leaf) + (setf (aref offsets row) cursor) + (let ((d (svref dists row))) + (dotimes (k n-class) + (let ((p (aref d k))) + (unless (zerop p) + (setf (aref class cursor) k + (aref probability cursor) p) + (incf cursor)))))) + (setf (aref offsets n-leaf) cursor) + (%make-packed-classifier :topology topology :n-class n-class :kind :csr + :offsets offsets :class class + :probability probability))))))) + +(defun make-packed-accumulator (classifier) + "A fresh accumulator for PACKED-PREDICT. One per thread, never shared." + (make-array (packed-classifier-n-class classifier) + :element-type 'single-float :initial-element 0.0)) + +(defun packed-predict (classifier datamatrix datum-index acc) + "PREDICT-FOREST's answer for one datum. Writes only ACC." + (declare (optimize (speed 3) (safety 0)) + (type packed-classifier classifier) + (type (simple-array single-float (* *)) datamatrix) + (type (simple-array single-float (*)) acc) + (type fixnum datum-index)) + (let* ((topology (packed-classifier-topology classifier)) + (n-class (packed-classifier-n-class classifier)) + (roots (packed-topology-roots topology)) + (n-tree (packed-topology-n-tree topology))) + (declare (type (simple-array (signed-byte 32) (*)) roots) + (type fixnum n-class n-tree)) + (dotimes (k n-class) (setf (aref acc k) 0.0)) + (ecase (packed-classifier-kind classifier) + (:dense + (let ((table (packed-classifier-table classifier))) + (declare (type (simple-array single-float (* *)) table)) + (dotimes (tree n-tree) + (let ((row (packed-leaf topology datamatrix datum-index (aref roots tree)))) + (declare (type fixnum row)) + (dotimes (k n-class) (incf (aref acc k) (aref table row k))))))) + (:csr + (let ((offsets (packed-classifier-offsets classifier)) + (class (packed-classifier-class classifier)) + (probability (packed-classifier-probability classifier))) + (declare (type (simple-array (unsigned-byte 32) (*)) offsets) + (type (simple-array (unsigned-byte 16) (*)) class) + (type (simple-array single-float (*)) probability)) + (dotimes (tree n-tree) + (let ((leaf (packed-leaf topology datamatrix datum-index (aref roots tree)))) + (declare (type fixnum leaf)) + (loop for i of-type fixnum + from (aref offsets leaf) below (aref offsets (1+ leaf)) + do (incf (aref acc (aref class i)) (aref probability i)))))))) + (dotimes (k n-class) (setf (aref acc k) (/ (aref acc k) n-tree))) + (argmax acc))) + +(defun packed-verify (classifier forest datamatrix) + "Compare CLASSIFIER with FOREST over every row of DATAMATRIX. + +Returns (values class-disagreements distribution-disagreements worst-absolute-difference). +All three should be zero: the distribution is checked element by element, not merely after +ARGMAX, and exact equality is achievable because the same floats are summed in the same +order." + (let* ((n-class (packed-classifier-n-class classifier)) + (acc (make-packed-accumulator classifier)) + (class-bad 0) (dist-bad 0) (worst 0.0)) + (dotimes (i (array-dimension datamatrix 0) (values class-bad dist-bad worst)) + (let ((reference-class (predict-forest forest datamatrix i)) + (reference-dist (copy-seq (class-distribution-forest forest datamatrix i)))) + (unless (= reference-class (packed-predict classifier datamatrix i acc)) + (incf class-bad)) + (let ((row-bad nil)) + (dotimes (k n-class) + (let ((d (abs (- (aref reference-dist k) (aref acc k))))) + (when (> d 0.0) (setf row-bad t)) + (setf worst (max worst d)))) + (when row-bad (incf dist-bad))))))) diff --git a/t/packed.lisp b/t/packed.lisp index f318a54..8f1ad4b 100644 --- a/t/packed.lisp +++ b/t/packed.lisp @@ -111,3 +111,55 @@ (packed-topology-n-internal topology) (packed-topology-n-leaf topology) (packed-topology-n-tree topology)))))) + +(deftest packed-classifier-agrees-bit-for-bit + ;; Agreement on the class alone is too weak -- two different distributions can share an + ;; argmax. Compare the whole distribution, and require exact equality: the same floats + ;; are summed in the same tree and class order, so anything else is a defect. + (with-serial-kernel + (multiple-value-bind (datamatrix target) (synthetic-classification-test) + (declare (ignore target)) + (let ((forest (synthetic-forest))) + (dolist (payload '(:dense :csr)) + (let ((classifier (build-packed-classifier forest :payload payload))) + (multiple-value-bind (class-bad dist-bad worst) + (packed-verify classifier forest datamatrix) + (ok (zerop class-bad) + (format nil "~A: ~D classes differ" payload class-bad)) + (ok (zerop dist-bad) + (format nil "~A: ~D distributions differ" payload dist-bad)) + (ok (zerop worst) + (format nil "~A: worst absolute difference ~,10F" payload worst))))))))) + +(deftest packed-classifier-auto-picks-on-the-dense-row-size + ;; CSR once a dense row exceeds a cache line, dense below. Not the compression ratio: + ;; a 10-class model compresses 2.4x on that measure and runs 0.82x as fast. + ;; + ;; The rule is unit-tested on both sides of the boundary, because no fixture forest has + ;; enough classes to reach the CSR side -- the synthetic set has 4. + (let ((rule #'cl-random-forest/src/packed/classifier::choose-payload)) + (ok (eq :dense (funcall rule 1)) "1 class is dense") + (ok (eq :dense (funcall rule 16)) "16 classes is dense, a row being exactly 64 bytes") + (ok (eq :csr (funcall rule 17)) "17 classes is csr, a row exceeding a cache line") + (ok (eq :csr (funcall rule 26)) "26 classes is csr")) + (with-serial-kernel + (let ((forest (synthetic-forest))) + (ok (eq :dense (packed-classifier-kind (build-packed-classifier forest))) + (format nil "a ~D-class forest selects dense" +synthetic-n-class+))))) + +(deftest packed-classifier-csr-holds-only-the-non-zero-entries + (with-serial-kernel + (let* ((forest (synthetic-forest)) + (topology (build-packed-topology forest)) + (dense (build-packed-classifier forest :payload :dense)) + (csr (build-packed-classifier forest :payload :csr)) + (n-leaf (packed-topology-n-leaf topology)) + (n-class (packed-classifier-n-class dense)) + (expected 0)) + (dotimes (row n-leaf) + (dotimes (k n-class) + (unless (zerop (aref (packed-classifier-table dense) row k)) + (incf expected)))) + (ok (= expected (length (packed-classifier-probability csr))) + (format nil "~D non-zero entries, CSR stores ~D" + expected (length (packed-classifier-probability csr))))))) From 75b0a689bf06e6417453dab64e9510b64a896c57 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 18:54:24 +0000 Subject: [PATCH 04/13] Add tree-major batch prediction --- src/packed/classifier.lisp | 63 ++++++++++++++++++++++++++++++++++++++ t/packed.lisp | 28 +++++++++++++++++ 2 files changed, 91 insertions(+) diff --git a/src/packed/classifier.lisp b/src/packed/classifier.lisp index a39ad47..5fcf0ea 100644 --- a/src/packed/classifier.lisp +++ b/src/packed/classifier.lisp @@ -24,7 +24,9 @@ #:%make-packed-classifier #:build-packed-classifier #:make-packed-accumulator + #:make-packed-accumulators #:packed-predict + #:packed-predict-batch #:packed-verify)) (in-package :cl-random-forest/src/packed/classifier) @@ -164,6 +166,67 @@ CSR's offset loads and scattered writes cost more than the bytes saved." (dotimes (k n-class) (setf (aref acc k) (/ (aref acc k) n-tree))) (argmax acc))) +(defun make-packed-accumulators (classifier tile) + "Accumulators for PACKED-PREDICT-BATCH: one row per datum in the tile." + (make-array (list tile (packed-classifier-n-class classifier)) + :element-type 'single-float :initial-element 0.0)) + +(defun packed-predict-batch (classifier datamatrix start end accs out) + "Predict rows [START,END) a tree at a time, writing classes into OUT indexed from zero. + +Walking one tree over the whole tile before moving to the next touches each tree's arrays +once per tile instead of once per datum. The cost is holding (END - START) x n-class +accumulators, which is why a tile of one loses and a tile of a few hundred wins." + (declare (optimize (speed 3) (safety 0)) + (type packed-classifier classifier) + (type (simple-array single-float (* *)) datamatrix accs) + (type (simple-array fixnum (*)) out) + (type fixnum start end)) + (let* ((topology (packed-classifier-topology classifier)) + (n-class (packed-classifier-n-class classifier)) + (roots (packed-topology-roots topology)) + (n-tree (packed-topology-n-tree topology)) + (tile (- end start))) + (declare (type (simple-array (signed-byte 32) (*)) roots) + (type fixnum n-class n-tree tile)) + (dotimes (r tile) + (dotimes (k n-class) (setf (aref accs r k) 0.0))) + (ecase (packed-classifier-kind classifier) + (:dense + (let ((table (packed-classifier-table classifier))) + (declare (type (simple-array single-float (* *)) table)) + (dotimes (tree n-tree) + (let ((root (aref roots tree))) + (dotimes (r tile) + (let ((row (packed-leaf topology datamatrix (+ start r) root))) + (declare (type fixnum row)) + (dotimes (k n-class) + (incf (aref accs r k) (aref table row k))))))))) + (:csr + (let ((offsets (packed-classifier-offsets classifier)) + (class (packed-classifier-class classifier)) + (probability (packed-classifier-probability classifier))) + (declare (type (simple-array (unsigned-byte 32) (*)) offsets) + (type (simple-array (unsigned-byte 16) (*)) class) + (type (simple-array single-float (*)) probability)) + (dotimes (tree n-tree) + (let ((root (aref roots tree))) + (dotimes (r tile) + (let ((leaf (packed-leaf topology datamatrix (+ start r) root))) + (declare (type fixnum leaf)) + (loop for i of-type fixnum + from (aref offsets leaf) below (aref offsets (1+ leaf)) + do (incf (aref accs r (aref class i)) + (aref probability i)))))))))) + (dotimes (r tile out) + (let ((best most-negative-single-float) + (best-k 0)) + (declare (type single-float best) (type fixnum best-k)) + (dotimes (k n-class) + (let ((v (/ (aref accs r k) n-tree))) + (when (> v best) (setf best v best-k k)))) + (setf (aref out r) best-k))))) + (defun packed-verify (classifier forest datamatrix) "Compare CLASSIFIER with FOREST over every row of DATAMATRIX. diff --git a/t/packed.lisp b/t/packed.lisp index 8f1ad4b..a7d5526 100644 --- a/t/packed.lisp +++ b/t/packed.lisp @@ -163,3 +163,31 @@ (ok (= expected (length (packed-classifier-probability csr))) (format nil "~D non-zero entries, CSR stores ~D" expected (length (packed-classifier-probability csr))))))) + +(deftest packed-batch-agrees-with-per-datum + ;; Tree-major batching walks one tree over a whole tile before moving to the next, which + ;; changes the order arrays are touched but not the arithmetic: each datum's accumulator + ;; receives the same values in the same tree order. + (with-serial-kernel + (multiple-value-bind (datamatrix target) (synthetic-classification-test) + (declare (ignore target)) + (let* ((forest (synthetic-forest)) + (n-rows (array-dimension datamatrix 0))) + (dolist (payload '(:dense :csr)) + (let* ((classifier (build-packed-classifier forest :payload payload)) + (acc (make-packed-accumulator classifier)) + (bad 0)) + (dolist (tile (list 1 7 64 n-rows)) + (let ((accs (make-packed-accumulators classifier tile)) + (out (make-array tile :element-type 'fixnum)) + (i 0)) + (loop while (< i n-rows) + do (let ((end (min n-rows (+ i tile)))) + (packed-predict-batch classifier datamatrix i end accs out) + (loop for j from i below end + do (unless (= (aref out (- j i)) + (packed-predict classifier datamatrix j acc)) + (incf bad))) + (setf i end))))) + (ok (zerop bad) + (format nil "~A: ~D batch answers differ from per-datum" payload bad)))))))) From 8c2f6c51fa7edac9dae3c19c84f5d4315c624757 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 19:07:36 +0000 Subject: [PATCH 05/13] Serialise packed classifiers as a header plus raw arrays Adds src/packed/io.lisp: PACKED-SAVE writes a magic/version/byte-order header followed by the topology and payload arrays as little-endian words; PACKED-LOAD reconstructs a packed-classifier from one, refusing files with a bad magic, unknown version, mismatched byte order, or truncated data via PACKED-LOAD-ERROR. Byte order is recorded, not converted -- a model must be reloaded on a machine of the same order. Float bits go through SBCL/CCL fast paths with an ANSI-only portable fallback used as the cross-implementation reference. --- src/packed.lisp | 3 +- src/packed/io.lisp | 203 +++++++++++++++++++++++++++++++++++++++++++++ t/packed.lisp | 80 ++++++++++++++++++ 3 files changed, 285 insertions(+), 1 deletion(-) create mode 100644 src/packed/io.lisp diff --git a/src/packed.lisp b/src/packed.lisp index 531aaf3..fa8b83f 100644 --- a/src/packed.lisp +++ b/src/packed.lisp @@ -1,6 +1,7 @@ (uiop:define-package :cl-random-forest/src/packed (:use :cl) (:use-reexport :cl-random-forest/src/packed/topology) - (:use-reexport :cl-random-forest/src/packed/classifier)) + (:use-reexport :cl-random-forest/src/packed/classifier) + (:use-reexport :cl-random-forest/src/packed/io)) (in-package :cl-random-forest/src/packed) diff --git a/src/packed/io.lisp b/src/packed/io.lisp new file mode 100644 index 0000000..f560ff3 --- /dev/null +++ b/src/packed/io.lisp @@ -0,0 +1,203 @@ +(defpackage :cl-random-forest/src/packed/io + (:use #:cl + #:cl-random-forest/src/packed/topology + #:cl-random-forest/src/packed/classifier) + (:export #:packed-save + #:packed-load + #:packed-load-error + #:packed-load-error-detail + #:single-float-to-bits + #:bits-to-single-float + #:%portable-single-float-to-bits)) + +(in-package :cl-random-forest/src/packed/io) + +(define-condition packed-load-error (error) + ((detail :initarg :detail :reader packed-load-error-detail)) + (:report (lambda (c s) + (format s "cannot load this packed model: ~A" (packed-load-error-detail c))))) + +;; A DEFCONSTANT whose value is an array signals on reload, the new value not being EQL to +;; the old, so the magic is a DEFPARAMETER. The other two are numbers and are fine. +(defparameter *magic* + #.(map '(simple-array (unsigned-byte 8) (*)) #'char-code "CLRFPACK")) +(defconstant +version+ 1) +(defconstant +byte-order-probe+ #x01020304) + +;;;; Floats as bits +;;;; +;;;; The file holds IEEE-754 bit patterns. SBCL and CCL can produce them directly; the +;;;; portable version is the reference the tests hold the fast paths to, and the fallback +;;;; anywhere else. + +(defun %portable-single-float-to-bits (x) + "IEEE-754 single-precision bits of X, in ANSI Common Lisp only." + (declare (type single-float x)) + (if (zerop x) + (if (minusp (float-sign x)) #x80000000 0) + (multiple-value-bind (significand exponent sign) (integer-decode-float x) + (let ((biased (+ exponent 23 127))) + (logior (if (minusp sign) #x80000000 0) + (ash (logand biased #xff) 23) + (logand significand #x7fffff)))))) + +(defun %portable-bits-to-single-float (bits) + "The single-float whose IEEE-754 bits are BITS, in ANSI Common Lisp only." + (declare (type (unsigned-byte 32) bits)) + (let* ((sign (if (logbitp 31 bits) -1.0 1.0)) + (exponent (ldb (byte 8 23) bits)) + (fraction (ldb (byte 23 0) bits))) + (cond ((and (zerop exponent) (zerop fraction)) (* sign 0.0)) + ((zerop exponent) (* sign (scale-float (float fraction 1.0) -149))) + (t (* sign (scale-float (float (logior fraction (ash 1 23)) 1.0) + (- exponent 127 23))))))) + +(defun single-float-to-bits (x) + "IEEE-754 single-precision bits of X." + (declare (type single-float x)) + #+sbcl (ldb (byte 32 0) (sb-kernel:single-float-bits x)) + #+ccl (ldb (byte 32 0) (ccl::single-float-bits x)) + #-(or sbcl ccl) (%portable-single-float-to-bits x)) + +(defun bits-to-single-float (bits) + "The single-float whose IEEE-754 bits are BITS." + (declare (type (unsigned-byte 32) bits)) + #+sbcl (sb-kernel:make-single-float + (if (logbitp 31 bits) (- bits (ash 1 32)) bits)) + #+ccl (ccl::host-single-float-from-unsigned-byte-32 bits) + #-(or sbcl ccl) (%portable-bits-to-single-float bits)) + +;;;; Byte-level primitives + +(defun write-u32 (value stream) + (declare (type (unsigned-byte 32) value)) + (dotimes (i 4) (write-byte (ldb (byte 8 (* 8 i)) value) stream))) + +(defun read-u32 (stream) + (let ((value 0)) + (dotimes (i 4 value) + (let ((byte (read-byte stream nil nil))) + (unless byte (error 'packed-load-error :detail "the file ends mid-header")) + (setf value (logior value (ash byte (* 8 i)))))))) + +(defun write-array (array stream bits encoder) + "Write ARRAY as little-endian words of BITS bits, ENCODER mapping element to integer." + (let* ((bytes-per (floor bits 8)) + (n (length array)) + (buffer (make-array (* n bytes-per) :element-type '(unsigned-byte 8)))) + (dotimes (i n) + (let ((word (funcall encoder (aref array i)))) + (dotimes (b bytes-per) + (setf (aref buffer (+ (* i bytes-per) b)) (ldb (byte 8 (* 8 b)) word))))) + (write-sequence buffer stream))) + +(defun read-array (stream n bits element-type decoder) + "Read N little-endian words of BITS bits, DECODER mapping integer to element." + (let* ((bytes-per (floor bits 8)) + (buffer (make-array (* n bytes-per) :element-type '(unsigned-byte 8))) + (got (read-sequence buffer stream)) + (out (make-array n :element-type element-type))) + (unless (= got (* n bytes-per)) + (error 'packed-load-error + :detail (format nil "wanted ~D bytes of array data, got ~D" + (* n bytes-per) got))) + (dotimes (i n out) + (let ((word 0)) + (dotimes (b bytes-per) + (setf word (logior word (ash (aref buffer (+ (* i bytes-per) b)) (* 8 b))))) + (setf (aref out i) (funcall decoder word)))))) + +(defun u32-of-s32 (x) (ldb (byte 32 0) x)) +(defun s32-of-u32 (x) (if (logbitp 31 x) (- x (ash 1 32)) x)) + +;;;; Save and load + +(defun packed-save (classifier pathname) + "Write CLASSIFIER to PATHNAME. Returns PATHNAME. + +The format is a header followed by the arrays as little-endian words. Byte order is *not* +converted on load -- the writing machine's is recorded and a mismatch is refused, which is +worth more than conversion code that could not be exercised here." + (let* ((topology (packed-classifier-topology classifier)) + (n-leaf (packed-topology-n-leaf topology)) + (n-class (packed-classifier-n-class classifier)) + (csr (eq (packed-classifier-kind classifier) :csr))) + (with-open-file (s pathname :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (write-sequence *magic* s) + (write-u32 +version+ s) + (write-u32 +byte-order-probe+ s) + (write-u32 (if csr 1 0) s) + (write-u32 (packed-topology-n-tree topology) s) + (write-u32 (packed-topology-n-internal topology) s) + (write-u32 n-leaf s) + (write-u32 n-class s) + (write-array (packed-topology-feature topology) s 32 #'identity) + (write-array (packed-topology-threshold topology) s 32 #'single-float-to-bits) + (write-array (packed-topology-left topology) s 32 #'u32-of-s32) + (write-array (packed-topology-right topology) s 32 #'u32-of-s32) + (write-array (packed-topology-roots topology) s 32 #'u32-of-s32) + (write-array (packed-topology-tree-leaf-offsets topology) s 32 #'identity) + (if csr + (progn + (write-array (packed-classifier-offsets classifier) s 32 #'identity) + (write-array (packed-classifier-class classifier) s 16 #'identity) + (write-array (packed-classifier-probability classifier) s 32 + #'single-float-to-bits)) + (let* ((table (packed-classifier-table classifier)) + (flat (make-array (* (max n-leaf 1) n-class) + :element-type 'single-float))) + (dotimes (row (max n-leaf 1)) + (dotimes (k n-class) + (setf (aref flat (+ (* row n-class) k)) (aref table row k)))) + (write-array flat s 32 #'single-float-to-bits)))) + pathname)) + +(defun packed-load (pathname) + "Read a packed classifier written by PACKED-SAVE." + (with-open-file (s pathname :direction :input :element-type '(unsigned-byte 8)) + (let ((magic (make-array (length *magic*) :element-type '(unsigned-byte 8)))) + (unless (and (= (read-sequence magic s) (length *magic*)) + (equalp magic *magic*)) + (error 'packed-load-error :detail "not a packed forest file"))) + (let ((version (read-u32 s))) + (unless (= version +version+) + (error 'packed-load-error + :detail (format nil "version ~D, this build reads ~D" version +version+)))) + (let ((order (read-u32 s))) + (unless (= order +byte-order-probe+) + (error 'packed-load-error + :detail (format nil "written on a machine of different byte order (~8,'0X)" + order)))) + (let* ((csr (= 1 (read-u32 s))) + (n-tree (read-u32 s)) + (n-internal (read-u32 s)) + (n-leaf (read-u32 s)) + (n-class (read-u32 s)) + (topology + (%make-packed-topology + :n-tree n-tree :n-internal n-internal :n-leaf n-leaf + :feature (read-array s n-internal 32 '(unsigned-byte 32) #'identity) + :threshold (read-array s n-internal 32 'single-float #'bits-to-single-float) + :left (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32) + :right (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32) + :roots (read-array s n-tree 32 '(signed-byte 32) #'s32-of-u32) + :tree-leaf-offsets (read-array s n-tree 32 '(unsigned-byte 32) + #'identity)))) + (if csr + (let* ((offsets (read-array s (1+ n-leaf) 32 '(unsigned-byte 32) #'identity)) + (nnz (aref offsets n-leaf))) + (%make-packed-classifier + :topology topology :n-class n-class :kind :csr + :offsets offsets + :class (read-array s nnz 16 '(unsigned-byte 16) #'identity) + :probability (read-array s nnz 32 'single-float #'bits-to-single-float))) + (let ((flat (read-array s (* (max n-leaf 1) n-class) 32 'single-float + #'bits-to-single-float)) + (table (make-array (list (max n-leaf 1) n-class) + :element-type 'single-float))) + (dotimes (row (max n-leaf 1)) + (dotimes (k n-class) + (setf (aref table row k) (aref flat (+ (* row n-class) k))))) + (%make-packed-classifier + :topology topology :n-class n-class :kind :dense :table table)))))) diff --git a/t/packed.lisp b/t/packed.lisp index a7d5526..5383b8b 100644 --- a/t/packed.lisp +++ b/t/packed.lisp @@ -191,3 +191,83 @@ (setf i end))))) (ok (zerop bad) (format nil "~A: ~D batch answers differ from per-datum" payload bad)))))))) + +(deftest packed-round-trips-through-a-file + (with-serial-kernel + (multiple-value-bind (datamatrix target) (synthetic-classification-test) + (declare (ignore target)) + (let ((forest (synthetic-forest))) + (dolist (payload '(:dense :csr)) + (uiop:with-temporary-file (:pathname path :type "packed") + (let* ((original (build-packed-classifier forest :payload payload)) + (acc (make-packed-accumulator original))) + (packed-save original path) + (let* ((restored (packed-load path)) + (restored-acc (make-packed-accumulator restored)) + (bad 0)) + (ok (eq (packed-classifier-kind restored) payload) + (format nil "~A survives the round trip" payload)) + (dotimes (i (array-dimension datamatrix 0)) + (unless (= (packed-predict original datamatrix i acc) + (packed-predict restored datamatrix i restored-acc)) + (incf bad))) + (ok (zerop bad) + (format nil "~A: ~D predictions differ after reload" payload bad)))))))))) + +(deftest packed-load-rejects-a-file-it-cannot-trust + (with-serial-kernel + (let ((forest (synthetic-forest))) + (uiop:with-temporary-file (:pathname path :type "packed") + (packed-save (build-packed-classifier forest) path) + ;; Corrupt the magic. + (with-open-file (s path :direction :io :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (file-position s 0) + (write-byte 0 s)) + (ok (handler-case (progn (packed-load path) nil) + (packed-load-error () t)) + "a bad magic number is rejected")) + (uiop:with-temporary-file (:pathname path :type "packed") + (packed-save (build-packed-classifier forest) path) + ;; Corrupt the version, which lives at byte offset 8. + (with-open-file (s path :direction :io :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (file-position s 8) + (write-byte 99 s)) + (ok (handler-case (progn (packed-load path) nil) + (packed-load-error () t)) + "an unknown version is rejected")) + (uiop:with-temporary-file (:pathname path :type "packed") + (packed-save (build-packed-classifier forest) path) + ;; Corrupt the byte-order probe, at offset 12. + (with-open-file (s path :direction :io :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (file-position s 12) + (write-byte 99 s)) + (ok (handler-case (progn (packed-load path) nil) + (packed-load-error () t)) + "a byte-order mismatch is rejected")) + (uiop:with-temporary-file (:pathname path :type "packed") + (packed-save (build-packed-classifier forest) path) + ;; Truncate. + (let ((bytes (with-open-file (s path :element-type '(unsigned-byte 8)) + (file-length s)))) + (with-open-file (s path :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (dotimes (i (floor bytes 2)) (write-byte 0 s)))) + (ok (handler-case (progn (packed-load path) nil) + (packed-load-error () t)) + "a truncated file is rejected"))))) + +(deftest packed-float-bits-round-trip + ;; The fast paths exist per implementation; the portable fallback is the reference. They + ;; must agree, or a model saved on one implementation would not load on another. + (let ((values (list 0.0 1.0 -1.0 0.5 -0.5 3.14159 1.0e-8 1.0e8 + most-positive-single-float least-positive-normalized-single-float))) + (dolist (v values) + (ok (= v (cl-random-forest/src/packed::bits-to-single-float + (cl-random-forest/src/packed::single-float-to-bits v))) + (format nil "~S survives the bit round trip" v)) + (ok (= (cl-random-forest/src/packed::single-float-to-bits v) + (cl-random-forest/src/packed::%portable-single-float-to-bits v)) + (format nil "~S: fast path agrees with the portable one" v))))) From c5a64fa1db2bde6baf9de5483023319b942c99eb Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 19:21:21 +0000 Subject: [PATCH 06/13] Fix %portable-single-float-to-bits for denormals INTEGER-DECODE-FLOAT leaves a denormal's significand unnormalised, so the biased-exponent arithmetic wrote a bogus non-zero exponent field for every denormal (LEAST-POSITIVE-SINGLE-FLOAT encoded as #x00800001 where IEEE-754 says #x00000001). Branch on whether the significand is already normalised and shift denormals directly into the fraction field instead. packed-float-bits-round-trip gains true denormals and both signed zeros, and now cross-checks the portable decoder against the fast encoder in both directions -- the decode direction, and denormals specifically, were never exercised before, which is why the bug survived the original test. --- src/packed/io.lisp | 18 +++++++++++++----- t/packed.lisp | 19 ++++++++++++++++--- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/src/packed/io.lisp b/src/packed/io.lisp index f560ff3..b96e062 100644 --- a/src/packed/io.lisp +++ b/src/packed/io.lisp @@ -8,7 +8,8 @@ #:packed-load-error-detail #:single-float-to-bits #:bits-to-single-float - #:%portable-single-float-to-bits)) + #:%portable-single-float-to-bits + #:%portable-bits-to-single-float)) (in-package :cl-random-forest/src/packed/io) @@ -36,10 +37,17 @@ (if (zerop x) (if (minusp (float-sign x)) #x80000000 0) (multiple-value-bind (significand exponent sign) (integer-decode-float x) - (let ((biased (+ exponent 23 127))) - (logior (if (minusp sign) #x80000000 0) - (ash (logand biased #xff) 23) - (logand significand #x7fffff)))))) + (let ((sign-bit (if (minusp sign) #x80000000 0))) + (if (< significand (ash 1 23)) + ;; A denormal. INTEGER-DECODE-FLOAT leaves its significand unnormalised -- + ;; LEAST-POSITIVE-SINGLE-FLOAT comes back as significand 1, exponent -149 -- + ;; so the biased-exponent arithmetic below would write a bogus non-zero + ;; exponent field. IEEE-754 stores a denormal as exponent field zero and a + ;; fraction that is the value divided by 2^-149. + (logior sign-bit (ash significand (+ exponent 149))) + (logior sign-bit + (ash (logand (+ exponent 23 127) #xff) 23) + (logand significand #x7fffff))))))) (defun %portable-bits-to-single-float (bits) "The single-float whose IEEE-754 bits are BITS, in ANSI Common Lisp only." diff --git a/t/packed.lisp b/t/packed.lisp index 5383b8b..9dfddcc 100644 --- a/t/packed.lisp +++ b/t/packed.lisp @@ -262,12 +262,25 @@ (deftest packed-float-bits-round-trip ;; The fast paths exist per implementation; the portable fallback is the reference. They ;; must agree, or a model saved on one implementation would not load on another. - (let ((values (list 0.0 1.0 -1.0 0.5 -0.5 3.14159 1.0e-8 1.0e8 - most-positive-single-float least-positive-normalized-single-float))) + ;; + ;; Both directions are cross-checked, and the list includes true denormals. An earlier + ;; version of this test used only LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT and compared + ;; encoding alone, and missed that the portable encoder wrote a bogus exponent field for + ;; every denormal -- 1.4012985e-45 came out as 00800001 where IEEE-754 says 00000001. + (let ((values (list 0.0 -0.0 1.0 -1.0 0.5 -0.5 3.14159 1.0e-8 1.0e8 + most-positive-single-float + least-positive-normalized-single-float + (/ least-positive-normalized-single-float 2.0) + least-positive-single-float + (- least-positive-single-float) + (* 12345.0 least-positive-single-float)))) (dolist (v values) (ok (= v (cl-random-forest/src/packed::bits-to-single-float (cl-random-forest/src/packed::single-float-to-bits v))) (format nil "~S survives the bit round trip" v)) (ok (= (cl-random-forest/src/packed::single-float-to-bits v) (cl-random-forest/src/packed::%portable-single-float-to-bits v)) - (format nil "~S: fast path agrees with the portable one" v))))) + (format nil "~S: the fast encoder agrees with the portable one" v)) + (ok (= v (cl-random-forest/src/packed::%portable-bits-to-single-float + (cl-random-forest/src/packed::single-float-to-bits v))) + (format nil "~S: the portable decoder agrees with the fast encoder" v))))) From 359654cd0d44fe86cd3fa8f702a9bba1d4a35767 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 19:49:20 +0000 Subject: [PATCH 07/13] Declare lparallel, alexandria, svmformat, clol and clol.vector as real dependencies src/utils.lisp and src/random-forest.lisp reference these packages qualified throughout but never named them in their DEFPACKAGE forms. Package-inferred- system derives a file's dependencies only from its DEFPACKAGE clauses, so nothing ever told ASDF to load them on a path that does not go through the top-level cl-random-forest system's explicit :depends-on -- cold-loading cl-random-forest/src/packed on its own failed with "Package LPARALLEL does not exist", then, once that was fixed, the same for SVMFORMAT and CLOL.VECTOR in turn. SVMFORMAT and CLOL/CLOL.VECTOR are nicknames whose systems (cl-libsvm-format, cl-online-learning) don't match the downcased package name ASDF would otherwise guess, so cl-random-forest.asd now registers both mappings with ASDF:REGISTER-SYSTEM-PACKAGES. This is a pre-existing defect, not something the packed system introduced -- packed is simply the first thing that ever tried to load a piece of this project without going through the top-level system. Verified on a genuinely cold fasl cache, and confirmed ASDF's own computed dependency graph (ASDF:COMPONENT-SIDEWAY-DEPENDENCIES) now names all of these explicitly rather than relying on load-order accidents. No new compiler warnings versus master; full test suite still passes. Co-Authored-By: Claude Opus 5 (1M context) --- cl-random-forest.asd | 12 ++++++++++++ src/random-forest.lisp | 35 +++++++++++++++++++++++++++++++++++ src/utils.lisp | 16 ++++++++++++++++ 3 files changed, 63 insertions(+) diff --git a/cl-random-forest.asd b/cl-random-forest.asd index 3461ff3..15c4f9b 100644 --- a/cl-random-forest.asd +++ b/cl-random-forest.asd @@ -2,6 +2,18 @@ (:use :cl :asdf)) (in-package :cl-random-forest-asd) +;; SVMFORMAT is a nickname of the CL-LIBSVM-FORMAT package, and package-inferred-system +;; derives a system name by downcasing the package name -- which would look for a +;; nonexistent "svmformat" system. Registering the mapping is what lets src/utils.lisp +;; declare its dependency on the package it actually uses. +(asdf:register-system-packages "cl-libsvm-format" '(#:svmformat)) + +;; CLOL and CLOL.VECTOR are nicknames of CL-ONLINE-LEARNING and CL-ONLINE-LEARNING.VECTOR +;; respectively, both provided by the single CL-ONLINE-LEARNING system. Same reasoning as +;; the CL-LIBSVM-FORMAT mapping above: without this, src/random-forest.lisp's :import-from +;; of these nicknames would send ASDF looking for nonexistent "clol"/"clol.vector" systems. +(asdf:register-system-packages "cl-online-learning" '(#:clol #:clol.vector)) + (defsystem cl-random-forest :version "0.2" :author "Satoshi Imai" diff --git a/src/random-forest.lisp b/src/random-forest.lisp index edb61f5..82fa024 100644 --- a/src/random-forest.lisp +++ b/src/random-forest.lisp @@ -1,6 +1,41 @@ (defpackage :cl-random-forest/src/random-forest (:use #:cl #:cl-random-forest/src/utils) + ;; CLOL, CLOL.VECTOR and ALEXANDRIA are all referenced qualified below (CLOL:MAKE-ONE-VS-REST + ;; and so on) but were never named here, so ASDF's package-inferred-system never loaded them + ;; on a path that does not go through the top-level cl-random-forest system -- exactly the + ;; same defect fixed in src/utils.lisp's DEFPACKAGE, just one file further down the chain that + ;; cl-random-forest/src/packed pulls in. CLOL and CLOL.VECTOR need the extra + ;; ASDF:REGISTER-SYSTEM-PACKAGES mapping in cl-random-forest.asd for the same reason SVMFORMAT + ;; does: both are nicknames of packages provided by CL-ONLINE-LEARNING, not systems of their + ;; own. Importing these symbols does not change how the code below reads or behaves -- they + ;; stay qualified at every call site -- it only tells ASDF what to load first. + (:import-from #:clol + #:copy-learner + #:make-one-vs-rest + #:make-sparse-arow + #:make-sparse-rls + #:one-vs-rest-predict + #:sparse-arow-predict + #:sparse-arow-update + #:sparse-rls-predict + #:sparse-rls-update + #:one-vs-rest-input-dimension + #:one-vs-rest-learner-activate + #:one-vs-rest-learner-bias + #:one-vs-rest-learners-vector + #:one-vs-rest-learner-update + #:one-vs-rest-learner-weight + #:one-vs-rest-n-class + #:sparse-arow-input-dimension + #:sparse-arow-weight) + (:import-from #:clol.vector + #:make-sparse-vector + #:sparse-vector-index-vector + #:sparse-vector-value-vector) + (:import-from #:alexandria + #:iota + #:positive-integer) (:export #:make-dtree #:predict-dtree #:test-dtree diff --git a/src/utils.lisp b/src/utils.lisp index 460120d..5a69f20 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -1,6 +1,22 @@ (defpackage :cl-random-forest/src/utils (:use :cl) (:nicknames :cl-random-forest.utils :clrf.utils) + ;; LPARALLEL, ALEXANDRIA and SVMFORMAT are all used below (the parallelisation macros, + ;; PUSH-NTIMES's own macro-defining code, and the libsvm-format readers, respectively), + ;; but none of them were named here. Naming them is what tells ASDF's package-inferred- + ;; system to load them: without this, loading any system that reaches this file without + ;; going through the top-level cl-random-forest system -- cl-random-forest/src/packed, + ;; for instance -- fails on a cold cache with "Package LPARALLEL does not exist", then, + ;; once that is fixed, "Package SVMFORMAT does not exist". + ;; + ;; SVMFORMAT needs one more thing beyond this clause: it is a nickname of the + ;; CL-LIBSVM-FORMAT package, and package-inferred-system derives a dependency's system + ;; name by downcasing the package name, which would look for a nonexistent "svmformat" + ;; system. cl-random-forest.asd registers the real mapping with + ;; ASDF:REGISTER-SYSTEM-PACKAGES before this file is ever read. + (:import-from #:lparallel #:*kernel*) + (:import-from #:alexandria #:with-gensyms #:once-only) + (:import-from #:svmformat #:parse-file) (:export #:random-uniform #:random-normal #:dotimes/pdotimes From cb2a8d3c9f8e87949f8db07d972972e5756cc093 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 19:49:27 +0000 Subject: [PATCH 08/13] Document the packed system and add it to the test suite CLAUDE.md and README.org now cover cl-random-forest/src/packed: how to load it, what it buys over predict-forest, and the two things to know before relying on it (it's a snapshot of the forest at build time, and it refuses forests pruned with :remove-sample-indices? t). Give src/packed.lisp the :clrf.packed nickname the README's examples use. cl-random-forest-test/packed was already wired into the aggregate system by Task 1; this just documents the eighth suite alongside the other seven. Co-Authored-By: Claude Opus 5 (1M context) --- CLAUDE.md | 25 ++++++++++++++++++++++++- README.org | 19 +++++++++++++++++++ src/packed.lisp | 1 + 3 files changed, 44 insertions(+), 1 deletion(-) diff --git a/CLAUDE.md b/CLAUDE.md index 467dbbd..a823c8d 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -59,8 +59,9 @@ Tests are split into feature systems, each of which can be run on its own: | `cl-random-forest-test/parallel` | parallelized training accuracy (4, SBCL only) | | `cl-random-forest-test/regression` | univariate regression behaviour (5) | | `cl-random-forest-test/pruning` | global pruning behaviour (5) | +| `cl-random-forest-test/packed` | packed inference representation (11) | -`cl-random-forest-test` is the aggregate that runs all seven. +`cl-random-forest-test` is the aggregate that runs all eight. `cl-random-forest-test/fixture` holds the shared dataset loaders and helpers and has no tests. Load the feature system first (`ql:quickload` or `asdf:load-system`), then: @@ -79,6 +80,7 @@ Test/example caveats: and three `refine-learner-process-*`) need no network: they use `cl-random-forest-test/fixture`'s deterministic synthetic data, or build their own. Everything else downloads datasets. +- `cl-random-forest-test/packed` uses the fixture's synthetic data and needs no network. - Of the regression and pruning suites' ten tests, seven are **property assertions**, not pinned accuracy numbers, and three deliberately pin bugs that are still open: `regression-refine-learner-default-gamma-diverges` (issue #16), `pruning-strands-leaves-without-sample-indices` (issue #14) and @@ -185,6 +187,27 @@ refine learner before training again. the kernel to `nil` restores serial execution with no recompilation. Parallelized: `make-forest`, `make-regression-forest`, `make-refine-dataset`, `train-refine-learner`. +### Packed inference + +`src/packed/` is a separate system, `cl-random-forest/src/packed`, that the core does not +depend on and the facade does not re-export. Load it explicitly: + +```lisp +(ql:quickload :cl-random-forest/src/packed) +``` + +It flattens a trained forest into arrays for inference: 5-8x faster than `predict-forest`, +reentrant where `predict-forest` is not, and serialisable. It is a derived read-only view -- +training, pruning, feature importance and reconstruction all keep using the `node` structs. + +Two things to know. A packed model is a snapshot: prune the forest and the packed copy goes +on predicting with the old structure, silently. And `build-packed-topology` refuses a forest +built with `:remove-sample-indices? t` whose leaves have lost their indices, because their +class distributions would come out uniform rather than signalling (issue #14). + +The design and the measurements behind it are in `docs/packed-forest-layout.md` and +`docs/superpowers/specs/2026-08-06-packed-forest-design.md`. + ## Known broken code `src/feature-importance.lisp` and `src/reconstruction.lisp` `:use` only the *exported* symbols of diff --git a/README.org b/README.org index 7f73d08..f294751 100644 --- a/README.org +++ b/README.org @@ -182,6 +182,25 @@ The following figure shows the accuracy for test dataset and the number of leaf [[./docs/img/clrf-mnist-pruning.png]] +**** Packed inference + +For serving a trained model, =cl-random-forest/src/packed= flattens a forest into arrays: +5-8x faster than =predict-forest=, safe to call from several threads, and serialisable. + +#+BEGIN_SRC lisp +(ql:quickload :cl-random-forest/src/packed) + +(defparameter *packed* (clrf.packed:build-packed-classifier *forest*)) +(defparameter *acc* (clrf.packed:make-packed-accumulator *packed*)) + +(clrf.packed:packed-predict *packed* *datamatrix* 0 *acc*) + +(clrf.packed:packed-save *packed* #p"model.packed") +(defparameter *reloaded* (clrf.packed:packed-load #p"model.packed")) +#+END_SRC + +One accumulator per thread. The packed model is a snapshot of the forest at build time. + **** Parallelization The following several functions can be parallelized with [[https://lparallel.org/][lparallel]]. diff --git a/src/packed.lisp b/src/packed.lisp index fa8b83f..c0db616 100644 --- a/src/packed.lisp +++ b/src/packed.lisp @@ -1,5 +1,6 @@ (uiop:define-package :cl-random-forest/src/packed (:use :cl) + (:nicknames :clrf.packed) (:use-reexport :cl-random-forest/src/packed/topology) (:use-reexport :cl-random-forest/src/packed/classifier) (:use-reexport :cl-random-forest/src/packed/io)) From d0b7b10552d99b5963adda31d778379ec6eb38e6 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 20:39:50 +0000 Subject: [PATCH 09/13] Validate packed-load's arrays before trusting them packed-load reconstructed LEFT, RIGHT, ROOTS, CSR OFFSETS and CSR CLASS straight from file bytes with no range checks, unlike build-packed-topology, which validates exhaustively before its own (safety 0) traversal ever runs. A one-byte header corruption (n-class decremented from 4 to 2) loaded with no error into a model whose dense table was then read at the wrong row stride, every leaf distribution silently wrong. Worse, a corrupt CSR class[i] >= n-class was never caught, which at (safety 0) is an out-of-bounds *write* into the caller's accumulator in packed-predict's CSR path, not just a wrong answer. Add validate-topology-arrays and validate-csr-arrays, run before packed-load returns. They check that every LEFT/RIGHT/ROOTS entry addresses a real internal node or leaf, TREE-LEAF-OFFSETS is a non-decreasing partition starting at 0, the header's four counts are sane (n-tree and n-class positive, all four non-negative), and, for a CSR file, OFFSETS is a non-decreasing partition ending at (length CLASS) = (length PROBABILITY) with every class id in range. Thresholds and leaf probabilities are deliberately left unchecked -- any bit pattern is a legal float, and NaN is not this layer's problem. Also, while touching packed-load: bind read-array's results as let* variables in file order before constructing the topology, instead of passing each read-array call inline as a keyword argument. :left and :right share type and length, so transposing those two keywords was a cosmetic-looking edit that would have silently swapped every split's branches with no error at any layer. And fix packed-save's docstring, which claimed the writing machine's byte order is recorded and a mismatch refused -- write-u32/read-u32 and single-float-to-bits are endianness-independent by construction, so the format never needed that, and +byte-order-probe+ is just a second, distinctive magic number. t/packed.lisp: the truncated-file corruption test reopened the file with :if-exists :supersede and wrote zero bytes over the first half, which zeroed the magic along with everything else and never reached the short-read paths it exists to exercise -- the first case in the same test already covers a corrupted magic. Fixed to read the original bytes into a buffer and truncate that instead. Added two more corruption cases alongside it: a decremented n-class (built CSR, so a class id in the file overflows the corrupted count) and a corrupted LEFT entry, whose byte offset is computed from the header rather than hardcoded. Both loaded with no error before this change. Co-Authored-By: Claude Opus 5 (1M context) --- src/packed/io.lisp | 169 ++++++++++++++++++++++++++++++++++++--------- t/packed.lisp | 57 +++++++++++++-- 2 files changed, 189 insertions(+), 37 deletions(-) diff --git a/src/packed/io.lisp b/src/packed/io.lisp index b96e062..263dd56 100644 --- a/src/packed/io.lisp +++ b/src/packed/io.lisp @@ -118,14 +118,106 @@ (defun u32-of-s32 (x) (ldb (byte 32 0) x)) (defun s32-of-u32 (x) (if (logbitp 31 x) (- x (ash 1 32)) x)) +;;;; Loaded-array validation +;;;; +;;;; BUILD-PACKED-TOPOLOGY validates exhaustively before anything reaches its (safety 0) +;;;; traversal. PACKED-LOAD reconstructs the same arrays from bytes it does not control, so +;;;; it owes them the same discipline: every index that PACKED-LEAF or the CSR loop in +;;;; PACKED-PREDICT will follow at (safety 0) is checked here first, where a bad one is an +;;;; ordinary error instead of an out-of-bounds read or write. Thresholds and the leaf +;;;; payload are not checked -- any bit pattern is a legal float, and NaN is not this +;;;; layer's problem. + +(defun check-header-count (name value &key positive) + "Signal PACKED-LOAD-ERROR unless VALUE is a valid header count: non-negative always, and +positive too when POSITIVE is true. READ-U32 cannot actually hand back a negative value, but +the check is stated explicitly rather than left as an accident of the encoding." + (unless (<= 0 value) + (error 'packed-load-error :detail (format nil "header ~A is negative: ~D" name value))) + (when (and positive (not (plusp value))) + (error 'packed-load-error + :detail (format nil "header ~A must be positive, got ~D" name value)))) + +(defun check-child-reference (array-name index value n-internal n-leaf) + "Signal PACKED-LOAD-ERROR unless VALUE is a valid child reference at ARRAY-NAME[INDEX]: +either an internal-node index in [0, N-INTERNAL), or the BUILD-PACKED-TOPOLOGY encoding of a +leaf, `~L` for some leaf L in [0, N-LEAF)." + (if (minusp value) + (let ((leaf (lognot value))) + (unless (< -1 leaf n-leaf) + (error 'packed-load-error + :detail (format nil "~A[~D] = ~D references leaf ~D, outside [0,~D)" + array-name index value leaf n-leaf)))) + (unless (< value n-internal) + (error 'packed-load-error + :detail (format nil "~A[~D] = ~D, outside the internal-node range [0,~D)" + array-name index value n-internal))))) + +(defun validate-topology-arrays (n-internal n-leaf n-tree left right roots tree-leaf-offsets) + "Signal PACKED-LOAD-ERROR if LEFT, RIGHT, ROOTS or TREE-LEAF-OFFSETS are not internally +consistent with the header counts N-INTERNAL, N-LEAF and N-TREE." + (dotimes (i n-internal) + (check-child-reference "left" i (aref left i) n-internal n-leaf) + (check-child-reference "right" i (aref right i) n-internal n-leaf)) + (dotimes (tree n-tree) + (check-child-reference "roots" tree (aref roots tree) n-internal n-leaf)) + (unless (zerop (aref tree-leaf-offsets 0)) + (error 'packed-load-error + :detail (format nil "tree-leaf-offsets[0] = ~D, must start at 0" + (aref tree-leaf-offsets 0)))) + (let ((previous 0)) + (dotimes (tree n-tree) + (let ((offset (aref tree-leaf-offsets tree))) + (when (< offset previous) + (error 'packed-load-error + :detail (format nil "tree-leaf-offsets[~D] = ~D is less than the previous ~ +entry ~D" tree offset previous))) + (unless (or (< offset n-leaf) (and (zerop n-leaf) (zerop offset))) + (error 'packed-load-error + :detail (format nil "tree-leaf-offsets[~D] = ~D, outside [0,~D)" + tree offset n-leaf))) + (setf previous offset))))) + +(defun validate-csr-arrays (n-leaf n-class offsets class probability) + "Signal PACKED-LOAD-ERROR unless OFFSETS, CLASS and PROBABILITY are a valid CSR partition +of N-LEAF rows over N-CLASS columns." + (unless (zerop (aref offsets 0)) + (error 'packed-load-error + :detail (format nil "csr offsets[0] = ~D, must start at 0" (aref offsets 0)))) + (let ((previous (aref offsets 0))) + (loop for i from 1 to n-leaf + do (let ((offset (aref offsets i))) + (when (< offset previous) + (error 'packed-load-error + :detail (format nil "csr offsets[~D] = ~D is less than the previous ~ +entry ~D" i offset previous))) + (setf previous offset)))) + (let ((nnz (aref offsets n-leaf))) + (unless (= nnz (length class)) + (error 'packed-load-error + :detail (format nil "csr offsets[~D] = ~D but class has ~D entries" + n-leaf nnz (length class)))) + (unless (= nnz (length probability)) + (error 'packed-load-error + :detail (format nil "csr offsets[~D] = ~D but probability has ~D entries" + n-leaf nnz (length probability))))) + (dotimes (i (length class)) + (unless (< (aref class i) n-class) + (error 'packed-load-error + :detail (format nil "csr class[~D] = ~D, outside [0,~D)" + i (aref class i) n-class))))) + ;;;; Save and load (defun packed-save (classifier pathname) "Write CLASSIFIER to PATHNAME. Returns PATHNAME. -The format is a header followed by the arrays as little-endian words. Byte order is *not* -converted on load -- the writing machine's is recorded and a mismatch is refused, which is -worth more than conversion code that could not be exercised here." +The format is a header followed by the arrays as little-endian words: WRITE-U32 always +serialises LSB-first and SINGLE-FLOAT-TO-BITS yields an endianness-independent IEEE-754 bit +pattern, so the file is byte-order independent by construction and round-trips identically +on any machine. +BYTE-ORDER-PROBE+ is not there to catch a real mismatch, then -- it is a +second, distinctive magic number, cheap insurance that the header was not merely truncated +or shifted past the point the first magic check looks at." (let* ((topology (packed-classifier-topology classifier)) (n-leaf (packed-topology-n-leaf topology)) (n-class (packed-classifier-n-class classifier)) @@ -162,7 +254,12 @@ worth more than conversion code that could not be exercised here." pathname)) (defun packed-load (pathname) - "Read a packed classifier written by PACKED-SAVE." + "Read a packed classifier written by PACKED-SAVE. + +Every array is checked against the header counts before this returns: LEFT, RIGHT, ROOTS, +TREE-LEAF-OFFSETS and, for a CSR file, OFFSETS and CLASS. A corrupt file the topology +traversal or the CSR prediction loop would otherwise read or write out of bounds at +(safety 0) instead signals PACKED-LOAD-ERROR here." (with-open-file (s pathname :direction :input :element-type '(unsigned-byte 8)) (let ((magic (make-array (length *magic*) :element-type '(unsigned-byte 8)))) (unless (and (= (read-sequence magic s) (length *magic*)) @@ -181,31 +278,39 @@ worth more than conversion code that could not be exercised here." (n-tree (read-u32 s)) (n-internal (read-u32 s)) (n-leaf (read-u32 s)) - (n-class (read-u32 s)) - (topology - (%make-packed-topology - :n-tree n-tree :n-internal n-internal :n-leaf n-leaf - :feature (read-array s n-internal 32 '(unsigned-byte 32) #'identity) - :threshold (read-array s n-internal 32 'single-float #'bits-to-single-float) - :left (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32) - :right (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32) - :roots (read-array s n-tree 32 '(signed-byte 32) #'s32-of-u32) - :tree-leaf-offsets (read-array s n-tree 32 '(unsigned-byte 32) - #'identity)))) - (if csr - (let* ((offsets (read-array s (1+ n-leaf) 32 '(unsigned-byte 32) #'identity)) - (nnz (aref offsets n-leaf))) - (%make-packed-classifier - :topology topology :n-class n-class :kind :csr - :offsets offsets - :class (read-array s nnz 16 '(unsigned-byte 16) #'identity) - :probability (read-array s nnz 32 'single-float #'bits-to-single-float))) - (let ((flat (read-array s (* (max n-leaf 1) n-class) 32 'single-float - #'bits-to-single-float)) - (table (make-array (list (max n-leaf 1) n-class) - :element-type 'single-float))) - (dotimes (row (max n-leaf 1)) - (dotimes (k n-class) - (setf (aref table row k) (aref flat (+ (* row n-class) k))))) - (%make-packed-classifier - :topology topology :n-class n-class :kind :dense :table table)))))) + (n-class (read-u32 s))) + (check-header-count "n-tree" n-tree :positive t) + (check-header-count "n-internal" n-internal) + (check-header-count "n-leaf" n-leaf) + (check-header-count "n-class" n-class :positive t) + (let* ((feature (read-array s n-internal 32 '(unsigned-byte 32) #'identity)) + (threshold (read-array s n-internal 32 'single-float #'bits-to-single-float)) + (left (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32)) + (right (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32)) + (roots (read-array s n-tree 32 '(signed-byte 32) #'s32-of-u32)) + (tree-leaf-offsets (read-array s n-tree 32 '(unsigned-byte 32) #'identity))) + (validate-topology-arrays n-internal n-leaf n-tree left right roots + tree-leaf-offsets) + (let ((topology + (%make-packed-topology + :n-tree n-tree :n-internal n-internal :n-leaf n-leaf + :feature feature :threshold threshold :left left :right right + :roots roots :tree-leaf-offsets tree-leaf-offsets))) + (if csr + (let* ((offsets (read-array s (1+ n-leaf) 32 '(unsigned-byte 32) #'identity)) + (nnz (aref offsets n-leaf)) + (class (read-array s nnz 16 '(unsigned-byte 16) #'identity)) + (probability (read-array s nnz 32 'single-float #'bits-to-single-float))) + (validate-csr-arrays n-leaf n-class offsets class probability) + (%make-packed-classifier + :topology topology :n-class n-class :kind :csr + :offsets offsets :class class :probability probability)) + (let ((flat (read-array s (* (max n-leaf 1) n-class) 32 'single-float + #'bits-to-single-float)) + (table (make-array (list (max n-leaf 1) n-class) + :element-type 'single-float))) + (dotimes (row (max n-leaf 1)) + (dotimes (k n-class) + (setf (aref table row k) (aref flat (+ (* row n-class) k))))) + (%make-packed-classifier + :topology topology :n-class n-class :kind :dense :table table)))))))) diff --git a/t/packed.lisp b/t/packed.lisp index 9dfddcc..a1b12b7 100644 --- a/t/packed.lisp +++ b/t/packed.lisp @@ -249,15 +249,62 @@ "a byte-order mismatch is rejected")) (uiop:with-temporary-file (:pathname path :type "packed") (packed-save (build-packed-classifier forest) path) - ;; Truncate. - (let ((bytes (with-open-file (s path :element-type '(unsigned-byte 8)) - (file-length s)))) + ;; Truncate to half length, keeping the surviving bytes intact. Overwriting with + ;; zeros instead (as an earlier version of this test did) zeros the magic along + ;; with everything else, so PACKED-LOAD would reject the file on the magic check + ;; the first case above already covers, and the short-read paths this case exists + ;; to exercise would never run. + (let* ((bytes (with-open-file (s path :element-type '(unsigned-byte 8)) + (file-length s))) + (buffer (make-array bytes :element-type '(unsigned-byte 8)))) + (with-open-file (s path :element-type '(unsigned-byte 8)) + (read-sequence buffer s)) (with-open-file (s path :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) - (dotimes (i (floor bytes 2)) (write-byte 0 s)))) + (write-sequence (subseq buffer 0 (floor bytes 2)) s))) (ok (handler-case (progn (packed-load path) nil) (packed-load-error () t)) - "a truncated file is rejected"))))) + "a truncated file is rejected")) + (uiop:with-temporary-file (:pathname path :type "packed") + ;; Corrupt N-CLASS, the last of the header's seven u32 fields, at byte offset + ;; 8 + 4*6 = 32. Decrementing it below the real class count is exactly what the + ;; reviewer demonstrated slipping through unchecked: the header positivity check + ;; still passes, and the topology is untouched, but a CSR file's CLASS array now + ;; holds ids that no longer fit under the corrupted count, which + ;; VALIDATE-CSR-ARRAYS must catch. Forcing :CSR here (rather than the :AUTO the + ;; other cases use) is what puts a CLASS array in the file for the corruption to + ;; land in -- the fixture's 4-class forest packs dense under :AUTO. + (packed-save (build-packed-classifier forest :payload :csr) path) + (with-open-file (s path :direction :io :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (file-position s 32) + (write-byte 2 s)) + (ok (handler-case (progn (packed-load path) nil) + (packed-load-error () t)) + "a corrupted n-class is rejected")) + (uiop:with-temporary-file (:pathname path :type "packed") + (packed-save (build-packed-classifier forest) path) + ;; Corrupt one entry of LEFT. The topology arrays begin right after the header, at + ;; byte offset 8 + 4*7 = 36, and FEATURE comes first, so LEFT starts at + ;; 36 + 4*n-internal*2. N-INTERNAL is read back from the header (offset 24) rather + ;; than hardcoded, since the exact node count is an artifact of training the + ;; fixture forest, not something this test pins. + (let* ((n-internal (with-open-file (s path :element-type '(unsigned-byte 8)) + (file-position s 24) + (+ (read-byte s) + (ash (read-byte s) 8) + (ash (read-byte s) 16) + (ash (read-byte s) 24)))) + (left-start (+ 36 (* 4 n-internal 2)))) + (with-open-file (s path :direction :io :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (file-position s left-start) + ;; A positive value far larger than any real internal-node count, written + ;; little-endian. + (write-byte #xff s) (write-byte #xff s) (write-byte #xff s) (write-byte #x7f s))) + (ok (handler-case (progn (packed-load path) nil) + (packed-load-error () t)) + "a corrupted left entry is rejected"))))) (deftest packed-float-bits-round-trip ;; The fast paths exist per implementation; the portable fallback is the reference. They From 3131c3adf47fdfd84354233d26a0e2d6b755db0d Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Thu, 6 Aug 2026 20:40:02 +0000 Subject: [PATCH 10/13] Fix packed inference documentation to match actual behaviour src/packed/classifier.lisp: document the two predict paths' differing accumulator state. packed-predict normalises ACC in place -- on return it holds the class distribution, which packed-verify relies on to read straight out of it -- while packed-predict-batch leaves ACCS holding raw per-tree sums, dividing by n-tree only in a local while picking each row's argmax, and never writing that quotient back. Also state packed-predict-batch's shape contract: ACCS needs at least (- end start) rows and OUT at least (- end start) elements, since nothing cross-checks make-packed-accumulators' independent tile argument against the (start, end) actually predicted, and at (safety 0) either being too small is a silent out-of-bounds write. CLAUDE.md: build-packed-topology rejects a forest that has been *pruned*, not one merely built with :remove-sample-indices? t as previously stated -- pruning!'s delete-children! turns an already-split node, whose sample indices were nil'd when it was split, back into a leaf without restoring them (issue #14). A default-built, unpruned forest packs fine regardless of what :remove-sample-indices? was given at construction, which t/packed.lisp already asserts directly; the old wording just had the wrong trigger. Also drop the citation of docs/superpowers/specs/2026-08-06-packed-forest-design.md, which .gitignore excludes from every clone. README.org: the packed-inference example built on *forest*, which by that point in the file has been pruned with its default :remove-sample-indices? t construction -- exactly the combination build-packed-classifier refuses. Add a sentence so a reader following the file top to bottom knows to rebuild with :remove-sample-indices? nil before packing a forest they intend to prune, instead of hitting an unexplained packed-build-error. Co-Authored-By: Claude Opus 5 (1M context) --- CLAUDE.md | 10 ++++++---- README.org | 7 +++++++ src/packed/classifier.lisp | 18 ++++++++++++++++-- 3 files changed, 29 insertions(+), 6 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index a823c8d..4995bfe 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -202,11 +202,13 @@ training, pruning, feature importance and reconstruction all keep using the `nod Two things to know. A packed model is a snapshot: prune the forest and the packed copy goes on predicting with the old structure, silently. And `build-packed-topology` refuses a forest -built with `:remove-sample-indices? t` whose leaves have lost their indices, because their -class distributions would come out uniform rather than signalling (issue #14). +that has been *pruned*: `pruning!`'s `delete-children!` turns an already-split node -- whose +sample indices were nil'd when it was split -- back into a leaf without restoring them, so +that leaf's class distribution would come out uniform rather than signalling (issue #14). A +default-built, unpruned forest packs fine regardless of what `:remove-sample-indices?` was +given at construction time; `t/packed.lisp` asserts this directly. -The design and the measurements behind it are in `docs/packed-forest-layout.md` and -`docs/superpowers/specs/2026-08-06-packed-forest-design.md`. +The design and the measurements behind it are in `docs/packed-forest-layout.md`. ## Known broken code diff --git a/README.org b/README.org index f294751..dcf5ecf 100644 --- a/README.org +++ b/README.org @@ -187,6 +187,13 @@ The following figure shows the accuracy for test dataset and the number of leaf For serving a trained model, =cl-random-forest/src/packed= flattens a forest into arrays: 5-8x faster than =predict-forest=, safe to call from several threads, and serialisable. +A forest you intend to prune /and/ pack must be built with =:remove-sample-indices? nil=: +pruning turns internal nodes back into leaves without restoring their sample indices (issue +#14), and the packed builder refuses those. =*forest*= above was built with the default +=:remove-sample-indices? t= and was then pruned in the Global Pruning section, so packing it +as shown below will signal a =packed-build-error= unless it is rebuilt with +=:remove-sample-indices? nil= first. + #+BEGIN_SRC lisp (ql:quickload :cl-random-forest/src/packed) diff --git a/src/packed/classifier.lisp b/src/packed/classifier.lisp index 5fcf0ea..ddda505 100644 --- a/src/packed/classifier.lisp +++ b/src/packed/classifier.lisp @@ -129,7 +129,11 @@ CSR's offset loads and scattered writes cost more than the bytes saved." :element-type 'single-float :initial-element 0.0)) (defun packed-predict (classifier datamatrix datum-index acc) - "PREDICT-FOREST's answer for one datum. Writes only ACC." + "PREDICT-FOREST's answer for one datum. Writes only ACC. + +ACC is normalised in place: on return it holds the class distribution (summed votes divided +by N-TREE), not the raw sums. PACKED-VERIFY relies on this to read the distribution straight +out of ACC. Contrast PACKED-PREDICT-BATCH, which leaves its accumulators unnormalised." (declare (optimize (speed 3) (safety 0)) (type packed-classifier classifier) (type (simple-array single-float (* *)) datamatrix) @@ -176,7 +180,17 @@ CSR's offset loads and scattered writes cost more than the bytes saved." Walking one tree over the whole tile before moving to the next touches each tree's arrays once per tile instead of once per datum. The cost is holding (END - START) x n-class -accumulators, which is why a tile of one loses and a tile of a few hundred wins." +accumulators, which is why a tile of one loses and a tile of a few hundred wins. + +ACCS must have at least (END - START) rows -- as MAKE-PACKED-ACCUMULATORS gives it when +called with a TILE no smaller than (END - START) -- and OUT must have length at least +(END - START); this runs at (safety 0), so either being too small is a silent out-of-bounds +write, not a signalled error. + +Unlike PACKED-PREDICT, ACCS is left holding raw per-tree sums, not divided by N-TREE: the +division by N-TREE happens only in a local while picking each row's argmax for OUT, and +that quotient is never written back. A caller that wants ACCS's own rows to be class +distributions must divide each one by N-TREE itself." (declare (optimize (speed 3) (safety 0)) (type packed-classifier classifier) (type (simple-array single-float (* *)) datamatrix accs) From 934f55644a9bf28e9f88e762f1768d8416a7a850 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Fri, 7 Aug 2026 02:59:47 +0000 Subject: [PATCH 11/13] Close three ways a packed model could escape its bounds checks Codex's review of #24 found three gaps in what packed-load validates, all confirmed against the code. Everything downstream runs at (safety 0), so a value that gets past the loader is not caught anywhere else. A cycle in left/right passed validation. Bounds alone do not make the walk terminate: packed-leaf loops while the node index is non-negative, so left[i] = i is in range and hangs prediction with no recovery. The fix is one comparison, because build-packed-topology already numbers a subtree after its root -- emit takes its slot before recursing. Requiring each step to move forward through a bounded array makes termination structural rather than circumstantial, and check-forward-numbering now asserts the invariant at build time so a later change to the numbering fails there with a clear message instead of turning into files the loader mysteriously rejects. feature was never checked at all. check-packable bounds it by the forest's datum-dim when building, but the topology did not keep that width, so it could not be rechecked and packed-leaf used the value as a datamatrix column subscript at (safety 0) -- a read at an arbitrary offset. datum-dim is now a topology slot and a header field. Since it is untrusted in a file, it is half a pair: the loader bounds feature by the claimed width, and check-datamatrix-width bounds the claimed width by the matrix actually passed to the walk, giving feature < datum-dim <= the real column count. That second check also catches the ordinary form of the same mistake, with no file involved: predicting with a narrower dataset than the forest was trained on, until now a silent read past the end of a row. It costs nothing measurable -- 39-41k predictions/s on a 500-tree depth-10 forest with and without it, a spread smaller than the run-to-run noise. read-array sized both its buffers from a header count before it could discover the file was shorter, so a 36-byte file declaring 4294967295 internal nodes asked for 16 GB and died of heap exhaustion rather than signalling. Each array's declared length is now compared with the bytes actually remaining first. Header version 2: datum-dim is appended as an eighth u32 field. Nothing has been released reading version 1. Verified each rejection fires for its own reason rather than incidentally, by corrupting a saved model one field at a time and reading the messages back: the cycle trips the forward-motion rule, the feature index trips the width bound, and the inflated count is refused for wanting 17179869180 bytes with 57296 left in the file. The untouched file still loads and still agrees with the in-memory classifier on all 1500 predictions. --- CLAUDE.md | 20 +++++++ src/packed/classifier.lisp | 2 + src/packed/io.lisp | 113 +++++++++++++++++++++++++++++-------- src/packed/topology.lisp | 51 ++++++++++++++++- t/packed.lisp | 86 ++++++++++++++++++++-------- 5 files changed, 225 insertions(+), 47 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index 4995bfe..d88e944 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -208,6 +208,26 @@ that leaf's class distribution would come out uniform rather than signalling (is default-built, unpruned forest packs fine regardless of what `:remove-sample-indices?` was given at construction time; `t/packed.lisp` asserts this directly. +The whole walk runs at `(safety 0)`, so **every index it will follow is checked before it +starts** -- in `check-packable` when building, and again in `packed-load` for a file the +process did not write. Three of those checks are not obvious: + +- `left`/`right` must not merely be in range but must *exceed their own node index*. + `build-packed-topology` numbers a subtree after its root, so this holds by construction; + it is what makes the walk provably terminate, and without it `left[i] = i` is an in-range + cycle that hangs prediction with no way to recover. +- `feature` is bounded by `datum-dim`, the training width, which is a slot on the topology + and a field in the file for exactly this reason. `datum-dim` is itself untrusted in a + file, so it is paired with `check-datamatrix-width`, which bounds it by the matrix + actually passed in. Composed, `feature < datum-dim <= the real column count`. +- Each array's declared length is checked against the bytes left in the file *before* it is + allocated, so an inflated count is an error rather than a multi-gigabyte allocation. + +`check-datamatrix-width` also catches the ordinary version of that mistake -- predicting +with a narrower dataset than the forest was trained on -- which is otherwise a silent read +past the end of a row. It costs nothing measurable: 39-41k predictions/s on a 500-tree +depth-10 forest either way, a spread smaller than the run-to-run noise. + The design and the measurements behind it are in `docs/packed-forest-layout.md`. ## Known broken code diff --git a/src/packed/classifier.lisp b/src/packed/classifier.lisp index ddda505..6068de3 100644 --- a/src/packed/classifier.lisp +++ b/src/packed/classifier.lisp @@ -145,6 +145,7 @@ out of ACC. Contrast PACKED-PREDICT-BATCH, which leaves its accumulators unnorma (n-tree (packed-topology-n-tree topology))) (declare (type (simple-array (signed-byte 32) (*)) roots) (type fixnum n-class n-tree)) + (check-datamatrix-width topology datamatrix) (dotimes (k n-class) (setf (aref acc k) 0.0)) (ecase (packed-classifier-kind classifier) (:dense @@ -203,6 +204,7 @@ distributions must divide each one by N-TREE itself." (tile (- end start))) (declare (type (simple-array (signed-byte 32) (*)) roots) (type fixnum n-class n-tree tile)) + (check-datamatrix-width topology datamatrix) (dotimes (r tile) (dotimes (k n-class) (setf (aref accs r k) 0.0))) (ecase (packed-classifier-kind classifier) diff --git a/src/packed/io.lisp b/src/packed/io.lisp index 263dd56..4eafeb6 100644 --- a/src/packed/io.lisp +++ b/src/packed/io.lisp @@ -22,7 +22,7 @@ ;; the old, so the magic is a DEFPARAMETER. The other two are numbers and are fine. (defparameter *magic* #.(map '(simple-array (unsigned-byte 8) (*)) #'char-code "CLRFPACK")) -(defconstant +version+ 1) +(defconstant +version+ 2) (defconstant +byte-order-probe+ #x01020304) ;;;; Floats as bits @@ -99,6 +99,20 @@ (setf (aref buffer (+ (* i bytes-per) b)) (ldb (byte 8 (* 8 b)) word))))) (write-sequence buffer stream))) +(defun check-array-fits (stream name n bits) + "Signal PACKED-LOAD-ERROR unless N words of BITS bits still remain in STREAM. + +READ-ARRAY has to size two buffers from N before it can discover that the file is shorter +than N claims, and N is a header field a corrupt file controls outright: a 36-byte file +declaring 4294967295 internal nodes would ask for 16 GB before reaching the short-read check. +Comparing against the bytes actually left costs one FILE-LENGTH and forecloses that." + (let* ((wanted (* n (floor bits 8))) + (remaining (- (file-length stream) (file-position stream)))) + (when (> wanted remaining) + (error 'packed-load-error + :detail (format nil "~A claims ~D entries, needing ~D bytes, but only ~D ~ +remain in the file" name n wanted remaining))))) + (defun read-array (stream n bits element-type decoder) "Read N little-endian words of BITS bits, DECODER mapping integer to element." (let* ((bytes-per (floor bits 8)) @@ -138,27 +152,59 @@ the check is stated explicitly rather than left as an accident of the encoding." (error 'packed-load-error :detail (format nil "header ~A must be positive, got ~D" name value)))) -(defun check-child-reference (array-name index value n-internal n-leaf) +(defun check-child-reference (array-name index value n-internal n-leaf &key parent) "Signal PACKED-LOAD-ERROR unless VALUE is a valid child reference at ARRAY-NAME[INDEX]: either an internal-node index in [0, N-INTERNAL), or the BUILD-PACKED-TOPOLOGY encoding of a -leaf, `~L` for some leaf L in [0, N-LEAF)." +leaf, `~L` for some leaf L in [0, N-LEAF). + +When PARENT is the index of the node VALUE is a child of, an internal VALUE must also exceed +it. Bounds alone do not make the walk terminate: PACKED-LEAF loops while the node index is +non-negative, so `left[i] = i` -- in range, and a cycle -- hangs it at (safety 0). Requiring +each step to move forward through a bounded array makes termination provable instead, which +is exactly the numbering BUILD-PACKED-TOPOLOGY produces and now checks." (if (minusp value) (let ((leaf (lognot value))) (unless (< -1 leaf n-leaf) (error 'packed-load-error :detail (format nil "~A[~D] = ~D references leaf ~D, outside [0,~D)" array-name index value leaf n-leaf)))) - (unless (< value n-internal) - (error 'packed-load-error - :detail (format nil "~A[~D] = ~D, outside the internal-node range [0,~D)" - array-name index value n-internal))))) + (progn + (unless (< value n-internal) + (error 'packed-load-error + :detail (format nil "~A[~D] = ~D, outside the internal-node range [0,~D)" + array-name index value n-internal))) + (when (and parent (<= value parent)) + (error 'packed-load-error + :detail (format nil "~A[~D] = ~D does not exceed its parent index ~D, so ~ +the walk could revisit a node and never terminate" array-name index value parent)))))) + +(defun validate-feature-array (n-internal datum-dim feature) + "Signal PACKED-LOAD-ERROR unless every FEATURE entry is a column of a DATUM-DIM datamatrix. + +PACKED-LEAF uses FEATURE[node] as the second subscript of the datamatrix with bounds checking +off, so an unchecked entry from a corrupt file is a read at an arbitrary offset from the +array. CHECK-PACKABLE applies the same bound when building; the file carries DATUM-DIM so +that the bound survives the round trip. + +DATUM-DIM is itself a number from the file, so this check alone would be vacuous against a +corruption that inflated both. It is half of a pair: this bounds FEATURE by the claimed +width, and CHECK-DATAMATRIX-WIDTH bounds the claimed width by the matrix actually handed to +the walk. Composed, feature < datum-dim <= the real column count, and an inflated DATUM-DIM +fails closed at the first prediction rather than reading out of bounds." + (dotimes (i n-internal) + (unless (< (aref feature i) datum-dim) + (error 'packed-load-error + :detail (format nil "feature[~D] = ~D, outside the datamatrix's [0,~D) columns" + i (aref feature i) datum-dim))))) (defun validate-topology-arrays (n-internal n-leaf n-tree left right roots tree-leaf-offsets) "Signal PACKED-LOAD-ERROR if LEFT, RIGHT, ROOTS or TREE-LEAF-OFFSETS are not internally consistent with the header counts N-INTERNAL, N-LEAF and N-TREE." (dotimes (i n-internal) - (check-child-reference "left" i (aref left i) n-internal n-leaf) - (check-child-reference "right" i (aref right i) n-internal n-leaf)) + (check-child-reference "left" i (aref left i) n-internal n-leaf :parent i) + (check-child-reference "right" i (aref right i) n-internal n-leaf :parent i)) + ;; A root has no parent to exceed; it only has to be in range. Termination still follows, + ;; since every step after it moves strictly forward. (dotimes (tree n-tree) (check-child-reference "roots" tree (aref roots tree) n-internal n-leaf)) (unless (zerop (aref tree-leaf-offsets 0)) @@ -232,6 +278,7 @@ or shifted past the point the first magic check looks at." (write-u32 (packed-topology-n-internal topology) s) (write-u32 n-leaf s) (write-u32 n-class s) + (write-u32 (packed-topology-datum-dim topology) s) (write-array (packed-topology-feature topology) s 32 #'identity) (write-array (packed-topology-threshold topology) s 32 #'single-float-to-bits) (write-array (packed-topology-left topology) s 32 #'u32-of-s32) @@ -256,10 +303,13 @@ or shifted past the point the first magic check looks at." (defun packed-load (pathname) "Read a packed classifier written by PACKED-SAVE. -Every array is checked against the header counts before this returns: LEFT, RIGHT, ROOTS, +Every array is checked against the header counts before this returns: FEATURE against the +saved datamatrix width, LEFT, RIGHT and ROOTS for range and for forward motion, plus TREE-LEAF-OFFSETS and, for a CSR file, OFFSETS and CLASS. A corrupt file the topology traversal or the CSR prediction loop would otherwise read or write out of bounds at -(safety 0) instead signals PACKED-LOAD-ERROR here." +(safety 0) -- or walk in a cycle forever -- instead signals PACKED-LOAD-ERROR here. Each +array's declared length is also checked against the bytes actually remaining before it is +allocated, so an inflated count cannot turn into a huge allocation." (with-open-file (s pathname :direction :input :element-type '(unsigned-byte 8)) (let ((magic (make-array (length *magic*) :element-type '(unsigned-byte 8)))) (unless (and (= (read-sequence magic s) (length *magic*)) @@ -278,35 +328,54 @@ traversal or the CSR prediction loop would otherwise read or write out of bounds (n-tree (read-u32 s)) (n-internal (read-u32 s)) (n-leaf (read-u32 s)) - (n-class (read-u32 s))) + (n-class (read-u32 s)) + (datum-dim (read-u32 s))) (check-header-count "n-tree" n-tree :positive t) (check-header-count "n-internal" n-internal) (check-header-count "n-leaf" n-leaf) (check-header-count "n-class" n-class :positive t) + (check-header-count "datum-dim" datum-dim :positive t) + (check-array-fits s "feature" n-internal 32) (let* ((feature (read-array s n-internal 32 '(unsigned-byte 32) #'identity)) - (threshold (read-array s n-internal 32 'single-float #'bits-to-single-float)) - (left (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32)) - (right (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32)) - (roots (read-array s n-tree 32 '(signed-byte 32) #'s32-of-u32)) - (tree-leaf-offsets (read-array s n-tree 32 '(unsigned-byte 32) #'identity))) + (threshold (progn (check-array-fits s "threshold" n-internal 32) + (read-array s n-internal 32 'single-float + #'bits-to-single-float))) + (left (progn (check-array-fits s "left" n-internal 32) + (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32))) + (right (progn (check-array-fits s "right" n-internal 32) + (read-array s n-internal 32 '(signed-byte 32) #'s32-of-u32))) + (roots (progn (check-array-fits s "roots" n-tree 32) + (read-array s n-tree 32 '(signed-byte 32) #'s32-of-u32))) + (tree-leaf-offsets (progn (check-array-fits s "tree-leaf-offsets" n-tree 32) + (read-array s n-tree 32 '(unsigned-byte 32) + #'identity)))) (validate-topology-arrays n-internal n-leaf n-tree left right roots tree-leaf-offsets) + (validate-feature-array n-internal datum-dim feature) (let ((topology (%make-packed-topology :n-tree n-tree :n-internal n-internal :n-leaf n-leaf + :datum-dim datum-dim :feature feature :threshold threshold :left left :right right :roots roots :tree-leaf-offsets tree-leaf-offsets))) (if csr - (let* ((offsets (read-array s (1+ n-leaf) 32 '(unsigned-byte 32) #'identity)) + (let* ((offsets (progn (check-array-fits s "csr offsets" (1+ n-leaf) 32) + (read-array s (1+ n-leaf) 32 '(unsigned-byte 32) + #'identity))) (nnz (aref offsets n-leaf)) - (class (read-array s nnz 16 '(unsigned-byte 16) #'identity)) - (probability (read-array s nnz 32 'single-float #'bits-to-single-float))) + (class (progn (check-array-fits s "csr class" nnz 16) + (read-array s nnz 16 '(unsigned-byte 16) #'identity))) + (probability (progn (check-array-fits s "csr probability" nnz 32) + (read-array s nnz 32 'single-float + #'bits-to-single-float)))) (validate-csr-arrays n-leaf n-class offsets class probability) (%make-packed-classifier :topology topology :n-class n-class :kind :csr :offsets offsets :class class :probability probability)) - (let ((flat (read-array s (* (max n-leaf 1) n-class) 32 'single-float - #'bits-to-single-float)) + (let ((flat (progn + (check-array-fits s "dense table" (* (max n-leaf 1) n-class) 32) + (read-array s (* (max n-leaf 1) n-class) 32 'single-float + #'bits-to-single-float))) (table (make-array (list (max n-leaf 1) n-class) :element-type 'single-float))) (dotimes (row (max n-leaf 1)) diff --git a/src/packed/topology.lisp b/src/packed/topology.lisp index f1d3b56..acdc106 100644 --- a/src/packed/topology.lisp +++ b/src/packed/topology.lisp @@ -15,6 +15,7 @@ #:packed-topology-n-tree #:packed-topology-n-internal #:packed-topology-n-leaf + #:packed-topology-datum-dim #:packed-topology-feature #:packed-topology-threshold #:packed-topology-left @@ -25,6 +26,7 @@ #:build-packed-topology #:packed-leaf #:packed-leaf-indices + #:check-datamatrix-width #:packed-build-error #:packed-build-error-detail)) @@ -48,10 +50,21 @@ that would be frozen into the model silently.")) A leaf is encoded as a negative child index, `~leaf`, so a walk's continuation test is its leaf test and a leaf costs no extra read. Leaf numbers are TREE-LEAF-OFFSETS[tree] + the tree's own leaf index, which is by construction the index -Global Refinement uses." +Global Refinement uses. + +LEFT and RIGHT hold, for every internal node, a child index strictly greater than the node's +own index: EMIT takes its slot before recursing, so a subtree is always numbered after its +root. Nothing in the walk depends on that, but it makes termination structural rather than +circumstantial -- each step moves strictly forward through a bounded array -- and PACKED-LOAD +rechecks it on a file it did not write, where a cycle would otherwise hang the walk. + +DATUM-DIM is the width of the datamatrix the forest was trained on. FEATURE indexes a +datamatrix column at (safety 0), so it is bounded by DATUM-DIM at build time, and keeping the +bound is what lets PACKED-LOAD and the prediction entry points check it again later." (n-tree 0 :type fixnum) (n-internal 0 :type fixnum) (n-leaf 0 :type fixnum) + (datum-dim 0 :type fixnum) (feature (make-array 0 :element-type '(unsigned-byte 32)) :type (simple-array (unsigned-byte 32) (*))) (threshold (make-array 0 :element-type 'single-float) @@ -123,6 +136,21 @@ with :remove-sample-indices? nil (issue #14)" depth indices)))))))) (walk (dtree-root dtree))) (values internal leaves))) +(defun check-forward-numbering (n-internal left right) + "Signal PACKED-BUILD-ERROR unless every internal child index exceeds its parent's. + +EMIT produces this by construction. Checking it here costs one pass and turns a later change +to the numbering -- breadth-first, or anything cache-conscious -- into an error at build time +with this message, rather than into files PACKED-LOAD starts rejecting for no visible reason." + (dotimes (i n-internal) + (dolist (side (list (cons "left" (aref left i)) (cons "right" (aref right i)))) + (let ((child (cdr side))) + (when (and (not (minusp child)) (<= child i)) + (error 'packed-build-error + :detail (format nil "~A[~D] = ~D does not exceed its parent index; the ~ +node numbering is no longer depth-first, and PACKED-LOAD's termination check assumes it is" + (car side) i child))))))) + (defun build-packed-topology (forest) "Flatten FOREST's structure into arrays. @@ -171,11 +199,31 @@ because the traversal runs at (safety 0)." (incf local-leaf)))))) (setf (aref roots tree) (emit (dtree-root dtree)))) (incf leaf-base local-leaf))) + (check-forward-numbering n-internal left right) (%make-packed-topology :n-tree n-tree :n-internal n-internal :n-leaf n-leaf + :datum-dim (forest-datum-dim forest) :feature feature :threshold threshold :left left :right right :roots roots :tree-leaf-offsets offsets)))) +(declaim (inline check-datamatrix-width)) +(defun check-datamatrix-width (topology datamatrix) + "Signal an error unless DATAMATRIX is at least as wide as the forest was trained on. + +PACKED-LEAF reads DATAMATRIX[datum, FEATURE[node]] at (safety 0), and FEATURE is bounded only +by the training width. Hand the walk a narrower matrix -- the easy mistake, predicting with a +different dataset than you trained on -- and it reads past the row rather than complaining. +This is one comparison against several hundred tree walks per call." + (declare (optimize (speed 3) (safety 0)) + (type packed-topology topology) + (type (simple-array single-float (* *)) datamatrix)) + (let ((dim (packed-topology-datum-dim topology)) + (width (array-dimension datamatrix 1))) + (declare (type fixnum dim width)) + (when (< width dim) + (error "this model was packed from a forest trained on ~D columns, but the datamatrix ~ +has ~D" dim width)))) + (declaim (inline packed-leaf)) (defun packed-leaf (topology datamatrix datum-index root) "The leaf number a datum reaches from ROOT. This is the Global Refinement index." @@ -211,6 +259,7 @@ because the traversal runs at (safety 0)." (n-tree (packed-topology-n-tree topology))) (declare (type (simple-array (signed-byte 32) (*)) roots) (type fixnum n-tree)) + (check-datamatrix-width topology datamatrix) (dotimes (tree n-tree out) (setf (aref out tree) (packed-leaf topology datamatrix datum-index (aref roots tree)))))) diff --git a/t/packed.lisp b/t/packed.lisp index a1b12b7..2526d25 100644 --- a/t/packed.lisp +++ b/t/packed.lisp @@ -266,7 +266,7 @@ (packed-load-error () t)) "a truncated file is rejected")) (uiop:with-temporary-file (:pathname path :type "packed") - ;; Corrupt N-CLASS, the last of the header's seven u32 fields, at byte offset + ;; Corrupt N-CLASS, the seventh of the header's eight u32 fields, at byte offset ;; 8 + 4*6 = 32. Decrementing it below the real class count is exactly what the ;; reviewer demonstrated slipping through unchecked: the header positivity check ;; still passes, and the topology is untouched, but a CSR file's CLASS array now @@ -282,29 +282,67 @@ (ok (handler-case (progn (packed-load path) nil) (packed-load-error () t)) "a corrupted n-class is rejected")) - (uiop:with-temporary-file (:pathname path :type "packed") - (packed-save (build-packed-classifier forest) path) - ;; Corrupt one entry of LEFT. The topology arrays begin right after the header, at - ;; byte offset 8 + 4*7 = 36, and FEATURE comes first, so LEFT starts at - ;; 36 + 4*n-internal*2. N-INTERNAL is read back from the header (offset 24) rather - ;; than hardcoded, since the exact node count is an artifact of training the - ;; fixture forest, not something this test pins. - (let* ((n-internal (with-open-file (s path :element-type '(unsigned-byte 8)) - (file-position s 24) - (+ (read-byte s) - (ash (read-byte s) 8) - (ash (read-byte s) 16) - (ash (read-byte s) 24)))) - (left-start (+ 36 (* 4 n-internal 2)))) - (with-open-file (s path :direction :io :if-exists :overwrite - :element-type '(unsigned-byte 8)) - (file-position s left-start) - ;; A positive value far larger than any real internal-node count, written - ;; little-endian. - (write-byte #xff s) (write-byte #xff s) (write-byte #xff s) (write-byte #x7f s))) - (ok (handler-case (progn (packed-load path) nil) - (packed-load-error () t)) - "a corrupted left entry is rejected"))))) + (flet ((clobber (payload offset bytes) + "Save FOREST, overwrite BYTES at OFFSET, and return T if the load is refused." + (uiop:with-temporary-file (:pathname path :type "packed") + (packed-save (build-packed-classifier forest :payload payload) path) + (with-open-file (s path :direction :io :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (file-position s offset) + (dolist (b bytes) (write-byte b s))) + (handler-case (progn (packed-load path) nil) + (packed-load-error () t)))) + (u32-at (offset) + "Read the u32 the saved header holds at OFFSET, to avoid hardcoding counts." + (uiop:with-temporary-file (:pathname path :type "packed") + (packed-save (build-packed-classifier forest) path) + (with-open-file (s path :element-type '(unsigned-byte 8)) + (file-position s offset) + (+ (read-byte s) (ash (read-byte s) 8) + (ash (read-byte s) 16) (ash (read-byte s) 24)))))) + ;; The topology arrays begin right after the header's eight u32 fields, at byte + ;; offset 8 + 4*8 = 40. FEATURE comes first and THRESHOLD second, so LEFT starts at + ;; 40 + 4*n-internal*2. N-INTERNAL is read back from the header (offset 24) rather + ;; than hardcoded, since the exact node count is an artifact of training the fixture + ;; forest, not something this test pins. + (let* ((n-internal (u32-at 24)) + (feature-start 40) + (left-start (+ 40 (* 4 n-internal 2)))) + (ok (clobber :auto left-start '(#xff #xff #xff #x7f)) + "a corrupted left entry is rejected") + ;; A node whose left child is itself. Every bound holds -- 0 is a perfectly good + ;; internal-node index -- so only the forward-motion rule catches it. Without that + ;; rule PACKED-LEAF spins in this node forever at (safety 0), which is why the + ;; check exists: a hang is not something a caller can recover from. + (ok (clobber :auto left-start '(0 0 0 0)) + "a left entry pointing at its own node is rejected") + ;; A feature index past the datamatrix's columns. Nothing about the tree structure + ;; is wrong here; the walk would simply read off the end of a row. + (ok (clobber :auto feature-start '(#xff #xff #xff #xff)) + "a feature index outside the trained datamatrix width is rejected") + ;; An inflated N-INTERNAL. READ-ARRAY has to size its buffers from this count + ;; before it can notice the file is too short, so without the remaining-length + ;; check this asks for 16 GB and dies of heap exhaustion rather than signalling. + ;; The assertion is specifically that it is a PACKED-LOAD-ERROR. + (ok (clobber :auto 24 '(#xff #xff #xff #xff)) + "a count larger than the file is rejected before anything is allocated")))))) + +(deftest packed-refuses-a-datamatrix-narrower-than-the-forest + ;; FEATURE is bounded by the training width, and the walk reads the datamatrix at + ;; (safety 0), so a narrower matrix is an out-of-bounds read rather than an error. This is + ;; reachable with a perfectly good in-memory model -- no file involved -- by predicting + ;; with a different dataset than the forest was trained on. + (with-serial-kernel + (let* ((forest (synthetic-forest)) + (classifier (build-packed-classifier forest)) + (dim (packed-topology-datum-dim (packed-classifier-topology classifier))) + (acc (make-packed-accumulator classifier)) + (narrow (make-array (list 1 (1- dim)) :element-type 'single-float + :initial-element 0.0))) + (ok (plusp dim) "the packed topology remembers the training width") + (ok (handler-case (progn (packed-predict classifier narrow 0 acc) nil) + (error () t)) + "predicting from a too-narrow datamatrix signals instead of reading past the row")))) (deftest packed-float-bits-round-trip ;; The fast paths exist per implementation; the portable fallback is the reference. They From ea6d8065195c5bebb5a1fbb0e8ee5e936a06bbc4 Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Fri, 7 Aug 2026 06:13:14 +0000 Subject: [PATCH 12/13] Stop the portable float encoder from reading the host's decode convention ccl-bin CI failed on four denormals -- 1.4012985e-45, its negative, 1.729903e-41 and 5.877472e-39 -- with the portable encoder disagreeing with CCL's native one. The round trip and the portable decoder both passed on the same values, which localised it: CCL's bits are the correct IEEE pattern and the portable encoder was producing something else. INTEGER-DECODE-FLOAT owes its caller only a (significand, exponent) pair whose product is the magnitude. Which member of that equivalence class it returns is up to the implementation, and for denormals the two we run on disagree: SBCL leaves the significand unnormalised, so LEAST-POSITIVE-SINGLE-FLOAT comes back as 1 x 2^-149, while CCL normalises it to 2^23 x 2^-172. The encoder decided "is this a denormal?" by testing the significand against 2^23, which reads the host's convention rather than the format. On CCL that test is false for every denormal, so it took the normal-number branch and wrote a wrapped exponent field: 5.877472e-39 encoded as 00000000, a denormal silently becoming zero. Normalising the pair first and letting the biased exponent decide is true of either convention. Reduction now runs in both directions, since the pair is pinned down only up to doubling the significand and dropping the exponent. The arithmetic moved into %FLOAT-PARTS-TO-BITS, taking the parts rather than a float, so both conventions can be fed in from any host. That is what the old test could not do: it compared the portable encoder against the native one, so on SBCL the host never produced the pair that breaks it and only CCL could see the bug. The new test supplies the pairs directly and fails on SBCL too -- verified by restoring the pre-fix branch, which fails 13 assertions here, the first four being exactly the values CI reported. Swept 53776604 bit patterns (every denormal, every exponent, and every pattern in the two smallest normal binades) through four representations of each: as decoded, normalised, reduced to an odd significand, and over-scaled. Zero disagreements. --- src/packed/io.lisp | 45 +++++++++++++++++++++++++++++++++------------ t/packed.lisp | 40 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 73 insertions(+), 12 deletions(-) diff --git a/src/packed/io.lisp b/src/packed/io.lisp index 4eafeb6..a454717 100644 --- a/src/packed/io.lisp +++ b/src/packed/io.lisp @@ -9,7 +9,8 @@ #:single-float-to-bits #:bits-to-single-float #:%portable-single-float-to-bits - #:%portable-bits-to-single-float)) + #:%portable-bits-to-single-float + #:%float-parts-to-bits)) (in-package :cl-random-forest/src/packed/io) @@ -31,23 +32,43 @@ ;;;; portable version is the reference the tests hold the fast paths to, and the fallback ;;;; anywhere else. +(defun %float-parts-to-bits (significand exponent sign) + "IEEE-754 single-precision bits of SIGNIFICAND * 2^EXPONENT, signed by SIGN. + +Separate from %PORTABLE-SINGLE-FLOAT-TO-BITS so that both of the conventions +INTEGER-DECODE-FLOAT is allowed to use can be fed in from any host and checked, rather than +only on a host that happens to use the other one." + (let ((sign-bit (if (minusp sign) #x80000000 0))) + ;; INTEGER-DECODE-FLOAT owes its caller only a pair whose product is the magnitude; + ;; whether a denormal's significand comes back normalised is up to the implementation. + ;; SBCL leaves it alone -- LEAST-POSITIVE-SINGLE-FLOAT is significand 1, exponent -149 -- + ;; and CCL normalises it to significand 2^23, exponent -172. Deciding "is this a + ;; denormal?" by the significand's magnitude therefore reads the host's convention + ;; instead of the format's, which is exactly how this went wrong before: correct on SBCL, + ;; and on CCL it fell into the normal-number branch and wrote a wrapped exponent field. + ;; Normalising first and letting the biased exponent decide is true of either convention. + ;; The pair is pinned down only up to doubling the significand and dropping the exponent, + ;; so reduce it from both directions rather than assuming which end it arrived at. + (loop while (and (>= significand (ash 1 24)) (evenp significand)) + do (setf significand (ash significand -1)) + (incf exponent)) + (loop while (< significand (ash 1 23)) + do (setf significand (ash significand 1)) + (decf exponent)) + (let ((biased (+ exponent 23 127))) + (if (plusp biased) + (logior sign-bit (ash biased 23) (logand significand #x7fffff)) + ;; Exponent field zero, and the significand shifted down to the fixed 2^-149 scale + ;; a denormal's fraction is measured in. + (logior sign-bit (ash significand (1- biased))))))) + (defun %portable-single-float-to-bits (x) "IEEE-754 single-precision bits of X, in ANSI Common Lisp only." (declare (type single-float x)) (if (zerop x) (if (minusp (float-sign x)) #x80000000 0) (multiple-value-bind (significand exponent sign) (integer-decode-float x) - (let ((sign-bit (if (minusp sign) #x80000000 0))) - (if (< significand (ash 1 23)) - ;; A denormal. INTEGER-DECODE-FLOAT leaves its significand unnormalised -- - ;; LEAST-POSITIVE-SINGLE-FLOAT comes back as significand 1, exponent -149 -- - ;; so the biased-exponent arithmetic below would write a bogus non-zero - ;; exponent field. IEEE-754 stores a denormal as exponent field zero and a - ;; fraction that is the value divided by 2^-149. - (logior sign-bit (ash significand (+ exponent 149))) - (logior sign-bit - (ash (logand (+ exponent 23 127) #xff) 23) - (logand significand #x7fffff))))))) + (%float-parts-to-bits significand exponent sign)))) (defun %portable-bits-to-single-float (bits) "The single-float whose IEEE-754 bits are BITS, in ANSI Common Lisp only." diff --git a/t/packed.lisp b/t/packed.lisp index 2526d25..1adc0dd 100644 --- a/t/packed.lisp +++ b/t/packed.lisp @@ -369,3 +369,43 @@ (ok (= v (cl-random-forest/src/packed::%portable-bits-to-single-float (cl-random-forest/src/packed::single-float-to-bits v))) (format nil "~S: the portable decoder agrees with the fast encoder" v))))) + +(deftest packed-float-bits-do-not-depend-on-the-decode-convention + ;; INTEGER-DECODE-FLOAT owes its caller only a (significand, exponent) pair whose product + ;; is the magnitude. Which member of that equivalence class it picks is up to the + ;; implementation, and for denormals the two we run on disagree: SBCL leaves the + ;; significand unnormalised (LEAST-POSITIVE-SINGLE-FLOAT is 1 x 2^-149) while CCL + ;; normalises it (2^23 x 2^-172). + ;; + ;; The portable encoder used to decide "is this a denormal?" by asking whether the + ;; significand was below 2^23 -- reading the host's convention rather than the format. + ;; That was right on SBCL and wrong on CCL, where 5.877472e-39 encoded as 00000000: a + ;; denormal silently becoming zero. Only CI caught it, because on SBCL the host never + ;; produces the pair that breaks it. + ;; + ;; So this feeds the pairs in directly. It fails on any implementation if the convention + ;; ever leaks back into the arithmetic. + (labels ((normalised (s e) + "The CCL convention: significand shifted up into [2^23, 2^24)." + (loop while (< s (ash 1 23)) do (setf s (ash s 1)) (decf e)) + (values s e)) + (minimal (s e) + "The other extreme: significand reduced until odd." + (loop while (and (plusp s) (evenp s)) do (setf s (ash s -1)) (incf e)) + (values s e))) + (dolist (v (list least-positive-single-float + (- least-positive-single-float) + (* 12345.0 least-positive-single-float) + (/ least-positive-normalized-single-float 2.0) + least-positive-normalized-single-float + 1.0 -0.5 3.14159 most-positive-single-float)) + (multiple-value-bind (s e sign) (integer-decode-float v) + (let ((expected (cl-random-forest/src/packed::single-float-to-bits v))) + (dolist (convention (list (cons "as decoded" (list s e)) + (cons "normalised" (multiple-value-list (normalised s e))) + (cons "minimal" (multiple-value-list (minimal s e))) + (cons "over-scaled" (list (ash s 5) (- e 5))))) + (ok (= expected + (cl-random-forest/src/packed::%float-parts-to-bits + (first (cdr convention)) (second (cdr convention)) sign)) + (format nil "~S: ~A significand encodes the same" v (car convention))))))))) From 095d44e84ee21610380807a54c6b783799d72fdf Mon Sep 17 00:00:00 2001 From: Satoshi Imai Date: Fri, 7 Aug 2026 06:22:34 +0000 Subject: [PATCH 13/13] Record what the CI matrix actually runs, and what it alone can catch The matrix is three jobs, not four: the workflow excludes ccl-bin on macOS because those binaries are no longer distributed. Roswell has no ccl-bin for ARM64 Linux either, so on an aarch64 machine the CCL half cannot be run locally at all -- which is how a denormal encoding bug reached CI in this branch. Says so, with the two CCL differences that have actually bitten. --- CLAUDE.md | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/CLAUDE.md b/CLAUDE.md index d88e944..d5a0b07 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -72,7 +72,13 @@ Load the feature system first (`ql:quickload` or `asdf:load-system`), then: ``` There is no lint step. CI (`.github/workflows/ci.yml`) runs the matrix -{sbcl-bin, ccl-bin} × {ubuntu-latest, macOS-latest}. +{sbcl-bin, ccl-bin} × {ubuntu-latest, macOS-latest}, less ccl-bin on macOS, which the +workflow excludes because macOS CCL binaries are no longer distributed — three jobs, not +four. Roswell has no ccl-bin for **ARM64 Linux** either, so on an aarch64 development +machine the CCL half of the matrix cannot be reproduced locally at all and CI is the only +place it runs. Treat a green local suite as evidence about SBCL only: CCL does not check +type declarations, and its `integer-decode-float` normalises a denormal's significand where +SBCL leaves it alone — both have produced CI-only failures in this repository. Test/example caveats: - `cl-random-forest-test/regression`, `.../pruning`, and the seven synthetic tests in