[W3.2.vm] Move VM object helpers into JavaScript

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

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*))

t/runtime-vm-objects-test.lisp

@@ -0,0 +1,122 @@
+(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))))