438 lines
19 KiB
EmacsLisp
438 lines
19 KiB
EmacsLisp
;;; etaf-compiler.el --- AOT View blueprints for ETAF -*- lexical-binding: t; -*-
|
|
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; This is the first compiler slice: structured View topology and literal
|
|
;; values are emitted into an immutable blueprint during byte compilation.
|
|
;; Runtime instantiation constructs only nodes on paths containing dynamic
|
|
;; property holes. Unsupported structural forms use the existing View
|
|
;; compiler unchanged.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'etaf-view)
|
|
|
|
(defvar read-eval)
|
|
|
|
(defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/1")
|
|
(defconst etaf-compiler-app-artifact-abi "etaf-app/3")
|
|
|
|
(define-error 'etaf-compiler-artifact-error "Invalid ETAF App artifact")
|
|
(define-error 'etaf-compiler-stale-artifact "Stale ETAF App artifact"
|
|
'etaf-compiler-artifact-error)
|
|
|
|
(defvar etaf-compiler--static-cache (make-hash-table :test #'equal))
|
|
(defvar etaf-compiler--artifact-blueprints (make-hash-table :test #'equal))
|
|
(defvar etaf-compiler--artifact-blueprint-owners
|
|
(make-hash-table :test #'equal))
|
|
(defvar etaf-compiler--active-artifacts (make-hash-table :test #'equal))
|
|
(defvar etaf-compiler--registry-epoch 0)
|
|
(defvar etaf-compiler--instantiate-count 0)
|
|
(defvar etaf-compiler--fallback-count 0)
|
|
(defvar etaf-compiler--last-blueprint nil)
|
|
(defvar etaf-compiler--artifact-hit-count 0)
|
|
(defvar etaf-compiler--artifact-miss-count 0)
|
|
(defvar etaf-compiler--last-artifact-status nil)
|
|
|
|
(defun etaf-compiler-deactivate-app-artifact (name)
|
|
"Remove App NAME's active artifact and unowned blueprints."
|
|
(when-let ((artifact (gethash name etaf-compiler--active-artifacts)))
|
|
(dolist (entry (plist-get artifact :blueprints))
|
|
(let* ((id (plist-get entry :id))
|
|
(owners (delete name
|
|
(copy-sequence
|
|
(gethash id
|
|
etaf-compiler--artifact-blueprint-owners)))))
|
|
(if owners
|
|
(puthash id owners etaf-compiler--artifact-blueprint-owners)
|
|
(remhash id etaf-compiler--artifact-blueprint-owners)
|
|
(remhash id etaf-compiler--artifact-blueprints))))
|
|
(remhash name etaf-compiler--active-artifacts)))
|
|
|
|
(defun etaf-compiler-note-registry-change ()
|
|
"Invalidate the static Component-call cache after a registry change."
|
|
(cl-incf etaf-compiler--registry-epoch)
|
|
(clrhash etaf-compiler--static-cache))
|
|
|
|
(defun etaf-compiler-clear-cache ()
|
|
"Clear all process-local compiled View materializations."
|
|
(interactive)
|
|
(clrhash etaf-compiler--static-cache))
|
|
|
|
(defun etaf-compiler-note-artifact-miss (reason)
|
|
"Record a rejected or unavailable App artifact REASON."
|
|
(cl-incf etaf-compiler--artifact-miss-count)
|
|
(setq etaf-compiler--last-artifact-status reason))
|
|
|
|
(defun etaf-compiler-statistics ()
|
|
"Return a read-only snapshot of compiler runtime statistics."
|
|
(list :abi etaf-compiler-blueprint-abi
|
|
:instantiations etaf-compiler--instantiate-count
|
|
:fallbacks etaf-compiler--fallback-count
|
|
:artifact-hits etaf-compiler--artifact-hit-count
|
|
:artifact-misses etaf-compiler--artifact-miss-count
|
|
:last-artifact-status etaf-compiler--last-artifact-status
|
|
:static-cache-entries (hash-table-count etaf-compiler--static-cache)
|
|
:last-blueprint
|
|
(and etaf-compiler--last-blueprint
|
|
(list :id (plist-get etaf-compiler--last-blueprint :id)
|
|
:static-nodes
|
|
(plist-get etaf-compiler--last-blueprint :static-nodes)
|
|
:dynamic-nodes
|
|
(plist-get etaf-compiler--last-blueprint :dynamic-nodes)
|
|
:hole-count
|
|
(plist-get etaf-compiler--last-blueprint :hole-count)))
|
|
:registry-epoch etaf-compiler--registry-epoch))
|
|
|
|
(defun etaf-compiler--read-forms (file)
|
|
"Read every inert Lisp form from FILE."
|
|
(with-temp-buffer
|
|
(insert-file-contents file)
|
|
(goto-char (point-min))
|
|
(let ((read-eval nil) forms form done)
|
|
(while (not done)
|
|
(condition-case nil
|
|
(progn (setq form (read (current-buffer))) (push form forms))
|
|
(end-of-file (setq done t))))
|
|
(nreverse forms))))
|
|
|
|
(defun etaf-compiler--read-single-form (file)
|
|
"Read exactly one inert Lisp form from FILE."
|
|
(let ((forms (etaf-compiler--read-forms file)))
|
|
(unless (= (length forms) 1)
|
|
(signal 'etaf-compiler-artifact-error
|
|
(list :expected-one-form file (length forms))))
|
|
(car forms)))
|
|
|
|
(defun etaf-compiler--collect-blueprints (form)
|
|
"Return compiled blueprints found below source FORM."
|
|
(let (blueprints)
|
|
(cl-labels
|
|
((visit (value)
|
|
(when (consp value)
|
|
(cond
|
|
((memq (car value) '(quote function)) nil)
|
|
((and (memq (car value) '(etaf-view etaf-compiled-view))
|
|
(cadr value))
|
|
(when-let* ((compiled (etaf-compiler--compile (cadr value)))
|
|
(blueprint (car compiled))
|
|
((etaf-compiler--beneficial-blueprint-p blueprint)))
|
|
(push blueprint blueprints)))
|
|
(t (visit (car value))
|
|
(visit (cdr value)))))))
|
|
(visit form))
|
|
(nreverse blueprints)))
|
|
|
|
(defun etaf-compiler--source-record (file)
|
|
"Return the content hash record for FILE."
|
|
(list :file (file-name-nondirectory file)
|
|
:sha256 (with-temp-buffer
|
|
(insert-file-contents-literally file)
|
|
(secure-hash 'sha256 (current-buffer)))))
|
|
|
|
(defun etaf-compiler--write-artifact (artifact output)
|
|
"Atomically write data-only ARTIFACT to OUTPUT."
|
|
(let* ((directory (file-name-directory (expand-file-name output)))
|
|
(_ (make-directory directory t))
|
|
(temporary (make-temp-file (expand-file-name ".etafc-" directory))))
|
|
(unwind-protect
|
|
(progn
|
|
(with-temp-file temporary
|
|
(let ((print-circle nil) (print-length nil) (print-level nil))
|
|
(prin1 artifact (current-buffer))
|
|
(insert "\n")))
|
|
(rename-file temporary output t)
|
|
(setq temporary nil)
|
|
output)
|
|
(when (and temporary (file-exists-p temporary))
|
|
(delete-file temporary)))))
|
|
|
|
;;;###autoload
|
|
(cl-defun etaf-compiler-write-app-artifact
|
|
(&key name source static style output)
|
|
"Compile one App into data-only OUTPUT.
|
|
NAME identifies the App. SOURCE is its Elisp companion, STATIC its inert
|
|
`.etaf' input, and STYLE its optional `.ecss' input."
|
|
(unless (and (stringp name) (file-readable-p source)
|
|
(file-readable-p static) (stringp output))
|
|
(signal 'wrong-type-argument
|
|
(list 'etaf-app-source name source static output)))
|
|
(let (blueprints)
|
|
(dolist (form (etaf-compiler--read-forms source))
|
|
(setq blueprints
|
|
(append blueprints
|
|
(etaf-compiler--collect-blueprints form))))
|
|
(setq blueprints
|
|
(delete-dups blueprints))
|
|
(let ((artifact
|
|
(list :kind 'etaf/app-artifact
|
|
:abi etaf-compiler-app-artifact-abi
|
|
:app name
|
|
:sources
|
|
(delq nil
|
|
(list (etaf-compiler--source-record source)
|
|
(etaf-compiler--source-record static)
|
|
(and style (etaf-compiler--source-record style))))
|
|
:static-form (etaf-compiler--read-single-form static)
|
|
:style-form (and style
|
|
(etaf-compiler--read-single-form style))
|
|
:blueprints
|
|
(mapcar (lambda (blueprint)
|
|
(list :id (plist-get blueprint :id)
|
|
:blueprint blueprint))
|
|
blueprints))))
|
|
(etaf-compiler--write-artifact artifact output))))
|
|
|
|
(defun etaf-compiler--validate-source-records (artifact base-directory)
|
|
"Signal when ARTIFACT does not match BASE-DIRECTORY."
|
|
(dolist (record (plist-get artifact :sources))
|
|
(let ((file (expand-file-name (plist-get record :file) base-directory)))
|
|
(unless (and (file-readable-p file)
|
|
(equal (with-temp-buffer
|
|
(insert-file-contents-literally file)
|
|
(secure-hash 'sha256 (current-buffer)))
|
|
(plist-get record :sha256)))
|
|
(signal 'etaf-compiler-stale-artifact
|
|
(list :source file))))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-load-app-artifact (file base-directory)
|
|
"Load FILE after validating it against BASE-DIRECTORY."
|
|
(let ((artifact (etaf-compiler--read-single-form file)))
|
|
(unless (and (eq (plist-get artifact :kind) 'etaf/app-artifact)
|
|
(equal (plist-get artifact :abi)
|
|
etaf-compiler-app-artifact-abi)
|
|
(stringp (plist-get artifact :app)))
|
|
(signal 'etaf-compiler-artifact-error (list :manifest file)))
|
|
(etaf-compiler--validate-source-records artifact base-directory)
|
|
(etaf-compiler-deactivate-app-artifact (plist-get artifact :app))
|
|
(dolist (entry (plist-get artifact :blueprints))
|
|
(let ((blueprint (plist-get entry :blueprint)))
|
|
(unless (and (equal (plist-get entry :id) (plist-get blueprint :id))
|
|
(equal (plist-get blueprint :abi)
|
|
etaf-compiler-blueprint-abi))
|
|
(signal 'etaf-compiler-artifact-error
|
|
(list :blueprint entry)))
|
|
(puthash (plist-get entry :id) blueprint
|
|
etaf-compiler--artifact-blueprints)
|
|
(cl-pushnew (plist-get artifact :app)
|
|
(gethash (plist-get entry :id)
|
|
etaf-compiler--artifact-blueprint-owners)
|
|
:test #'equal)))
|
|
(puthash (plist-get artifact :app) artifact
|
|
etaf-compiler--active-artifacts)
|
|
(setq etaf-compiler--last-artifact-status 'loaded)
|
|
artifact))
|
|
|
|
(defun etaf-compiler--literal (form)
|
|
"Return `(t . VALUE)' when FORM is a portable literal, otherwise nil."
|
|
(cond
|
|
((or (null form) (eq form t) (numberp form) (stringp form)
|
|
(characterp form) (keywordp form))
|
|
(cons t form))
|
|
((and (consp form) (eq (car form) 'quote) (null (cddr form)))
|
|
(cons t (cadr form)))
|
|
(t nil)))
|
|
|
|
(defun etaf-compiler--compile-property (form programs)
|
|
"Compile property FORM, returning `(DESCRIPTOR . PROGRAMS)'."
|
|
(if-let ((literal (etaf-compiler--literal form)))
|
|
(cons (list :kind 'static :value (cdr literal)) programs)
|
|
(let ((index (length programs)))
|
|
(cons (list :kind 'hole :index index)
|
|
(append programs (list `(lambda () ,form)))))))
|
|
|
|
(defun etaf-compiler--compile-block (form path programs)
|
|
"Compile View FORM at PATH, returning `(BLOCK PROGRAMS)' or nil."
|
|
(cond
|
|
((or (null form) (stringp form))
|
|
(list (list :kind 'literal :value form :path path :static-p t) programs))
|
|
((not (and (consp form) (symbolp (car form)))) nil)
|
|
((eq (car form) 'expr)
|
|
(let ((index (length programs)))
|
|
(list (list :kind 'expr :path path :hole index :static-p nil)
|
|
(append programs
|
|
(list `(lambda () ,(etaf--parse-expr-form (cdr form))))))))
|
|
((memq (car form) '(slot raw-ebox)) nil)
|
|
((etaf--ordinary-expression-head-p (car form)) nil)
|
|
(t
|
|
(let* ((parts (etaf--parse-attributes-and-children (cdr form)))
|
|
(props (car parts))
|
|
(children (cdr parts))
|
|
(compiled-props nil)
|
|
(compiled-children nil)
|
|
(all-static t)
|
|
(tail props)
|
|
(child-index 0)
|
|
result)
|
|
(while tail
|
|
(let* ((key (pop tail))
|
|
(value (pop tail))
|
|
(compiled (etaf-compiler--compile-property value programs))
|
|
(descriptor (car compiled)))
|
|
(setq programs (cdr compiled))
|
|
(unless (eq (plist-get descriptor :kind) 'static)
|
|
(setq all-static nil))
|
|
(setq compiled-props
|
|
(append compiled-props (list key descriptor)))))
|
|
(while (and children (not (eq result 'unsupported)))
|
|
(let ((compiled
|
|
(etaf-compiler--compile-block
|
|
(pop children) (append path (list child-index)) programs)))
|
|
(if (not compiled)
|
|
(setq result 'unsupported)
|
|
(let ((block (car compiled)))
|
|
(setq programs (cadr compiled)
|
|
compiled-children (append compiled-children (list block)))
|
|
(unless (plist-get block :static-p) (setq all-static nil)))))
|
|
(cl-incf child-index))
|
|
(unless (eq result 'unsupported)
|
|
(list (list :kind 'node :name (car form) :path path
|
|
:props compiled-props :children compiled-children
|
|
:static-p all-static)
|
|
programs))))))
|
|
|
|
(defun etaf-compiler--block-counts (block)
|
|
"Return `(STATIC . DYNAMIC)' node counts below BLOCK."
|
|
(if (eq (plist-get block :kind) 'literal)
|
|
(cons 0 0)
|
|
(let ((static (if (plist-get block :static-p) 1 0))
|
|
(dynamic (if (plist-get block :static-p) 0 1)))
|
|
(dolist (child (plist-get block :children))
|
|
(pcase-let ((`(,child-static . ,child-dynamic)
|
|
(etaf-compiler--block-counts child)))
|
|
(cl-incf static child-static)
|
|
(cl-incf dynamic child-dynamic)))
|
|
(cons static dynamic))))
|
|
|
|
(defun etaf-compiler--beneficial-blueprint-p (blueprint)
|
|
"Return non-nil when BLUEPRINT can reuse at least one static node."
|
|
(> (or (plist-get blueprint :static-nodes) 0) 0))
|
|
|
|
(defun etaf-compiler--compile (form)
|
|
"Compile FORM into `(BLUEPRINT PROGRAM-CODE...)', or return nil."
|
|
(when-let ((compiled (etaf-compiler--compile-block form '(0) nil)))
|
|
(let* ((root (car compiled))
|
|
(programs (cadr compiled))
|
|
(id (secure-hash 'sha256 (prin1-to-string form)))
|
|
(counts (etaf-compiler--block-counts root)))
|
|
(cons (list :kind 'etaf/view-blueprint
|
|
:abi etaf-compiler-blueprint-abi
|
|
:id id :root root
|
|
:static-nodes (car counts)
|
|
:dynamic-nodes (cdr counts)
|
|
:hole-count (length programs))
|
|
programs))))
|
|
|
|
(defun etaf-compiler--materialize (blueprint block programs)
|
|
"Materialize BLOCK from BLUEPRINT using PROGRAMS."
|
|
(let* ((static-p (plist-get block :static-p))
|
|
(cache-key (and static-p
|
|
(list (plist-get blueprint :id)
|
|
(plist-get block :path)
|
|
etaf-compiler--registry-epoch)))
|
|
(missing (make-symbol "etaf-compiled-missing"))
|
|
(cached (and cache-key
|
|
(gethash cache-key etaf-compiler--static-cache missing))))
|
|
(if (and cache-key (not (eq cached missing)))
|
|
cached
|
|
(let ((value
|
|
(pcase (plist-get block :kind)
|
|
('literal (plist-get block :value))
|
|
('expr
|
|
(etaf--expr-create
|
|
:token (list 'etaf-compiled-site
|
|
(plist-get blueprint :id)
|
|
(plist-get block :path))
|
|
:thunk (aref programs (plist-get block :hole))))
|
|
('node
|
|
(let ((props nil))
|
|
(cl-loop for (key descriptor) on (plist-get block :props)
|
|
by #'cddr
|
|
do (setq props
|
|
(append
|
|
props
|
|
(list
|
|
key
|
|
(if (eq (plist-get descriptor :kind)
|
|
'static)
|
|
(plist-get descriptor :value)
|
|
(etaf--expr-create
|
|
:thunk
|
|
(aref programs
|
|
(plist-get descriptor
|
|
:index))))))))
|
|
(etaf--view-call
|
|
(plist-get block :name) props
|
|
(mapcar (lambda (child)
|
|
(etaf-compiler--materialize
|
|
blueprint child programs))
|
|
(plist-get block :children))
|
|
(list 'etaf-compiled-site
|
|
(plist-get blueprint :id)
|
|
(plist-get block :path)))))
|
|
(_ (error "Unknown ETAF compiled block: %S" block)))))
|
|
(when cache-key
|
|
(puthash cache-key value etaf-compiler--static-cache))
|
|
value))))
|
|
|
|
;;;###autoload
|
|
(defun etaf-compiler-instantiate (blueprint programs)
|
|
"Instantiate compiled View BLUEPRINT with dynamic PROGRAMS."
|
|
(unless (and (eq (plist-get blueprint :kind) 'etaf/view-blueprint)
|
|
(equal (plist-get blueprint :abi)
|
|
etaf-compiler-blueprint-abi)
|
|
(stringp (plist-get blueprint :id))
|
|
(vectorp programs)
|
|
(= (length programs) (plist-get blueprint :hole-count)))
|
|
(error "Invalid or incompatible ETAF View blueprint"))
|
|
(let ((artifact-blueprint
|
|
(gethash (plist-get blueprint :id)
|
|
etaf-compiler--artifact-blueprints)))
|
|
(if artifact-blueprint
|
|
(progn
|
|
(cl-incf etaf-compiler--artifact-hit-count)
|
|
(setq etaf-compiler--last-artifact-status 'hit
|
|
blueprint artifact-blueprint))
|
|
(cl-incf etaf-compiler--artifact-miss-count)
|
|
(setq etaf-compiler--last-artifact-status 'embedded-fallback))
|
|
(cl-incf etaf-compiler--instantiate-count)
|
|
(setq etaf-compiler--last-blueprint blueprint)
|
|
(etaf-compiler--materialize
|
|
blueprint (plist-get blueprint :root) programs)))
|
|
|
|
(defun etaf-compiler-expand-view
|
|
(form &optional slot-mode artifact-required count-fallback)
|
|
"Return compiler expansion for View FORM.
|
|
SLOT-MODE is forwarded to the legacy compiler. ARTIFACT-REQUIRED keeps the
|
|
legacy path unless a manually loaded artifact contains the blueprint.
|
|
COUNT-FALLBACK records an unsupported explicit compiler request."
|
|
(let* ((compiled (etaf-compiler--compile form))
|
|
(blueprint (car compiled))
|
|
(legacy (etaf--compile-view-form form (or slot-mode :projection))))
|
|
(if (and compiled (etaf-compiler--beneficial-blueprint-p blueprint))
|
|
(let ((instantiate
|
|
`(etaf-compiler-instantiate
|
|
',blueprint (vector ,@(cdr compiled)))))
|
|
(if artifact-required
|
|
`(if (gethash ,(plist-get blueprint :id)
|
|
etaf-compiler--artifact-blueprints)
|
|
,instantiate
|
|
,legacy)
|
|
instantiate))
|
|
(if count-fallback
|
|
`(progn (cl-incf etaf-compiler--fallback-count) ,legacy)
|
|
legacy))))
|
|
|
|
;;;###autoload
|
|
(defmacro etaf-compiled-view (form)
|
|
"Compatibility spelling for explicitly compiled View FORM."
|
|
(declare (indent 1) (debug (form)))
|
|
(etaf-compiler-expand-view form :projection nil t))
|
|
|
|
(provide 'etaf-compiler)
|
|
;;; etaf-compiler.el ends here
|