From 4f64a99481b05f6153e4f38fd3bf3dfad14f9029 Mon Sep 17 00:00:00 2001 From: takeokunn Date: Mon, 26 Oct 2026 16:28:03 +0900 Subject: [PATCH 1/2] feat(runtime): add VM object helpers --- cl-cc-javascript.asd | 4 +- src/runtime-vm-objects.lisp | 133 +++++++++++++++++++++++++++++++++ t/runtime-vm-objects-test.lisp | 123 ++++++++++++++++++++++++++++++ 3 files changed, 259 insertions(+), 1 deletion(-) create mode 100644 src/runtime-vm-objects.lisp create mode 100644 t/runtime-vm-objects-test.lisp diff --git a/cl-cc-javascript.asd b/cl-cc-javascript.asd index cecf030..0c06b07 100644 --- a/cl-cc-javascript.asd +++ b/cl-cc-javascript.asd @@ -77,6 +77,7 @@ (:file "runtime-array-from") (:file "runtime-object") (:file "runtime-object-ops") + (:file "runtime-vm-objects") (:file "runtime-json") (:file "runtime-string") (:file "runtime-math") @@ -183,7 +184,8 @@ (:file "runtime-builtins-iterator-proxy-test") (:file "runtime-builtins-platform-object-test") (:file "runtime-console-test") - (:file "runtime-builtins-platform-test")) + (:file "runtime-builtins-platform-test") + (:file "runtime-vm-objects-test")) ;; Not UIOP:SYMBOL-CALL, and not a sibling-package prefix either: a .asd is ;; read by the plain CL reader before :depends-on is ever consulted, so any ;; PKG:SYMBOL token here must resolve against a package already present in diff --git a/src/runtime-vm-objects.lisp b/src/runtime-vm-objects.lisp new file mode 100644 index 0000000..f001466 --- /dev/null +++ b/src/runtime-vm-objects.lisp @@ -0,0 +1,133 @@ +;;;; Runtime structures used by the VM's object and dispatch paths. +(in-package #:cl-cc/javascript) + +;;; Hidden classes / object shapes +(defstruct object-shape + "A shape shared by instances with the same class and ordered slot layout." + (name nil :type symbol) + (slot-offsets (make-hash-table :test #'equal)) + (transition-table (make-hash-table :test #'equal)) + (parent-shape nil)) + +(defvar *shape-registry* (make-hash-table :test #'equal) + "Map (CLASS-NAME SLOT-NAMES) keys to their object shapes.") + +(defun find-or-create-shape (class-name slot-names) + "Find or create a shape for CLASS-NAME and the ordered SLOT-NAMES layout." + (check-type class-name symbol) + (check-type slot-names list) + (let* ((stable-slot-names + (mapcar (lambda (slot) + (if (stringp slot) (copy-seq slot) slot)) + slot-names)) + (key (list class-name stable-slot-names))) + (or (gethash key *shape-registry*) + (let ((shape (make-object-shape :name class-name))) + (loop for slot in stable-slot-names + for offset from 0 + do (setf (gethash slot (object-shape-slot-offsets shape)) offset)) + (setf (gethash key *shape-registry*) shape) + shape)))) + +(defun shape-slot-offset (shape slot-name) + "Return SLOT-NAME's offset in SHAPE, or NIL when it is absent." + (gethash slot-name (object-shape-slot-offsets shape))) + +;;; Inline method dispatch tables +(defconstant +imt-size+ 64 + "Fixed number of selector buckets in an inline method table.") + +(defstruct imt-entry + "An inline method entry and its collision chain." + (selector nil :type symbol) + (implementation nil :type (or null function)) + (conflict-chain nil :type list)) + +(defstruct inline-method-table + "Per-class inline method table with collision chains." + (entries (make-array +imt-size+ :initial-element nil))) + +(defun imt-insert (imt selector impl) + "Insert or replace SELECTOR's implementation in IMT without losing collisions." + (let* ((hash (mod (sxhash selector) +imt-size+)) + (entry (aref (inline-method-table-entries imt) hash))) + (cond + ((null entry) + (setf (aref (inline-method-table-entries imt) hash) + (make-imt-entry :selector selector :implementation impl))) + ((eq (imt-entry-selector entry) selector) + (setf (aref (inline-method-table-entries imt) hash) + (make-imt-entry + :selector selector + :implementation impl + :conflict-chain (imt-entry-conflict-chain entry)))) + (t + (let ((conflict (find selector (imt-entry-conflict-chain entry) + :test #'eq :key #'imt-entry-selector))) + (if conflict + (progn + (setf (imt-entry-implementation conflict) impl) + (imt-entry-conflict-chain entry)) + (push (make-imt-entry :selector selector :implementation impl) + (imt-entry-conflict-chain entry)))))))) + +(defun imt-lookup (imt selector) + "Return SELECTOR's implementation from IMT, or NIL when it is absent." + (let* ((hash (mod (sxhash selector) +imt-size+)) + (entry (aref (inline-method-table-entries imt) hash))) + (cond + ((null entry) nil) + ((eq (imt-entry-selector entry) selector) + (imt-entry-implementation entry)) + (t + (let ((found (find selector (imt-entry-conflict-chain entry) + :test #'eq :key #'imt-entry-selector))) + (when found + (imt-entry-implementation found))))))) + +;;; Object mark word +(defconstant +mark-word-gc-color-bits+ 2) +(defconstant +mark-word-kind-bits+ 2) +(defconstant +mark-word-hash-bits+ 28) + +(defun make-mark-word (&key (gc-color 0) (object-kind 0) + (identity-hash 0) (lock-state 0)) + "Create a 64-bit mark word after validating each field's bit width." + (check-type gc-color (unsigned-byte 2)) + (check-type object-kind (unsigned-byte 2)) + (check-type identity-hash (unsigned-byte 28)) + (check-type lock-state (unsigned-byte 32)) + (logior gc-color + (ash object-kind +mark-word-gc-color-bits+) + (ash identity-hash (+ +mark-word-gc-color-bits+ +mark-word-kind-bits+)) + (ash lock-state (+ +mark-word-gc-color-bits+ +mark-word-kind-bits+ + +mark-word-hash-bits+)))) + +(defun mark-word-gc-color (mw) + "Extract the two GC color bits from mark word MW." + (logand mw (1- (ash 1 +mark-word-gc-color-bits+)))) + +;;; Value types / inline structs +(defstruct value-type-def + "Definition of an inline value type stored in stack or register slots." + (name nil :type symbol) + (fields nil :type list) + (total-size 0 :type fixnum)) + +(defvar *value-types* (make-hash-table :test #'eq) + "Registered value type definitions.") + +(defmacro defvalue-type (name &rest fields) + "Register NAME with FIELDS as an inline composite value type." + `(progn + (setf (gethash ',name *value-types*) + (make-value-type-def :name ',name :fields ',fields + :total-size ,(length fields))) + ',name)) + +(export '(object-shape make-object-shape *shape-registry* + find-or-create-shape shape-slot-offset + +imt-size+ imt-entry make-imt-entry + inline-method-table make-inline-method-table imt-insert imt-lookup + make-mark-word mark-word-gc-color + defvalue-type value-type-def *value-types*)) diff --git a/t/runtime-vm-objects-test.lisp b/t/runtime-vm-objects-test.lisp new file mode 100644 index 0000000..1f78752 --- /dev/null +++ b/t/runtime-vm-objects-test.lisp @@ -0,0 +1,123 @@ +;;;; Tests for VM object shapes, inline method tables, mark words, and value types. +(in-package :cl-cc-javascript/test) + +(it-sequential "vm-object-shape-cache-distinguishes-class-and-layout" + (let ((cl-cc/javascript:*shape-registry* (make-hash-table :test #'equal))) + (let* ((shape (cl-cc/javascript:find-or-create-shape 'shape-case '(first second))) + (same (cl-cc/javascript:find-or-create-shape 'shape-case '(first second))) + (reordered (cl-cc/javascript:find-or-create-shape 'shape-case '(second first))) + (other-class (cl-cc/javascript:find-or-create-shape 'other-shape-case + '(first second)))) + (expect same :to-be shape) + (expect (not (eq shape reordered)) :to-be-truthy) + (expect (not (eq shape other-class)) :to-be-truthy) + (expect (cl-cc/javascript:shape-slot-offset shape 'first) :to-equal 0) + (expect (cl-cc/javascript:shape-slot-offset shape 'second) :to-equal 1) + (expect (cl-cc/javascript:shape-slot-offset reordered 'second) :to-equal 0)))) + +(it-sequential "vm-object-shape-cache-copies-slot-list-keys" + (let ((cl-cc/javascript:*shape-registry* (make-hash-table :test #'equal))) + (let* ((slots (list 'first 'second)) + (shape (cl-cc/javascript:find-or-create-shape 'mutable-layout slots))) + (setf (cdr slots) nil) + (expect (cl-cc/javascript:find-or-create-shape 'mutable-layout '(first second)) + :to-be shape)))) + +(it-sequential "vm-object-shape-slot-offsets-use-equal-string-keys" + (let ((cl-cc/javascript:*shape-registry* (make-hash-table :test #'equal))) + (let* ((stored-slot (copy-seq "property")) + (lookup-slot (copy-seq "property")) + (shape (cl-cc/javascript:find-or-create-shape + 'string-slot-layout (list stored-slot))) + (same-shape (cl-cc/javascript:find-or-create-shape + 'string-slot-layout (list lookup-slot)))) + (expect (not (eq stored-slot lookup-slot)) :to-be-truthy) + (expect same-shape :to-be shape) + (expect (cl-cc/javascript:shape-slot-offset shape lookup-slot) :to-equal 0)))) + +(it-sequential "vm-object-shape-cache-copies-mutable-string-keys" + (let ((cl-cc/javascript:*shape-registry* (make-hash-table :test #'equal))) + (let* ((caller-slot (copy-seq "property")) + (shape (cl-cc/javascript:find-or-create-shape + 'mutable-string-layout (list caller-slot)))) + (setf (char caller-slot 0) #\X) + (let* ((same-shape + (cl-cc/javascript:find-or-create-shape + 'mutable-string-layout (list (copy-seq "property")))) + (offset (cl-cc/javascript:shape-slot-offset + shape (copy-seq "property")))) + (expect caller-slot :to-equal "Xroperty") + (expect same-shape :to-be shape) + (expect offset :to-equal 0))))) + +(it-sequential "vm-object-imt-reinsertion-preserves-collision-chain" + (let ((buckets (make-array cl-cc/javascript:+imt-size+ :initial-element nil)) + (selectors nil)) + (loop for index below (1+ (* 2 cl-cc/javascript:+imt-size+)) + for selector = (make-symbol (format nil "IMT-SELECTOR-~D" index)) + for bucket = (mod (sxhash selector) cl-cc/javascript:+imt-size+) + do (push selector (aref buckets bucket)) + when (= (length (aref buckets bucket)) 3) + do (setf selectors (subseq (aref buckets bucket) 0 3)) + (return)) + (let* ((imt (cl-cc/javascript:make-inline-method-table)) + (first-impl (lambda () :first)) + (second-impl (lambda () :second)) + (third-impl (lambda () :third)) + (first-update (lambda () :first-update)) + (second-update (lambda () :second-update))) + (loop for selector in selectors + for impl in (list first-impl second-impl third-impl) + do (cl-cc/javascript:imt-insert imt selector impl)) + (cl-cc/javascript:imt-insert imt (first selectors) first-update) + (cl-cc/javascript:imt-insert imt (second selectors) second-update) + (expect (eq (cl-cc/javascript:imt-lookup imt (first selectors)) first-update) + :to-be-truthy) + (expect (eq (cl-cc/javascript:imt-lookup imt (second selectors)) second-update) + :to-be-truthy) + (expect (eq (cl-cc/javascript:imt-lookup imt (third selectors)) third-impl) + :to-be-truthy)))) + +(it-sequential "vm-object-mark-word-packs-64-bit-boundaries" + (let ((mark-word + (cl-cc/javascript:make-mark-word + :gc-color 3 + :object-kind 3 + :identity-hash 268435455 + :lock-state 4294967295))) + (expect mark-word :to-equal (1- (ash 1 64))) + (expect (cl-cc/javascript:mark-word-gc-color mark-word) :to-equal 3) + (expect (cl-cc/javascript:make-mark-word :gc-color 1) :to-equal 1) + (expect (cl-cc/javascript:make-mark-word :object-kind 1) + :to-equal (ash 1 2)) + (expect (cl-cc/javascript:make-mark-word :identity-hash 1) + :to-equal (ash 1 4)) + (expect (cl-cc/javascript:make-mark-word :lock-state 1) + :to-equal (ash 1 32)))) + +(it-sequential-each ((:gc-color -1) + (:gc-color 4) + (:object-kind -1) + (:object-kind 4) + (:identity-hash -1) + (:identity-hash 268435456) + (:lock-state -1) + (:lock-state 4294967296)) + "vm-object-mark-word-rejects-out-of-range-~S-~S" + (key value) + (expect (handler-case + (progn (apply #'cl-cc/javascript:make-mark-word (list key value)) nil) + (type-error () t)) + :to-be-truthy)) + +(it-sequential "vm-object-value-type-registers-its-fields" + (let ((cl-cc/javascript:*value-types* (make-hash-table :test #'eq))) + (expect (cl-cc/javascript:defvalue-type point2d + (x :type single-float) + (y :type single-float)) + :to-equal 'point2d) + (let ((definition (gethash 'point2d cl-cc/javascript:*value-types*))) + (expect (typep definition 'cl-cc/javascript:value-type-def) :to-be-truthy) + (expect (cl-cc/javascript::value-type-def-fields definition) + :to-equal '((x :type single-float) (y :type single-float))) + (expect (cl-cc/javascript::value-type-def-total-size definition) :to-equal 2)))) From 355b66bb2316ae01ab549bfffdc757de4ee77de1 Mon Sep 17 00:00:00 2001 From: takeokunn Date: Mon, 26 Oct 2026 17:30:51 +0900 Subject: [PATCH 2/2] test: remove redundant VM test-file header --- t/runtime-vm-objects-test.lisp | 1 - 1 file changed, 1 deletion(-) diff --git a/t/runtime-vm-objects-test.lisp b/t/runtime-vm-objects-test.lisp index 1f78752..f801446 100644 --- a/t/runtime-vm-objects-test.lisp +++ b/t/runtime-vm-objects-test.lisp @@ -1,4 +1,3 @@ -;;;; Tests for VM object shapes, inline method tables, mark words, and value types. (in-package :cl-cc-javascript/test) (it-sequential "vm-object-shape-cache-distinguishes-class-and-layout"